{-# 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

{- ^

Write like the following.

@
enum \"Foo\" ''Int [''Show, ''Read, ''Eq] [
	(\"FooError\", - 1),
	(\"FooZero\", 0),
	(\"FooOne\", 1),
	(\"FooTwo\", 2) ]
@

Then you get like the following.

@
newtype Foo = Foo Int deriving Eq

pattern FooError :: Int -> Foo
pattern FooError <- Foo (- 1) where
	FooError = Foo (- 1)

pattern FooZero :: Int -> Foo
...


instance Show Foo where
	showsPrec = ...

instance Read Foo where
	readPrec = ...
@

And you can read and show like the following.

@
> Foo $ - 1
FooError
> FooTwo
FooTwo
> Foo 3
Foo 3
> read "Foo (- 1)" :: Foo
FooError
> read \"FooOne\" :: Foo
FooOne
@

-}

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

{- ^

You can define enum members separately.

@
enumMems \"Foo\" [
	(\"FooThree\", 3),
	(\"FooFour\", 4) ]
@

-}

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