{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Foreign.C.Enum (enum, enumMems) where
import Language.Haskell.TH (
Name, mkName, newName, Lit(..), clause, cxt, normalB,
DecsQ, DecQ, valD, funD, instanceD,
patSynSigD, patSynD, prefixPatSyn, explBidir,
newtypeD, normalC, derivClause,
ExpQ, varE, conE, litE, sigE, appE, infixE, listE, lamCaseE,
conT, appT, varP, conP, litP, wildP, match,
doE, bindS, noBindS,
bangType, bang, noSourceUnpackedness, noSourceStrictness,
TypeQ, sigD, arrowT )
import Foreign.Ptr
import Foreign.Storable
import Control.Arrow (first)
import Data.Bool (bool)
import Data.Maybe (isJust, listToMaybe)
import Data.List (partition)
import Text.Read (readPrec, Lexeme(..), step, choice, prec, parens, lexP)
enum :: String -> Name -> [Name] -> [(String, Integer)] -> DecsQ
enum :: String -> Name -> [Name] -> [(String, Integer)] -> DecsQ
enum String
nt Name
t [Name]
ds [(String, Integer)]
nvs = (\Dec
n [Dec] -> [Dec]
s [Dec] -> [Dec]
r [Dec] -> [Dec]
st [Dec]
ms [Dec]
unsf -> Dec
n Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec] -> [Dec]
s ([Dec] -> [Dec]
r ([Dec] -> [Dec]
st [Dec]
ms)) [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
unsf)
(Dec
-> ([Dec] -> [Dec])
-> ([Dec] -> [Dec])
-> ([Dec] -> [Dec])
-> [Dec]
-> [Dec]
-> [Dec])
-> Q Dec
-> Q (([Dec] -> [Dec])
-> ([Dec] -> [Dec]) -> ([Dec] -> [Dec]) -> [Dec] -> [Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Name -> [Name] -> Q Dec
mkNewtype String
nt Name
t [Name]
ds'
Q (([Dec] -> [Dec])
-> ([Dec] -> [Dec]) -> ([Dec] -> [Dec]) -> [Dec] -> [Dec] -> [Dec])
-> Q ([Dec] -> [Dec])
-> Q (([Dec] -> [Dec])
-> ([Dec] -> [Dec]) -> [Dec] -> [Dec] -> [Dec])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q ([Dec] -> [Dec])
-> Q ([Dec] -> [Dec]) -> Bool -> Q ([Dec] -> [Dec])
forall a. a -> a -> Bool -> a
bool (([Dec] -> [Dec]) -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec] -> [Dec]
forall a. a -> a
id) ((:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> Q Dec
mkShow String
nt [String]
ns) Bool
bs
Q (([Dec] -> [Dec]) -> ([Dec] -> [Dec]) -> [Dec] -> [Dec] -> [Dec])
-> Q ([Dec] -> [Dec])
-> Q (([Dec] -> [Dec]) -> [Dec] -> [Dec] -> [Dec])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q ([Dec] -> [Dec])
-> Q ([Dec] -> [Dec]) -> Bool -> Q ([Dec] -> [Dec])
forall a. a -> a -> Bool -> a
bool (([Dec] -> [Dec]) -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec] -> [Dec]
forall a. a -> a
id) ((:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> Q Dec
mkRead String
nt [String]
ns) Bool
br
Q (([Dec] -> [Dec]) -> [Dec] -> [Dec] -> [Dec])
-> Q ([Dec] -> [Dec]) -> Q ([Dec] -> [Dec] -> [Dec])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q ([Dec] -> [Dec])
-> Q ([Dec] -> [Dec]) -> Bool -> Q ([Dec] -> [Dec])
forall a. a -> a -> Bool -> a
bool (([Dec] -> [Dec]) -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec] -> [Dec]
forall a. a -> a
id)
((:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Name -> Q Dec
deriveStorable (String -> Name
mkName String
nt) Name
t) Bool
bst
Q ([Dec] -> [Dec] -> [Dec]) -> DecsQ -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> [(String, Integer)] -> DecsQ
enumMems String
nt [(String, Integer)]
nvs
Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Name -> DecsQ
unSigFun String
nt Name
t
where ShowReadClasses Bool
bs Bool
br Bool
bst [Name]
ds' = [Name] -> ShowReadClasses
showReadClasses [Name]
ds; ns :: [String]
ns = (String, Integer) -> String
forall a b. (a, b) -> a
fst ((String, Integer) -> String) -> [(String, Integer)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Integer)]
nvs
data ShowReadClasses = ShowReadClasses {
ShowReadClasses -> Bool
showReadClassesShow :: Bool,
ShowReadClasses -> Bool
showReadClassesRead :: Bool,
ShowReadClasses -> Bool
showReadClassesStorable :: Bool,
ShowReadClasses -> [Name]
showReadClassesClasses :: [Name] } deriving Int -> ShowReadClasses -> ShowS
[ShowReadClasses] -> ShowS
ShowReadClasses -> String
(Int -> ShowReadClasses -> ShowS)
-> (ShowReadClasses -> String)
-> ([ShowReadClasses] -> ShowS)
-> Show ShowReadClasses
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowReadClasses] -> ShowS
$cshowList :: [ShowReadClasses] -> ShowS
show :: ShowReadClasses -> String
$cshow :: ShowReadClasses -> String
showsPrec :: Int -> ShowReadClasses -> ShowS
$cshowsPrec :: Int -> ShowReadClasses -> ShowS
Show
showReadClasses :: [Name] -> ShowReadClasses
showReadClasses :: [Name] -> ShowReadClasses
showReadClasses [Name]
ns = Bool -> Bool -> Bool -> [Name] -> ShowReadClasses
ShowReadClasses (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
s) (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
r) (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
st) [Name]
ns'''
where
(Maybe Name
s, [Name]
ns') = Name -> [Name] -> (Maybe Name, [Name])
forall a. Eq a => a -> [a] -> (Maybe a, [a])
popIt ''Show [Name]
ns
(Maybe Name
r, [Name]
ns'') = Name -> [Name] -> (Maybe Name, [Name])
forall a. Eq a => a -> [a] -> (Maybe a, [a])
popIt ''Read [Name]
ns'
(Maybe Name
st, [Name]
ns''') = Name -> [Name] -> (Maybe Name, [Name])
forall a. Eq a => a -> [a] -> (Maybe a, [a])
popIt ''Storable [Name]
ns''
popIt :: Eq a => a -> [a] -> (Maybe a, [a])
popIt :: a -> [a] -> (Maybe a, [a])
popIt a
x = ([a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> ([a], [a]) -> (Maybe a, [a])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
`first`) (([a], [a]) -> (Maybe a, [a]))
-> ([a] -> ([a], [a])) -> [a] -> (Maybe a, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x)
mkNewtype :: String -> Name -> [Name] -> DecQ
mkNewtype :: String -> Name -> [Name] -> Q Dec
mkNewtype String
nt Name
t [Name]
ds = CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD ([PredQ] -> CxtQ
cxt []) (String -> Name
mkName String
nt) [] Maybe Kind
forall a. Maybe a
Nothing
(Name -> [BangTypeQ] -> ConQ
normalC (String -> Name
mkName String
nt)
[BangQ -> PredQ -> BangTypeQ
bangType
(SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
(Name -> PredQ
conT Name
t)])
[Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ([PredQ] -> DerivClauseQ) -> [PredQ] -> DerivClauseQ
forall a b. (a -> b) -> a -> b
$ Name -> PredQ
conT (Name -> PredQ) -> [Name] -> [PredQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
ds]
enumMems :: String -> [(String, Integer)] -> DecsQ
enumMems :: String -> [(String, Integer)] -> DecsQ
enumMems String
t [(String, Integer)]
nvs = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Integer -> DecsQ) -> (String, Integer) -> DecsQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Name -> String -> Integer -> DecsQ
mkMember (String -> Name
mkName String
t)) ((String, Integer) -> DecsQ) -> [(String, Integer)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [(String, Integer)]
nvs
mkMember :: Name -> String -> Integer -> DecsQ
mkMember :: Name -> String -> Integer -> DecsQ
mkMember Name
t String
n Integer
v = [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
Name -> PredQ -> Q Dec
patSynSigD (String -> Name
mkName String
n) (Name -> PredQ
conT Name
t),
Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> Q Dec
patSynD (String -> Name
mkName String
n) ([Name] -> PatSynArgsQ
prefixPatSyn [])
([ClauseQ] -> PatSynDirQ
explBidir [(BodyQ -> [Q Dec] -> ClauseQ) -> [Q Dec] -> BodyQ -> ClauseQ
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []) []
(BodyQ -> ClauseQ) -> (ExpQ -> BodyQ) -> ExpQ -> ClauseQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> BodyQ
normalB (ExpQ -> ClauseQ) -> ExpQ -> ClauseQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
t ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (Integer -> Lit
IntegerL Integer
v)])
(Name -> [PatQ] -> PatQ
conP Name
t [Lit -> PatQ
litP (Integer -> Lit
IntegerL Integer
v)]) ]
mkShow :: String -> [String] -> DecQ
mkShow :: String -> [String] -> Q Dec
mkShow String
t [String]
ns = CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt [])
(Name -> PredQ
conT ''Show PredQ -> PredQ -> PredQ
`appT` Name -> PredQ
conT (String -> Name
mkName String
t)) [String -> [String] -> Q Dec
defineShowsPrec String
t [String]
ns]
defineShowsPrec :: String -> [String] -> DecQ
defineShowsPrec :: String -> [String] -> Q Dec
defineShowsPrec String
t [String]
ns = String -> Q Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [String
"d", String
"n"] Q [Name] -> ([Name] -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name
d, Name
n] ->
Name -> [ClauseQ] -> Q Dec
funD 'showsPrec [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
d] (ExpQ -> BodyQ
normalB ([MatchQ] -> ExpQ
lamCaseE (
(String -> MatchQ
named (String -> MatchQ) -> [String] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
ns) [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++
[PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
t) [Name -> PatQ
varP Name
n]) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Name -> ExpQ
sw Name
d Name
n) []] ))) []]
where
named :: String -> MatchQ
named String
f = (BodyQ -> [Q Dec] -> MatchQ) -> [Q Dec] -> BodyQ -> MatchQ
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> BodyQ -> [Q Dec] -> MatchQ)
-> PatQ -> BodyQ -> [Q Dec] -> MatchQ
forall a b. (a -> b) -> a -> b
$ Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
f) []) []
(BodyQ -> MatchQ) -> (ExpQ -> BodyQ) -> ExpQ -> MatchQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> BodyQ
normalB (ExpQ -> MatchQ) -> ExpQ -> MatchQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
litE (String -> Lit
StringL String
f) ExpQ -> ExpQ -> ExpQ
`p` Name -> ExpQ
varE '(++)
sw :: Name -> Name -> ExpQ
sw Name
d Name
n = Name -> ExpQ
varE 'showParen ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE Name
d ExpQ -> ExpQ -> ExpQ
.> Lit -> ExpQ
litE (Integer -> Lit
IntegerL Integer
10))
ExpQ -> ExpQ -> ExpQ
.$ ((Lit -> ExpQ
litE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ") ExpQ -> ExpQ -> ExpQ
`p` Name -> ExpQ
varE '(++)) ExpQ -> ExpQ -> ExpQ
...
(Name -> ExpQ
varE 'showsPrec ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (Integer -> Lit
IntegerL Integer
11) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
n))
mkRead :: String -> [String] -> DecQ
mkRead :: String -> [String] -> Q Dec
mkRead String
t [String]
ns = CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (Name -> PredQ
conT ''Read PredQ -> PredQ -> PredQ
`appT` Name -> PredQ
conT (String -> Name
mkName String
t)) ([Q Dec] -> Q Dec) -> (Q Dec -> [Q Dec]) -> Q Dec -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [])
(Q Dec -> Q Dec) -> Q Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'readPrec) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'parens ExpQ -> ExpQ -> ExpQ
.$ (Name -> ExpQ
varE 'choice ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE (
(String -> ExpQ
named (String -> ExpQ) -> [String] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
ns) [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. [a] -> [a] -> [a]
++
[Name -> ExpQ
varE 'prec ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (Integer -> Lit
IntegerL Integer
10) ExpQ -> ExpQ -> ExpQ
`appE` [StmtQ] -> ExpQ
doE [
PatQ -> ExpQ -> StmtQ
bindS (Name -> [PatQ] -> PatQ
conP 'Ident [Lit -> PatQ
litP (Lit -> PatQ) -> Lit -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
t]) (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'lexP,
ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE (String -> Name
mkName String
t) ExpQ -> ExpQ -> ExpQ
.<$> (Name -> ExpQ
varE 'step ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE 'readPrec) ]]
))) []
where
named :: String -> ExpQ
named String
n = [StmtQ] -> ExpQ
doE [
PatQ -> ExpQ -> StmtQ
bindS (Name -> [PatQ] -> PatQ
conP 'Ident [Lit -> PatQ
litP (Lit -> PatQ) -> Lit -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
n]) (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'lexP,
ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'pure ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
conE (String -> Name
mkName String
n) ]
(...), (.$), (.<$>), (.>), p :: ExpQ -> ExpQ -> ExpQ
ExpQ
e1 ... :: ExpQ -> ExpQ -> ExpQ
... ExpQ
e2 = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e1) (Name -> ExpQ
varE '(.)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e2)
ExpQ
e1 .$ :: ExpQ -> ExpQ -> ExpQ
.$ ExpQ
e2 = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e1) (Name -> ExpQ
varE '($)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e2)
ExpQ
e1 .<$> :: ExpQ -> ExpQ -> ExpQ
.<$> ExpQ
e2 = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e1) (Name -> ExpQ
varE '(<$>)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e2)
ExpQ
e1 .> :: ExpQ -> ExpQ -> ExpQ
.> ExpQ
e2 = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e1) (Name -> ExpQ
varE '(>)) (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e2)
ExpQ
ex p :: ExpQ -> ExpQ -> ExpQ
`p` ExpQ
op = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
ex) ExpQ
op Maybe ExpQ
forall a. Maybe a
Nothing
deriveStorable :: Name -> Name -> DecQ
deriveStorable :: Name -> Name -> Q Dec
deriveStorable Name
drv Name
org = String -> Q Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [String
"p", String
"p", String
"x"] Q [Name] -> ([Name] -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name
pnt, Name
pnt', Name
x] ->
CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT ''Storable) (Name -> PredQ
conT Name
drv)) [
Name -> [ClauseQ] -> Q Dec
funD 'sizeOf [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP]
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'sizeOf ExpQ -> ExpQ -> ExpQ
`appE`
(Name -> ExpQ
varE 'undefined ExpQ -> PredQ -> ExpQ
`sigE` Name -> PredQ
conT Name
org))
[]],
Name -> [ClauseQ] -> Q Dec
funD 'alignment [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP]
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'alignment ExpQ -> ExpQ -> ExpQ
`appE`
(Name -> ExpQ
varE 'undefined ExpQ -> PredQ -> ExpQ
`sigE` Name -> PredQ
conT Name
org))
[]],
Name -> [ClauseQ] -> Q Dec
funD 'peek [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
pnt]
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
drv) (Name -> ExpQ
varE '(<$>)) (Maybe ExpQ -> ExpQ) -> (ExpQ -> Maybe ExpQ) -> ExpQ -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just
(ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'peek ExpQ -> ExpQ -> ExpQ
`appE`
(Name -> ExpQ
varE 'castPtr ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
pnt))
[]],
Name -> [ClauseQ] -> Q Dec
funD 'poke [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
pnt', Name -> [PatQ] -> PatQ
conP Name
drv [Name -> PatQ
varP Name
x]]
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'poke ExpQ -> ExpQ -> ExpQ
`appE`
(Name -> ExpQ
varE 'castPtr ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
pnt') ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
x)
[]] ]
unSigFun :: String -> Name -> DecsQ
unSigFun :: String -> Name -> DecsQ
unSigFun String
en Name
tp = (\Dec
s Dec
f -> [Dec
s, Dec
f]) (Dec -> Dec -> [Dec]) -> Q Dec -> Q (Dec -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Name -> Q Dec
unSig String
en Name
tp Q (Dec -> [Dec]) -> Q Dec -> DecsQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Q Dec
unFun String
en
unSig :: String -> Name -> DecQ
unSig :: String -> Name -> Q Dec
unSig String
en Name
tp = Name -> PredQ -> Q Dec
sigD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"un" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
en) (PredQ -> Q Dec) -> PredQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> PredQ
conT (String -> Name
mkName String
en) PredQ -> PredQ -> PredQ
`arrT` Name -> PredQ
conT Name
tp
unFun :: String -> DecQ
unFun :: String -> Q Dec
unFun String
en = do
Name
x <- String -> Q Name
newName String
"x"
Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"un" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
en) [
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
en) [Name -> PatQ
varP Name
x]] (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
x)) []
]
arrT :: TypeQ -> TypeQ -> TypeQ
PredQ
t1 arrT :: PredQ -> PredQ -> PredQ
`arrT` PredQ
t2 = PredQ
arrowT PredQ -> PredQ -> PredQ
`appT` PredQ
t1 PredQ -> PredQ -> PredQ
`appT` PredQ
t2