sdl2-ttf-2.1.1/ 0000755 0000000 0000000 00000000000 07346545000 011343 5 ustar 00 0000000 0000000 sdl2-ttf-2.1.1/LICENSE 0000644 0000000 0000000 00000005363 07346545000 012357 0 ustar 00 0000000 0000000 Copyright (c) 2013-2020 Ömer Sinan Ağacan, Siniša Biđin, Rongcui Dong
and others (see git commits)
This code is licensed under MIT or BSD3 licenses, so that the user
can chose between these two licenses.
MIT licence text follows.
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is furnished to do
so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
BSD3 licence text follows.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Rongcui Dong nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
sdl2-ttf-2.1.1/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 013000 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
sdl2-ttf-2.1.1/cbits/ 0000755 0000000 0000000 00000000000 07346545000 012447 5 ustar 00 0000000 0000000 sdl2-ttf-2.1.1/cbits/helpers.c 0000644 0000000 0000000 00000006247 07346545000 014266 0 ustar 00 0000000 0000000 #include "SDL.h"
#include "SDL_ttf.h"
// Lots of SDL_ttf's render functions accept an SDL_Color directly. We send in
// a pointer instead, which we dereference here. Is there a way to avoid this?
// Note the "_p" added to the function names.
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUNICODE_Solid_p(
TTF_Font *font,
uint16_t *text,
SDL_Color *fg) {
return TTF_RenderUNICODE_Solid(font, text, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUNICODE_Shaded_p(
TTF_Font *font,
uint16_t *text,
SDL_Color *fg,
SDL_Color *bg) {
return TTF_RenderUNICODE_Shaded(font, text, *fg, *bg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUNICODE_Blended_p(
TTF_Font *font,
uint16_t *text,
SDL_Color *fg) {
return TTF_RenderUNICODE_Blended(font, text, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUTF8_Solid_p(
TTF_Font *font,
const char *text,
SDL_Color *fg) {
return TTF_RenderUTF8_Solid(font, text, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUTF8_Shaded_p(
TTF_Font *font,
const char *text,
SDL_Color *fg,
SDL_Color *bg) {
return TTF_RenderUTF8_Shaded(font, text, *fg, *bg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUTF8_Blended_p(
TTF_Font *font,
const char *text,
SDL_Color *fg) {
return TTF_RenderUTF8_Blended(font, text, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderText_Solid_p(
TTF_Font *font,
const char *text,
SDL_Color *fg) {
return TTF_RenderText_Solid(font, text, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderText_Shaded_p(
TTF_Font *font,
const char *text,
SDL_Color *fg,
SDL_Color *bg) {
return TTF_RenderText_Shaded(font, text, *fg, *bg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderText_Blended_p(
TTF_Font *font,
const char *text,
SDL_Color *fg) {
return TTF_RenderText_Blended(font, text, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderGlyph_Solid_p(
TTF_Font *font,
uint16_t glyph,
SDL_Color *fg) {
return TTF_RenderGlyph_Solid(font, glyph, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderGlyph_Shaded_p(
TTF_Font *font,
uint16_t glyph,
SDL_Color *fg,
SDL_Color *bg) {
return TTF_RenderGlyph_Shaded(font, glyph, *fg, *bg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderGlyph_Blended_p(
TTF_Font *font,
uint16_t glyph,
SDL_Color *fg) {
return TTF_RenderGlyph_Blended(font, glyph, *fg);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUTF8_Blended_Wrapped_p(
TTF_Font *font,
const char *text,
SDL_Color *fg,
uint32_t wrapLength) {
return TTF_RenderUTF8_Blended_Wrapped(font, text, *fg, wrapLength);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderUNICODE_Blended_Wrapped_p(
TTF_Font *font,
uint16_t *text,
SDL_Color *fg,
uint32_t wrapLength) {
return TTF_RenderUNICODE_Blended_Wrapped(font, text, *fg, wrapLength);
}
extern DECLSPEC SDL_Surface * SDLCALL
TTF_RenderText_Blended_Wrapped_p(
TTF_Font *font,
const char *text,
SDL_Color *fg,
uint32_t wrapLength) {
return TTF_RenderText_Blended_Wrapped(font, text, *fg, wrapLength);
}
sdl2-ttf-2.1.1/example/ 0000755 0000000 0000000 00000000000 07346545000 012776 5 ustar 00 0000000 0000000 sdl2-ttf-2.1.1/example/Example.hs 0000644 0000000 0000000 00000011001 07346545000 014716 0 ustar 00 0000000 0000000 {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (threadDelay)
import Control.Monad (forM_)
import Data.ByteString (readFile)
import Data.Text (Text, unpack)
import Data.Text.IO (putStrLn)
import Prelude hiding (putStrLn, readFile)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import qualified SDL
import qualified SDL.Font
red :: SDL.Font.Color
red = SDL.V4 255 0 0 0
gray :: SDL.Font.Color
gray = SDL.V4 128 128 128 255
-- A sequence of example actions to be perfomed and displayed.
examples :: [(Text, SDL.Window -> FilePath -> IO ())]
examples = [
("Blitting solid",
\window path -> do
font <- SDL.Font.load path 70
text <- SDL.Font.solid font red "Solid!"
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window),
("Blitting shaded",
\window path -> do
font <- SDL.Font.load path 70
text <- SDL.Font.shaded font red gray "Shaded!"
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window),
("Blitting blended",
\window path -> do
font <- SDL.Font.load path 70
text <- SDL.Font.blended font red "Blended!"
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window),
("Blitting styled",
\window path -> do
font <- SDL.Font.load path 65
let styles = [SDL.Font.Bold, SDL.Font.Underline, SDL.Font.Italic]
SDL.Font.setStyle font styles
print =<< SDL.Font.getStyle font
text <- SDL.Font.blended font red "Styled!"
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window),
("Blitting outlined",
\window path -> do
font <- SDL.Font.load path 65
SDL.Font.setOutline font 3
print =<< SDL.Font.getOutline font
text <- SDL.Font.blended font red "Outlined!"
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window),
("Decoding from bytestring",
\window path -> do
bytes <- readFile path
font <- SDL.Font.decode bytes 40
let chars = "Decoded~~~!"
putStrLn "How big will the surface be?"
print =<< SDL.Font.size font chars
text <- SDL.Font.blended font gray chars
putStrLn "Style and family names?"
print =<< SDL.Font.styleName font
print =<< SDL.Font.familyName font
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window),
("Render a single glyph",
\window path -> do
font <- SDL.Font.load path 100
text <- SDL.Font.blendedGlyph font red 'ŏ'
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window),
("Check existence of weird chars, blit them",
\window path -> do
font <- SDL.Font.load path 80
putStrLn " Glyphs provided or not:"
let chars = "☃Δ✭!"
exist <- mapM (SDL.Font.glyphProvided font) $ unpack chars
print $ zip (unpack chars) exist
putStrLn " Metrics:"
metrics <- mapM (SDL.Font.glyphMetrics font) $ unpack chars
print $ zip (unpack chars) metrics
text <- SDL.Font.blended font red chars
SDL.Font.free font
screen <- SDL.getWindowSurface window
SDL.surfaceBlit text Nothing screen Nothing
SDL.freeSurface text
SDL.updateWindowSurface window)
]
main :: IO ()
main = do
SDL.initialize [SDL.InitVideo]
SDL.Font.initialize
getArgs >>= \case
[] -> do
putStrLn "Usage: cabal run path/to/font.(ttf|fon)"
exitFailure
-- Run each of the examples within a newly-created window.
(path:_) ->
forM_ examples $ \(name, action) -> do
putStrLn name
window <- SDL.createWindow name SDL.defaultWindow
SDL.showWindow window
action window path
threadDelay 1000000
SDL.destroyWindow window
SDL.Font.quit
SDL.quit
sdl2-ttf-2.1.1/sdl2-ttf.cabal 0000644 0000000 0000000 00000003422 07346545000 013767 0 ustar 00 0000000 0000000 name: sdl2-ttf
version: 2.1.1
synopsis: Bindings to SDL2_ttf.
description: Haskell bindings to SDL2_ttf C++ library .
bug-reports: https://github.com/haskell-game/sdl2-ttf/issues
license: BSD3
license-file: LICENSE
maintainer: Mikolaj Konarski
author: Rongcui Dong (rongcuid@outlook.com),
Siniša Biđin ,
Ömer Sinan Ağacan (omeragacan@gmail.com),
Sean Chalmers (sclhiannan@gmail.com)
copyright: Copyright © 2013-2017 Ömer Sinan Ağacan, Siniša Biđin, Rongcui Dong
category: Font, Foreign binding, Graphics
build-type: Simple
cabal-version: >=1.10
tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2, GHC==8.6.5, GHC==8.8.3
source-repository head
type: git
location: https://github.com/haskell-game/sdl2-ttf
library
ghc-options: -Wall
exposed-modules:
SDL.Font,
SDL.Raw.Font
other-modules:
SDL.Raw.Helper
hs-source-dirs:
src
pkgconfig-depends:
sdl2 >= 2.0.3,
SDL2_ttf >= 2.0.12
c-sources:
cbits/helpers.c
build-depends:
base >= 4.8 && < 5,
bytestring >= 0.10.4.0,
sdl2 >= 2.2,
template-haskell,
text >= 1.1.0.0,
transformers >= 0.4
default-language:
Haskell2010
if os(windows)
cpp-options: -D_SDL_main_h -DSDL_main_h_
flag example
description: Build the example executable
default: False
executable sdl2-ttf-example
ghc-options: -Wall
hs-source-dirs: example
main-is: Example.hs
default-language: Haskell2010
if flag(example)
build-depends:
base,
bytestring,
sdl2,
sdl2-ttf,
text
else
buildable: False
sdl2-ttf-2.1.1/src/SDL/ 0000755 0000000 0000000 00000000000 07346545000 012554 5 ustar 00 0000000 0000000 sdl2-ttf-2.1.1/src/SDL/Font.hs 0000644 0000000 0000000 00000043252 07346545000 014024 0 ustar 00 0000000 0000000 {-|
Module : SDL.Font
Copyright : (c) 2015 Siniša Biđin
License : MIT
Stability : experimental
Bindings to the @SDL2_ttf@ library
which itself is a wrapper around the FreeType library.
The bindings should allow you to load fonts and
render 'Text' in various styles to an @SDL@ 'Surface'.
You can safely assume that any monadic function listed here is capable of
throwing an 'SDLException' in case it encounters an error.
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module SDL.Font
(
-- * General
initialize
, version
, quit
-- * Loading
--
-- | Use the following functions to load @TTF@ and @FON@ file formats.
, Font(..)
, PointSize
, load
, Index
, loadIndex
, decode
, decodeIndex
, free
-- * Rendering
--
-- | Use the following functions to render text to a 'Surface'.
--
-- The methods available are described in more detail in the original
-- @SDL2_ttf@ documentation
-- .
, Color
, solid
, shaded
, blended
, size
-- * Attributes
, Style(..)
, getStyle
, setStyle
, Outline
, getOutline
, setOutline
, Hinting(..)
, getHinting
, setHinting
, Kerning
, getKerning
, setKerning
, isMonospace
, familyName
, styleName
, height
, ascent
, descent
, lineSkip
, getKerningSize
-- * Glyphs
--
-- | Functions that work with individual glyphs.
, glyphProvided
, glyphIndex
, glyphMetrics
, solidGlyph
, shadedGlyph
, blendedGlyph
, blendedWrapped
) where
import Control.Exception (throwIO)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits ((.&.), (.|.))
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackCString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Foreign (lengthWord16, unsafeCopyToPtr)
import Data.Word (Word8, Word16)
import Foreign.C.String (CString, withCString)
import Foreign.C.Types (CUShort, CInt)
import Foreign.Marshal.Alloc (allocaBytes, alloca)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (peek, pokeByteOff)
import GHC.Generics (Generic)
import SDL (Surface(..), SDLException(SDLCallFailed))
import SDL.Internal.Exception
import SDL.Raw.Filesystem (rwFromConstMem)
import SDL.Vect (V4(..))
import qualified SDL.Raw
import qualified SDL.Raw.Font
-- | Gets the major, minor, patch versions of the linked @SDL2_ttf@ library.
--
-- You may call this without initializing the library with 'initialize'.
version :: (Integral a, MonadIO m) => m (a, a, a)
version = liftIO $ do
SDL.Raw.Version major minor patch <- peek =<< SDL.Raw.Font.getVersion
return (fromIntegral major, fromIntegral minor, fromIntegral patch)
-- | Initializes the library.
--
-- Unless noted otherwise, this must be called before any other part of the
-- library is used.
--
-- You may call this multiple times.
initialize :: MonadIO m => m ()
initialize = do
init'd <- (== 1) `fmap` SDL.Raw.Font.wasInit
unless init'd $
throwIfNeg_ "SDL.Font.initialize" "TTF_Init" SDL.Raw.Font.init
-- | Cleans up any resources still in use by the library.
--
-- If called, you must call 'initialize' again before using any other parts of
-- the library.
quit :: MonadIO m => m ()
quit = SDL.Raw.Font.quit
-- | Represents a loaded font.
newtype Font = Font { unwrap :: Ptr SDL.Raw.Font.Font }
deriving (Eq, Show)
-- | Point size (based on 72DPI) to load font as. Translates to pixel height.
type PointSize = Int
-- | Given a path to a font file, loads it for use as a 'Font' at a certain
-- 'PointSize'.
load :: MonadIO m => FilePath -> PointSize -> m Font
load path pts =
fmap Font .
throwIfNull "SDL.Font.load" "TTF_OpenFont" .
liftIO . withCString path $
flip SDL.Raw.Font.openFont $ fromIntegral pts
-- | Same as 'load', but accepts a 'ByteString' containing a font instead.
decode :: MonadIO m => ByteString -> PointSize -> m Font
decode bytes pts = liftIO .
unsafeUseAsCStringLen bytes $ \(cstr, len) -> do
rw <- rwFromConstMem (castPtr cstr) (fromIntegral len)
fmap Font .
throwIfNull "SDL.Font.decode" "TTF_OpenFontRW" $
SDL.Raw.Font.openFont_RW rw 0 $ fromIntegral pts
-- | Designates a font face, the default and first one being 0.
type Index = Int
-- | Given a path to a font file, loads one of its font faces (designated by
-- the given index) for use as a 'Font' at a certain 'PointSize'.
--
-- The first face is always index 0, and is the one chosen by default when
-- using 'load'.
loadIndex :: MonadIO m => FilePath -> PointSize -> Index -> m Font
loadIndex path pts i =
fmap Font .
throwIfNull "SDL.Font.loadIndex" "TTF_OpenFontIndex" .
liftIO . withCString path $ \cpath ->
SDL.Raw.Font.openFontIndex cpath (fromIntegral pts) (fromIntegral i)
-- | Same as 'loadIndex', but accepts a 'ByteString' containing a font instead.
decodeIndex :: MonadIO m => ByteString -> PointSize -> Index -> m Font
decodeIndex bytes pts i = liftIO .
unsafeUseAsCStringLen bytes $ \(cstr, len) -> do
rw <- rwFromConstMem (castPtr cstr) (fromIntegral len)
fmap Font .
throwIfNull "SDL.Font.decodeIndex" "TTF_OpenFontIndexRW" $
SDL.Raw.Font.openFontIndex_RW rw 0 (fromIntegral pts) (fromIntegral i)
-- | Frees a loaded 'Font'.
free :: MonadIO m => Font -> m ()
free = SDL.Raw.Font.closeFont . unwrap
-- | Color as an RGBA byte vector.
type Color = V4 Word8
-- | A helper for unmanaged 'Surface's, since it is not exposed by SDL itself.
unmanaged :: Ptr SDL.Raw.Surface -> Surface
unmanaged p = Surface p Nothing
-- | Renders 'Text' using the /quick and dirty/ method.
--
-- Is the fastest of the rendering methods, but results in text that isn't as
-- /smooth/.
solid :: MonadIO m => Font -> Color -> Text -> m SDL.Surface
solid (Font font) (V4 r g b a) text =
fmap unmanaged .
throwIfNull "SDL.Font.solid" "TTF_RenderUNICODE_Solid" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderUNICODE_Solid font (castPtr ptr) fg
-- | Uses the /slow and nice, but with a solid box/ method.
--
-- Renders slower than 'solid', but in about the same time as 'blended'.
--
-- Results in a 'Surface' containing antialiased text of a foreground color
-- surrounded by a box of a background color. This 'Surface' will blit as fast
-- as the one from 'solid'.
shaded :: MonadIO m => Font -> Color -> Color -> Text -> m SDL.Surface
shaded (Font font) (V4 r g b a) (V4 r2 g2 b2 a2) text =
fmap unmanaged .
throwIfNull "SDL.Font.shaded" "TTF_RenderUNICODE_Shaded" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
with (SDL.Raw.Color r2 g2 b2 a2) $ \bg ->
SDL.Raw.Font.renderUNICODE_Shaded font (castPtr ptr) fg bg
-- | The /slow slow slow, but ultra nice over another image/ method, 'blended'
-- renders text at high quality.
--
-- The text is antialiased and surrounded by a transparent box. Renders slower
-- than 'solid', but in about the same time as 'shaded'.
--
-- The resulting 'Surface' will blit slower than the ones from 'solid' or
-- 'shaded'.
blended :: MonadIO m => Font -> Color -> Text -> m SDL.Surface
blended (Font font) (V4 r g b a) text =
fmap unmanaged .
throwIfNull "SDL.Font.blended" "TTF_RenderUNICODE_Blended" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderUNICODE_Blended font (castPtr ptr) fg
-- Analogous to Data.Text.Foreign.useAsPtr, just appends a null-byte.
-- FIXME: Is this even necessary?
withText :: Text -> (Ptr Word16 -> IO a) -> IO a
withText text act =
allocaBytes len $ \ptr -> do
unsafeCopyToPtr text ptr
pokeByteOff ptr (len - 2) (0 :: CUShort)
act ptr
where
len = 2*(lengthWord16 text + 1)
-- Helper function for converting a bitmask into a list of values.
fromMaskWith :: (Enum a, Bounded a) => (a -> CInt) -> CInt -> [a]
fromMaskWith convert cint = concatMap (\a -> find (a, convert a)) [minBound..]
where
find (a, i) = [a | i == i .&. cint]
-- Helper function for converting a list of values into a bitmask.
toMaskWith :: (a -> CInt) -> [a] -> CInt
toMaskWith convert = foldr ((.|.) . convert) 0
-- | Possible styles that can be applied to a 'Font'.
data Style
= Bold
| Italic
| Underline
| Strikethrough
deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show)
styleToCInt :: Style -> CInt
styleToCInt =
\case
Bold -> SDL.Raw.Font.TTF_STYLE_BOLD
Italic -> SDL.Raw.Font.TTF_STYLE_ITALIC
Underline -> SDL.Raw.Font.TTF_STYLE_UNDERLINE
Strikethrough -> SDL.Raw.Font.TTF_STYLE_STRIKETHROUGH
-- | Gets the rendering styles of a given 'Font'.
--
-- If none were ever set, this will be an empty list.
getStyle :: MonadIO m => Font -> m [Style]
getStyle = fmap (fromMaskWith styleToCInt) . SDL.Raw.Font.getFontStyle . unwrap
-- | Sets the rendering style of a 'Font'.
--
-- Use an empty list to reset the style.
setStyle :: MonadIO m => Font -> [Style] -> m ()
setStyle (Font font) = SDL.Raw.Font.setFontStyle font . toMaskWith styleToCInt
-- | The size of the 'Font' outline, in pixels.
--
-- Use 0 to turn off outlining.
type Outline = Int
-- | Gets the current outline size of a given 'Font'.
getOutline :: MonadIO m => Font -> m Outline
getOutline = fmap fromIntegral . SDL.Raw.Font.getFontOutline . unwrap
-- | Sets the outline size for a given 'Font'.
--
-- Use 0 to turn off outlining.
setOutline :: MonadIO m => Font -> Outline -> m ()
setOutline (Font font) = SDL.Raw.Font.setFontOutline font . fromIntegral
-- | The hinting setting of a 'Font'.
data Hinting
= Normal
| Light
| Mono
| None
deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show)
hintingToCInt :: Hinting -> CInt
hintingToCInt =
\case
Normal -> SDL.Raw.Font.TTF_HINTING_NORMAL
Light -> SDL.Raw.Font.TTF_HINTING_LIGHT
Mono -> SDL.Raw.Font.TTF_HINTING_MONO
None -> SDL.Raw.Font.TTF_HINTING_NONE
cIntToHinting :: CInt -> Hinting
cIntToHinting =
\case
SDL.Raw.Font.TTF_HINTING_NORMAL -> Normal
SDL.Raw.Font.TTF_HINTING_LIGHT -> Light
SDL.Raw.Font.TTF_HINTING_MONO -> Mono
SDL.Raw.Font.TTF_HINTING_NONE -> None
_ -> error "SDL.Font.cIntToHinting received unknown TTF_HINTING."
-- | Gets the hinting setting of a given 'Font'.
getHinting :: MonadIO m => Font -> m Hinting
getHinting = fmap cIntToHinting . SDL.Raw.Font.getFontHinting . unwrap
-- | Sets the hinting setting of a font.
setHinting :: MonadIO m => Font -> Hinting -> m ()
setHinting (Font font) = SDL.Raw.Font.setFontHinting font . hintingToCInt
-- | Whether kerning is enabled or not.
--
-- The default for a newly-loaded 'Font' is enabled.
type Kerning = Bool
-- | Gets the current kerning setting of a given 'Font'.
getKerning :: MonadIO m => Font -> m Kerning
getKerning = fmap toBool . SDL.Raw.Font.getFontKerning . unwrap
-- | Sets the kerning setting for a given 'Font'.
--
-- Use 'False' to turn off kerning.
setKerning :: MonadIO m => Font -> Kerning -> m ()
setKerning (Font font) = SDL.Raw.Font.setFontKerning font . fromBool
-- | Gets the maximum pixel height of all glyphs of a given 'Font'.
height :: MonadIO m => Font -> m Int
height = fmap fromIntegral . SDL.Raw.Font.fontHeight . unwrap
-- | Gets the maximum pixel ascent of all glyphs of a given 'Font'.
--
-- This can be interpreted as the distance from the top of the font to the
-- baseline.
ascent :: MonadIO m => Font -> m Int
ascent = fmap fromIntegral . SDL.Raw.Font.fontAscent . unwrap
-- | Gets the maximum pixel descent of all glyphs of a given 'Font'.
--
-- Also interpreted as the distance from the baseline to the bottom of the
-- font.
descent :: MonadIO m => Font -> m Int
descent = fmap fromIntegral . SDL.Raw.Font.fontDescent . unwrap
-- | Gets the recommended pixel height of a rendered line of text of a given
-- 'Font'.
--
-- This is usually larger than what 'height' would return.
lineSkip :: MonadIO m => Font -> m Int
lineSkip = fmap fromIntegral . SDL.Raw.Font.fontLineSkip . unwrap
-- | Tests whether the current face of a 'Font' is a fixed width font or not.
isMonospace :: MonadIO m => Font -> m Bool
isMonospace = fmap toBool . SDL.Raw.Font.fontFaceIsFixedWidth . unwrap
cStringToText :: MonadIO m => CString -> m Text
cStringToText = fmap decodeUtf8 . liftIO . unsafePackCString
onlyIfM :: Monad m => Bool -> m a -> m (Maybe a)
onlyIfM = \case
False -> return . const Nothing
True -> fmap Just
-- | Gets the current font face family name, if any.
familyName :: MonadIO m => Font -> m (Maybe Text)
familyName (Font font) = do
cstr <- SDL.Raw.Font.fontFaceFamilyName font
onlyIfM (cstr /= nullPtr) $ cStringToText cstr
-- | Gets the current font face style name, if any.
styleName :: MonadIO m => Font -> m (Maybe Text)
styleName (Font font) = do
cstr <- SDL.Raw.Font.fontFaceStyleName font
onlyIfM (cstr /= nullPtr) $ cStringToText cstr
-- | Does a 'Font' provide a certain unicode character?
glyphProvided :: MonadIO m => Font -> Char -> m Bool
glyphProvided font ch =
glyphIndex font ch >>= \case
Just _ -> return True
Nothing -> return False
{-# INLINE fromChar #-}
fromChar :: Integral a => Char -> a
fromChar = fromIntegral . fromEnum
-- | Same as 'glyphProvided', but returns an index of the glyph for the given
-- character instead, if one is provided.
glyphIndex :: MonadIO m => Font -> Char -> m (Maybe Int)
glyphIndex (Font font) ch =
SDL.Raw.Font.glyphIsProvided font (fromChar ch)
>>= \case
0 -> return Nothing
i -> return . Just $ fromIntegral i
-- | Get glyph metrics for a given unicode character. The values returned are:
--
-- 1. minimum x offset
-- 2. maximum x offset
-- 3. minimum y offset
-- 4. maximum y offset
-- 5. advance offset
--
-- You can see more information about these values in the original @SDL2_ttf@
-- documentation
-- .
glyphMetrics :: MonadIO m => Font -> Char -> m (Maybe (Int, Int, Int, Int, Int))
glyphMetrics (Font font) ch =
liftIO .
alloca $ \minx ->
alloca $ \maxx ->
alloca $ \miny ->
alloca $ \maxy ->
alloca $ \advn -> do
let chi = fromChar ch
r <- SDL.Raw.Font.glyphMetrics font chi minx maxx miny maxy advn
if r /= 0 then
return Nothing
else do
a <- fromIntegral <$> peek minx
b <- fromIntegral <$> peek maxx
c <- fromIntegral <$> peek miny
d <- fromIntegral <$> peek maxy
e <- fromIntegral <$> peek advn
return $ Just (a, b, c, d, e)
-- | Use this function to discover how wide and tall a 'Surface' needs to be
-- in order to accommodate a given text when it is rendered.
--
-- Note that no actual rendering takes place.
--
-- The values returned are the width and height, respectively, in pixels. The
-- height returned is the same one returned by 'height'.
size :: MonadIO m => Font -> Text -> m (Int, Int)
size (Font font) text =
liftIO .
withText text $ \ptr ->
alloca $ \w ->
alloca $ \h ->
SDL.Raw.Font.sizeUNICODE font (castPtr ptr) w h
>>= \case
0 -> do
w' <- fromIntegral <$> peek w
h' <- fromIntegral <$> peek h
return (w', h')
_ -> do
err <- getError
throwIO $ SDLCallFailed "SDL.Font.size" "TTF_SizeUNICODE" err
-- | Same as 'solid', but renders a single glyph instead.
solidGlyph :: MonadIO m => Font -> Color -> Char -> m SDL.Surface
solidGlyph (Font font) (V4 r g b a) ch =
fmap unmanaged .
throwIfNull "SDL.Font.solidGlyph" "TTF_RenderGlyph_Solid" .
liftIO .
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderGlyph_Solid font (fromChar ch) fg
-- | Same as 'shaded', but renders a single glyph instead.
shadedGlyph :: MonadIO m => Font -> Color -> Color -> Char -> m SDL.Surface
shadedGlyph (Font font) (V4 r g b a) (V4 r2 g2 b2 a2) ch =
fmap unmanaged .
throwIfNull "SDL.Font.shadedGlyph" "TTF_RenderGlyph_Solid" .
liftIO .
with (SDL.Raw.Color r g b a) $ \fg ->
with (SDL.Raw.Color r2 g2 b2 a2) $ \bg ->
SDL.Raw.Font.renderGlyph_Shaded font (fromChar ch) fg bg
-- | Same as 'blended', but renders a single glyph instead.
blendedGlyph :: MonadIO m => Font -> Color -> Char -> m SDL.Surface
blendedGlyph (Font font) (V4 r g b a) ch =
fmap unmanaged .
throwIfNull "SDL.Font.blendedGlyph" "TTF_RenderGlyph_Blended" .
liftIO .
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderGlyph_Blended font (fromChar ch) fg
-- | Same as 'blended', but renders across multiple lines.
-- Text is wrapped to multiple lines on line endings and on word boundaries
-- if it extends beyond wrapLength in pixels.
blendedWrapped :: MonadIO m => Font -> Color -> Int -> Text -> m SDL.Surface
blendedWrapped (Font font) (V4 r g b a) wrapLength text =
fmap unmanaged .
throwIfNull "SDL.Font.blended" "TTF_RenderUNICODE_Blended_Wrapped" .
liftIO . withText text $ \ptr ->
with (SDL.Raw.Color r g b a) $ \fg ->
SDL.Raw.Font.renderUNICODE_Blended_Wrapped font (castPtr ptr) fg $ fromIntegral wrapLength
-- | From a given 'Font' get the kerning size of two glyphs.
getKerningSize :: MonadIO m => Font -> Index -> Index -> m Int
getKerningSize (Font font) prevIndex index =
fmap fromIntegral $ SDL.Raw.Font.getFontKerningSize font (fromIntegral prevIndex) (fromIntegral index)
sdl2-ttf-2.1.1/src/SDL/Raw/ 0000755 0000000 0000000 00000000000 07346545000 013305 5 ustar 00 0000000 0000000 sdl2-ttf-2.1.1/src/SDL/Raw/Font.hsc 0000644 0000000 0000000 00000017036 07346545000 014721 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-|
Module : SDL.Raw.Font
Copyright : (c) 2015 Siniša Biđin
License : MIT
Stability : experimental
Raw bindings to the @SDL2_ttf@ library. No error-handling is done here. For more
information about specific function behaviour, see the @SDL2_ttf@ documentation.
-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
module SDL.Raw.Font
(
-- * General
init
, wasInit
, quit
, getVersion
-- * Loading fonts
, Font
, FontPath
, PointSize
, openFont
, Free
, openFont_RW
, Index
, openFontIndex
, openFontIndex_RW
, closeFont
-- * Font attributes
, getFontStyle
, setFontStyle
, pattern TTF_STYLE_NORMAL
, pattern TTF_STYLE_BOLD
, pattern TTF_STYLE_ITALIC
, pattern TTF_STYLE_UNDERLINE
, pattern TTF_STYLE_STRIKETHROUGH
, getFontOutline
, setFontOutline
, getFontHinting
, setFontHinting
, pattern TTF_HINTING_NORMAL
, pattern TTF_HINTING_LIGHT
, pattern TTF_HINTING_MONO
, pattern TTF_HINTING_NONE
, getFontKerning
, setFontKerning
, fontHeight
, fontAscent
, fontDescent
, fontLineSkip
, fontFaces
, fontFaceIsFixedWidth
, fontFaceFamilyName
, fontFaceStyleName
, glyphIsProvided
, glyphMetrics
, getFontKerningSize
-- * Getting text size
, sizeText
, sizeUTF8
, sizeUNICODE
-- * Rendering text
, renderText_Solid
, renderText_Shaded
, renderText_Blended
, renderText_Blended_Wrapped
, renderUTF8_Solid
, renderUTF8_Shaded
, renderUTF8_Blended
, renderUTF8_Blended_Wrapped
, renderUNICODE_Solid
, renderUNICODE_Shaded
, renderUNICODE_Blended
, renderUNICODE_Blended_Wrapped
, renderGlyph_Solid
, renderGlyph_Shaded
, renderGlyph_Blended
-- * Other
, byteSwappedUNICODE
, pattern UNICODE_BOM_NATIVE
, pattern UNICODE_BOM_SWAPPED
) where
#include "SDL_ttf.h"
import Foreign.C.String (CString)
import Foreign.C.Types (CInt(..), CLong(..), CUShort(..), CUInt(..))
import Foreign.Ptr (Ptr)
import Prelude hiding (init)
import SDL.Raw.Types (Version, Surface, RWops, Color)
import SDL.Raw.Helper (liftF)
pattern UNICODE_BOM_NATIVE = #{const UNICODE_BOM_NATIVE}
pattern UNICODE_BOM_SWAPPED = #{const UNICODE_BOM_SWAPPED}
pattern TTF_STYLE_NORMAL = #{const TTF_STYLE_NORMAL}
pattern TTF_STYLE_BOLD = #{const TTF_STYLE_BOLD}
pattern TTF_STYLE_ITALIC = #{const TTF_STYLE_ITALIC}
pattern TTF_STYLE_UNDERLINE = #{const TTF_STYLE_UNDERLINE}
pattern TTF_STYLE_STRIKETHROUGH = #{const TTF_STYLE_STRIKETHROUGH}
pattern TTF_HINTING_LIGHT = #{const TTF_HINTING_LIGHT}
pattern TTF_HINTING_MONO = #{const TTF_HINTING_MONO}
pattern TTF_HINTING_NONE = #{const TTF_HINTING_NONE}
pattern TTF_HINTING_NORMAL = #{const TTF_HINTING_NORMAL}
liftF "getVersion" "TTF_Linked_Version"
[t|IO (Ptr Version)|]
liftF "init" "TTF_Init"
[t|IO CInt|]
liftF "wasInit" "TTF_WasInit"
[t|IO CInt|]
liftF "quit" "TTF_Quit"
[t|IO ()|]
-- | A path to a font file.
type FontPath = CString
-- | Point size (based on 72DPI). Translates to pixel height.
type PointSize = CInt
-- | The raw, underlying @TTF_Font@ struct.
data Font
-- | Should the 'Ptr' 'RWops' be freed after an operation? 1 for yes, 0 for no.
type Free = CInt
-- | Indicates the font face we're loading. First face is always 0.
type Index = CLong
liftF "openFont" "TTF_OpenFont"
[t|FontPath -> PointSize -> IO (Ptr Font)|]
liftF "openFont_RW" "TTF_OpenFontRW"
[t|Ptr RWops -> Free -> PointSize -> IO (Ptr Font)|]
liftF "openFontIndex" "TTF_OpenFontIndex"
[t|FontPath -> PointSize -> Index -> IO (Ptr Font)|]
liftF "openFontIndex_RW" "TTF_OpenFontIndexRW"
[t|Ptr RWops -> Free -> PointSize -> Index -> IO (Ptr Font)|]
liftF "closeFont" "TTF_CloseFont"
[t|Ptr Font -> IO ()|]
liftF "byteSwappedUNICODE" "TTF_ByteSwappedUNICODE"
[t|CInt -> IO ()|]
liftF "getFontStyle" "TTF_GetFontStyle"
[t|Ptr Font -> IO CInt|]
liftF "setFontStyle" "TTF_SetFontStyle"
[t|Ptr Font -> CInt -> IO ()|]
liftF "getFontOutline" "TTF_GetFontOutline"
[t|Ptr Font -> IO CInt|]
liftF "setFontOutline" "TTF_SetFontOutline"
[t|Ptr Font -> CInt -> IO ()|]
liftF "getFontHinting" "TTF_GetFontHinting"
[t|Ptr Font -> IO CInt|]
liftF "setFontHinting" "TTF_SetFontHinting"
[t|Ptr Font -> CInt -> IO ()|]
liftF "getFontKerning" "TTF_GetFontKerning"
[t|Ptr Font -> IO CInt|]
liftF "setFontKerning" "TTF_SetFontKerning"
[t|Ptr Font -> CInt -> IO ()|]
liftF "fontHeight" "TTF_FontHeight"
[t|Ptr Font -> IO CInt|]
liftF "fontAscent" "TTF_FontAscent"
[t|Ptr Font -> IO CInt|]
liftF "fontDescent" "TTF_FontDescent"
[t|Ptr Font -> IO CInt|]
liftF "fontLineSkip" "TTF_FontLineSkip"
[t|Ptr Font -> IO CInt|]
liftF "fontFaces" "TTF_FontFaces"
[t|Ptr Font -> IO CLong|]
liftF "fontFaceIsFixedWidth" "TTF_FontFaceIsFixedWidth"
[t|Ptr Font -> IO CInt|]
liftF "fontFaceFamilyName" "TTF_FontFaceFamilyName"
[t|Ptr Font -> IO CString|]
liftF "fontFaceStyleName" "TTF_FontFaceStyleName"
[t|Ptr Font -> IO CString|]
liftF "glyphIsProvided" "TTF_GlyphIsProvided"
[t|Ptr Font -> CUShort -> IO CInt|]
liftF "glyphMetrics" "TTF_GlyphMetrics"
[t|Ptr Font -> CUShort ->
Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt ->
IO CInt|]
liftF "sizeText" "TTF_SizeText"
[t|Ptr Font -> CString -> Ptr CInt -> Ptr CInt -> IO CInt|]
liftF "sizeUTF8" "TTF_SizeUTF8"
[t|Ptr Font -> CString -> Ptr CInt -> Ptr CInt -> IO CInt|]
liftF "sizeUNICODE" "TTF_SizeUNICODE"
[t|Ptr Font -> Ptr CUShort -> Ptr CInt -> Ptr CInt -> IO CInt|]
liftF "renderText_Solid" "TTF_RenderText_Solid_p"
[t|Ptr Font -> CString -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderUTF8_Solid" "TTF_RenderUTF8_Solid_p"
[t|Ptr Font -> CString -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderUNICODE_Solid" "TTF_RenderUNICODE_Solid_p"
[t|Ptr Font -> Ptr CUShort -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderGlyph_Solid" "TTF_RenderGlyph_Solid_p"
[t|Ptr Font -> CUShort -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderText_Shaded" "TTF_RenderText_Shaded_p"
[t|Ptr Font -> CString -> Ptr Color -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderUTF8_Shaded" "TTF_RenderUTF8_Shaded_p"
[t|Ptr Font -> CString -> Ptr Color -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderUNICODE_Shaded" "TTF_RenderUNICODE_Shaded_p"
[t|Ptr Font -> Ptr CUShort -> Ptr Color -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderGlyph_Shaded" "TTF_RenderGlyph_Shaded_p"
[t|Ptr Font -> CUShort -> Ptr Color -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderText_Blended" "TTF_RenderText_Blended_p"
[t|Ptr Font -> CString -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderUTF8_Blended" "TTF_RenderUTF8_Blended_p"
[t|Ptr Font -> CString -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderUNICODE_Blended" "TTF_RenderUNICODE_Blended_p"
[t|Ptr Font -> Ptr CUShort -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderGlyph_Blended" "TTF_RenderGlyph_Blended_p"
[t|Ptr Font -> CUShort -> Ptr Color -> IO (Ptr Surface)|]
liftF "renderText_Blended_Wrapped" "TTF_RenderText_Blended_Wrapped_p"
[t|Ptr Font -> CString -> Ptr Color -> CUInt -> IO (Ptr Surface)|]
liftF "renderUTF8_Blended_Wrapped" "TTF_RenderUTF8_Blended_Wrapped_p"
[t|Ptr Font -> CString -> Ptr Color -> CUInt -> IO (Ptr Surface)|]
liftF "renderUNICODE_Blended_Wrapped" "TTF_RenderUNICODE_Blended_Wrapped_p"
[t|Ptr Font -> Ptr CUShort -> Ptr Color -> CUInt -> IO (Ptr Surface)|]
liftF "getFontKerningSize" "TTF_GetFontKerningSize"
[t|Ptr Font -> CInt -> CInt -> IO CInt|]
sdl2-ttf-2.1.1/src/SDL/Raw/Helper.hs 0000644 0000000 0000000 00000004726 07346545000 015071 0 ustar 00 0000000 0000000 {-|
Module : SDL.Raw.Helper
Copyright : (c) 2015 Siniša Biđin
License : MIT
Stability : experimental
Exposes a way to automatically generate a foreign import alongside its lifted,
inlined MonadIO variant. Use this to simplify the package's SDL.Raw.* modules.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module SDL.Raw.Helper (liftF) where
import Control.Monad (replicateM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Language.Haskell.TH
-- | Given a name @fname@, a name of a C function @cname@ and the desired
-- Haskell type @ftype@, this function generates:
--
-- * A foreign import of @cname@, named as @fname'@.
-- * An always-inline MonadIO version of @fname'@, named @fname@.
liftF :: String -> String -> Q Type -> Q [Dec]
liftF fname cname ftype = do
let f' = mkName $ fname ++ "'" -- Direct binding.
let f = mkName fname -- Lifted.
t' <- ftype -- Type of direct binding.
-- The generated function accepts n arguments.
args <- replicateM (countArgs t') $ newName "x"
-- If the function has no arguments, then we just liftIO it directly.
-- However, this fails to typecheck without an explicit type signature.
-- Therefore, we include one. TODO: Can we get rid of this?
sigd <- case args of
[] -> ((:[]) . SigD f) `fmap` liftType t'
_ -> return []
return $ concat
[
[ ForeignD $ ImportF CCall Safe cname f' t'
, PragmaD $ InlineP f Inline FunLike AllPhases
]
, sigd
, [ FunD f
[ Clause
(map VarP args)
(NormalB $ 'liftIO `applyTo` [f' `applyTo` map VarE args])
[]
]
]
]
-- | How many arguments does a function of a given type take?
countArgs :: Type -> Int
countArgs = count 0
where
count !n = \case
(AppT (AppT ArrowT _) t) -> count (n+1) t
(ForallT _ _ t) -> count n t
(SigT t _) -> count n t
_ -> n
-- | An expression where f is applied to n arguments.
applyTo :: Name -> [Exp] -> Exp
applyTo f [] = VarE f
applyTo f es = loop (tail es) . AppE (VarE f) $ head es
where
loop as e = foldl AppE e as
-- | Fuzzily speaking, converts a given IO type into a MonadIO m one.
liftType :: Type -> Q Type
liftType = \case
AppT _ t -> do
m <- newName "m"
return $
ForallT
[PlainTV m]
[AppT (ConT ''MonadIO) $ VarT m]
(AppT (VarT m) t)
t -> return t