{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Foreign.C.Struct (
	-- * STRUCT
	struct, StrName, StrSize, StrAlgn,
	MemName, MemType, MemPeek, MemPoke, DerivClass,
	-- * STRUCT WITH PRIMITIVE MONAD
	structPrim, FunCopy, FunFree ) where

import Language.Haskell.TH (
	DecsQ, DecQ, Dec(PragmaD), Pragma(CompleteP), sigD, valD, funD, tySynD,
	newtypeD, plainTV, normalC, derivClause,
		bangType, bang, noSourceUnpackedness, noSourceStrictness,
	instanceD, cxt,
	patSynSigD, patSynD, recordPatSyn, explBidir,
	ExpQ, varE, conE, appE, infixE, lamE, tupE, listE, litE, integerL,
	forallT, varT, conT, appT, varP, wildP, conP, tupP, viewP,
	Name, mkName, newName,
	ClauseQ, clause, normalB, StmtQ, doE, compE, bindS, noBindS )
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Concurrent (newForeignPtr)
import Foreign.Marshal (malloc, mallocBytes, free, copyBytes)
import Foreign.Storable
import Control.Arrow ((&&&))
import Control.Monad (replicateM)
import Control.Monad.Primitive (PrimMonad(..), RealWorld, unsafeIOToPrim)
import Data.Bool (bool)
import Data.Maybe (mapMaybe)
import Data.List (unzip4, intersperse, intercalate)
import Data.Array (Ix(..))
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (Lexeme(..), readPrec, step, lexP, parens, prec)

import Foreign.C.Struct.Parts (
	(.->), (.$), (...), (.<$>), (.<*>), (.>>=),
	(.&&), (.||), (.==), (.<), (.+), (.*),
	tupleE, tupT, tupP', intE, strP, pt, zp, ss, (..+), toLabel, lcfirst )

---------------------------------------------------------------------------

-- * STRUCT
--	+ FUNCTION STRUCT
--	+ NEWTYPE
--	+ PATTERN
--		- Function Mk Pattern
--		- Function Mk Pattern Fun
--	+ DERIVING
--		- Function Mk Deriving
--		- Show
--		- Read
--		- Eq
--		- Ord
--		- Bounded
--		- Ix
-- * STRUCT WITH PRIMITIVE MONAD
-- 	+ FUNCTION STRUCT PRIM
-- 	+ NEWTYPE
-- 	+ FREEZE
-- 	+ THAW
-- 	+ COPY

---------------------------------------------------------------------------
-- STRUCT
---------------------------------------------------------------------------

-- FUNCTION STRUCT

struct :: StrName -> StrSize -> StrAlgn ->
	[(MemName, MemType, MemPeek, MemPoke)] -> [DerivClass] -> DecsQ
struct :: StrName
-> StrSize
-> StrSize
-> [(StrName, MemType, MemPeek, MemPeek)]
-> [MemType]
-> DecsQ
struct StrName
sn StrSize
sz StrSize
algn ([(StrName, MemType, MemPeek, MemPeek)]
-> ([StrName], [MemType], [MemPeek], [MemPeek])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 -> ([StrName]
mns, [MemType]
mts, [MemPeek]
mpes, [MemPeek]
mpos)) [MemType]
dcs_ = [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++)
	([Dec] -> [Dec] -> [Dec]) -> DecsQ -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
		StrName -> Q Dec
mkNewtype StrName
sn,
		Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> (Pragma -> Dec) -> Pragma -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pragma -> Dec
PragmaD (Pragma -> Q Dec) -> Pragma -> Q Dec
forall a b. (a -> b) -> a -> b
$ [MemType] -> Maybe MemType -> Pragma
CompleteP [StrName -> MemType
mkName StrName
sn] Maybe MemType
forall a. Maybe a
Nothing,
		StrName -> [MemType] -> Q Dec
mkPatternSig StrName
sn [MemType]
mts, StrName -> StrSize -> [StrName] -> [MemPeek] -> Q Dec
mkPatternBody StrName
sn StrSize
sz [StrName]
mns [MemPeek]
mpos,
		StrName -> [MemType] -> Q Dec
mkPatternFunSig StrName
sn [MemType]
mts, StrName -> [MemPeek] -> Q Dec
mkPatternFunBody StrName
sn [MemPeek]
mpes ]
	Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName
-> StrSize -> StrSize -> [StrName] -> DerivCollection -> DecsQ
mkInstances StrName
sn StrSize
sz StrSize
algn [StrName]
mns DerivCollection
dcs
	where dcs :: DerivCollection
dcs = case [MemType] -> (DerivCollection, [MemType])
toDerivCollection [MemType]
dcs_ of
		(DerivCollection
d, []) -> DerivCollection
d; (DerivCollection
_, [MemType]
os) -> StrName -> DerivCollection
forall a. HasCallStack => StrName -> a
error (StrName -> DerivCollection) -> StrName -> DerivCollection
forall a b. (a -> b) -> a -> b
$ StrName
"Can't derive: " StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ [MemType] -> StrName
forall a. Show a => a -> StrName
show [MemType]
os

-- ^
-- Example
--
-- @
-- struct \"Foo\" ${size Foo} #{alignment Foo}
--	[	(\"x\", ''CInt, [| \#{peek Foo, x} |], [| \#{poke Foo, x} |]),
--		(\"y\", ''CInt, [| \#{peek Foo, y} |], [| \#{poke Foo, y} |]) ]
--	[''Show, ''Read, ''Eq, ''Ord, ''Bounded, ''Storable]
-- @

type StrName = String; type StrSize = Integer; type StrAlgn = Integer
type MemName = String; type MemType = Name
type MemPeek = ExpQ; type MemPoke = ExpQ
type DerivClass = Name

-- NEWTYPE

mkNewtype :: StrName -> DecQ
mkNewtype :: StrName -> Q Dec
mkNewtype StrName
sn =
	CxtQ
-> MemType
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD ([PredQ] -> CxtQ
cxt []) (StrName -> MemType
mkName StrName
sn) [] Maybe Kind
forall a. Maybe a
Nothing (MemType -> [BangTypeQ] -> ConQ
normalC (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"_") [
		BangQ -> PredQ -> BangTypeQ
bangType
			(SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
			(MemType -> PredQ
conT ''ForeignPtr PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT (StrName -> MemType
mkName StrName
sn)) ]) []

-- PATTERN

-- Function Mk Pattern

mkPatternSig :: StrName -> [MemType] -> DecQ
mkPatternSig :: StrName -> [MemType] -> Q Dec
mkPatternSig (StrName -> MemType
mkName -> MemType
sn) = MemType -> PredQ -> Q Dec
patSynSigD MemType
sn (PredQ -> Q Dec) -> ([MemType] -> PredQ) -> [MemType] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PredQ -> PredQ -> PredQ) -> PredQ -> [PredQ] -> PredQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PredQ -> PredQ -> PredQ
(.->) (MemType -> PredQ
conT MemType
sn) ([PredQ] -> PredQ) -> ([MemType] -> [PredQ]) -> [MemType] -> PredQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemType -> PredQ
conT (MemType -> PredQ) -> [MemType] -> [PredQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

mkPatternBody :: StrName -> StrSize -> [MemName] -> [MemPoke] -> DecQ
mkPatternBody :: StrName -> StrSize -> [StrName] -> [MemPeek] -> Q Dec
mkPatternBody StrName
sn StrSize
sz [StrName]
ms_ [MemPeek]
pos = MemType -> PatSynArgsQ -> PatSynDirQ -> PatQ -> Q Dec
patSynD (StrName -> MemType
mkName StrName
sn) ([MemType] -> PatSynArgsQ
recordPatSyn [MemType]
ms)
	([ClauseQ] -> PatSynDirQ
explBidir [StrName -> StrSize -> [MemPeek] -> ClauseQ
mkPatternBodyClause StrName
sn StrSize
sz [MemPeek]
pos])
	(MemPeek -> PatQ -> PatQ
viewP (MemType -> MemPeek
varE (MemType -> MemPeek) -> (StrName -> MemType) -> StrName -> MemPeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName (StrName -> MemPeek) -> StrName -> MemPeek
forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn) ([PatQ] -> PatQ
tupP' ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ms))
	where ms :: [MemType]
ms = StrName -> MemType
mkName (StrName -> MemType) -> (StrName -> StrName) -> StrName -> MemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> StrName -> StrName
toLabel StrName
sn (StrName -> MemType) -> [StrName] -> [MemType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StrName]
ms_

mkPatternBodyClause :: StrName -> StrSize -> [MemPoke] -> ClauseQ
mkPatternBodyClause :: StrName -> StrSize -> [MemPeek] -> ClauseQ
mkPatternBodyClause (StrName -> MemType
mkName (StrName -> MemType) -> (StrName -> StrName) -> StrName -> MemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"_") -> MemType
sn) StrSize
sz [MemPeek]
pos = do
	([MemType]
vs, MemType
p) <- (,) ([MemType] -> MemType -> ([MemType], MemType))
-> Q [MemType] -> Q (MemType -> ([MemType], MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemPeek] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MemPeek]
pos Int -> Q MemType -> Q [MemType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM` StrName -> Q MemType
newName StrName
"v" Q (MemType -> ([MemType], MemType))
-> Q MemType -> Q ([MemType], MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"p"
	let	vps :: [PatQ]
vps = MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs; pe :: MemPeek
pe = MemType -> MemPeek
varE MemType
p; fr :: MemPeek
fr = MemType -> MemPeek
varE 'free MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
pe
	[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
vps (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'unsafePerformIO MemPeek -> MemPeek -> MemPeek
.$ MemType -> MemPeek
conE MemType
sn MemPeek -> MemPeek -> MemPeek
.<$> [StmtQ] -> MemPeek
doE (
		(MemType -> PatQ
varP MemType
p PatQ -> MemPeek -> StmtQ
`bindS` (MemType -> MemPeek
varE 'mallocBytes MemPeek -> MemPeek -> MemPeek
`appE` StrSize -> MemPeek
intE StrSize
sz)) StmtQ -> [StmtQ] -> [StmtQ]
forall a. a -> [a] -> [a]
:
		((((MemPeek, MemType) -> StmtQ) -> [(MemPeek, MemType)] -> [StmtQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemPeek] -> [MemType] -> [(MemPeek, MemType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MemPeek]
pos [MemType]
vs) \(MemPeek
po, MemType
v) ->
			MemPeek -> StmtQ
noBindS (MemPeek -> StmtQ) -> MemPeek -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemPeek
po MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
pe MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
v) [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++
		[MemPeek -> StmtQ
noBindS (MemPeek -> StmtQ) -> MemPeek -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'newForeignPtr MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
pe MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
fr] )) []

-- Function Mk Pattern Fun

mkPatternFunSig :: StrName -> [MemType] -> DecQ
mkPatternFunSig :: StrName -> [MemType] -> Q Dec
mkPatternFunSig (StrName -> MemType
mkName (StrName -> MemType) -> (StrName -> StrName) -> StrName -> MemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> StrName
lcfirst (StrName -> MemType)
-> (StrName -> PredQ) -> StrName -> (MemType, PredQ)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& MemType -> PredQ
conT (MemType -> PredQ) -> (StrName -> MemType) -> StrName -> PredQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName -> (MemType
fn, PredQ
st)) =
	MemType -> PredQ -> Q Dec
sigD MemType
fn (PredQ -> Q Dec) -> ([MemType] -> PredQ) -> [MemType] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PredQ
st PredQ -> PredQ -> PredQ
.->) (PredQ -> PredQ) -> ([MemType] -> PredQ) -> [MemType] -> PredQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PredQ] -> PredQ
tupT ([PredQ] -> PredQ) -> ([MemType] -> [PredQ]) -> [MemType] -> PredQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemType -> PredQ
conT (MemType -> PredQ) -> [MemType] -> [PredQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

mkPatternFunBody :: StrName -> [MemPeek] -> DecQ
mkPatternFunBody :: StrName -> [MemPeek] -> Q Dec
mkPatternFunBody (StrName -> MemType
mkName (StrName -> MemType) -> (StrName -> StrName) -> StrName -> MemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> StrName
lcfirst (StrName -> MemType)
-> (StrName -> MemType) -> StrName -> (MemType, MemType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& StrName -> MemType
mkName (StrName -> MemType) -> (StrName -> StrName) -> StrName -> MemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"_") -> (MemType
fn, MemType
cn)) [MemPeek]
pes =
	MemType -> [ClauseQ] -> Q Dec
funD MemType
fn ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: []) (ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ (,) (MemType -> MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"f" Q (MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"p" Q (MemType, MemType) -> ((MemType, MemType) -> ClauseQ) -> ClauseQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MemType
f, MemType
p) ->
		[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> [PatQ] -> PatQ
conP MemType
cn [MemType -> PatQ
varP MemType
f]] (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'unsafePerformIO
			MemPeek -> MemPeek -> MemPeek
.$ MemType -> MemPeek
varE 'withForeignPtr MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
f
				MemPeek -> MemPeek -> MemPeek
`appE` [PatQ] -> MemPeek -> MemPeek
lamE [PatQ -> PatQ -> Bool -> PatQ
forall a. a -> a -> Bool -> a
bool (MemType -> PatQ
varP MemType
p) PatQ
wildP (Bool -> PatQ) -> Bool -> PatQ
forall a b. (a -> b) -> a -> b
$ [MemPeek] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MemPeek]
pes]
					(MemType -> [MemPeek] -> MemPeek
mkPatternFunPeeks MemType
p [MemPeek]
pes)) []

mkPatternFunPeeks :: Name -> [MemPeek] -> ExpQ
mkPatternFunPeeks :: MemType -> [MemPeek] -> MemPeek
mkPatternFunPeeks (MemType -> MemPeek
varE -> MemPeek
p) ([MemPeek] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([MemPeek] -> Int)
-> ([MemPeek] -> [MemPeek]) -> [MemPeek] -> (Int, [MemPeek])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [MemPeek] -> [MemPeek]
forall a. a -> a
id -> (Int
n, [MemPeek]
pes)) =
	(MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
(.<*>) (MemType -> MemPeek
varE 'pure MemPeek -> MemPeek -> MemPeek
.$ Int -> MemPeek
tupleE Int
n) ([MemPeek] -> MemPeek) -> [MemPeek] -> MemPeek
forall a b. (a -> b) -> a -> b
$ (MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
p) (MemPeek -> MemPeek) -> [MemPeek] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemPeek]
pes

-- DERIVING

-- Function Mk Deriving

mkInstances :: StrName -> StrSize -> StrAlgn -> [MemName] -> DerivCollection -> DecsQ
mkInstances :: StrName
-> StrSize -> StrSize -> [StrName] -> DerivCollection -> DecsQ
mkInstances StrName
sn StrSize
sz StrSize
algn [StrName]
ms DerivCollection
dc =
	[Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Dec] -> DecsQ) -> [Q Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (\(Q Dec
t, Bool
b) -> Maybe (Q Dec) -> Maybe (Q Dec) -> Bool -> Maybe (Q Dec)
forall a. a -> a -> Bool -> a
bool Maybe (Q Dec)
forall a. Maybe a
Nothing (Q Dec -> Maybe (Q Dec)
forall a. a -> Maybe a
Just Q Dec
t) Bool
b) ((Q Dec, Bool) -> Maybe (Q Dec)) -> [(Q Dec, Bool)] -> [Q Dec]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` [Q Dec] -> [Bool] -> [(Q Dec, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [
		StrName -> [StrName] -> Q Dec
mkInstanceShow StrName
sn [StrName]
ms, StrName -> [StrName] -> Q Dec
mkInstanceRead StrName
sn [StrName]
ms, StrName -> [StrName] -> Q Dec
mkInstanceEq StrName
sn [StrName]
ms,
		StrName -> [StrName] -> Q Dec
mkInstanceOrd StrName
sn [StrName]
ms, StrName -> [StrName] -> Q Dec
mkInstanceBounded StrName
sn [StrName]
ms, StrName -> [StrName] -> Q Dec
mkInstanceIx StrName
sn [StrName]
ms,
		StrName -> StrSize -> StrSize -> Q Dec
deriveStorable StrName
sn StrSize
sz StrSize
algn
		] [	DerivCollection -> Bool
derivingShow DerivCollection
dc, DerivCollection -> Bool
derivingRead DerivCollection
dc, DerivCollection -> Bool
derivingEq DerivCollection
dc,
			DerivCollection -> Bool
derivingOrd DerivCollection
dc, DerivCollection -> Bool
derivingBounded DerivCollection
dc, DerivCollection -> Bool
derivingIx DerivCollection
dc,
			DerivCollection -> Bool
derivingStorable DerivCollection
dc ]

data DerivCollection = DerivCollection {
	DerivCollection -> Bool
derivingShow :: Bool, DerivCollection -> Bool
derivingRead :: Bool,
	DerivCollection -> Bool
derivingEq :: Bool, DerivCollection -> Bool
derivingOrd :: Bool,
	DerivCollection -> Bool
derivingBounded :: Bool, DerivCollection -> Bool
derivingIx :: Bool,
	DerivCollection -> Bool
derivingStorable :: Bool } deriving Int -> DerivCollection -> StrName -> StrName
[DerivCollection] -> StrName -> StrName
DerivCollection -> StrName
(Int -> DerivCollection -> StrName -> StrName)
-> (DerivCollection -> StrName)
-> ([DerivCollection] -> StrName -> StrName)
-> Show DerivCollection
forall a.
(Int -> a -> StrName -> StrName)
-> (a -> StrName) -> ([a] -> StrName -> StrName) -> Show a
showList :: [DerivCollection] -> StrName -> StrName
$cshowList :: [DerivCollection] -> StrName -> StrName
show :: DerivCollection -> StrName
$cshow :: DerivCollection -> StrName
showsPrec :: Int -> DerivCollection -> StrName -> StrName
$cshowsPrec :: Int -> DerivCollection -> StrName -> StrName
Show

toDerivCollection :: [DerivClass] -> (DerivCollection, [DerivClass])
toDerivCollection :: [MemType] -> (DerivCollection, [MemType])
toDerivCollection [] = (Bool
-> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> DerivCollection
DerivCollection Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False, [])
toDerivCollection (MemType
d : [MemType]
ds) = case MemType
d of
	MemType
NameShow -> (DerivCollection
dc { derivingShow :: Bool
derivingShow = Bool
True }, [MemType]
ds')
	MemType
NameRead -> (DerivCollection
dc { derivingRead :: Bool
derivingRead = Bool
True }, [MemType]
ds')
	MemType
NameEq -> (DerivCollection
dc { derivingEq :: Bool
derivingEq = Bool
True }, [MemType]
ds')
	MemType
NameOrd -> (DerivCollection
dc { derivingOrd :: Bool
derivingOrd = Bool
True }, [MemType]
ds')
	MemType
NameBounded -> (DerivCollection
dc { derivingBounded :: Bool
derivingBounded = Bool
True }, [MemType]
ds')
	MemType
NameIx -> (DerivCollection
dc { derivingIx :: Bool
derivingIx = Bool
True }, [MemType]
ds')
	MemType
NameStorable -> (DerivCollection
dc { derivingStorable :: Bool
derivingStorable = Bool
True }, [MemType]
ds')
	MemType
_ -> (DerivCollection
dc, MemType
d MemType -> [MemType] -> [MemType]
forall a. a -> [a] -> [a]
: [MemType]
ds')
	where (DerivCollection
dc, [MemType]
ds') = [MemType] -> (DerivCollection, [MemType])
toDerivCollection [MemType]
ds

pattern NameShow, NameRead, NameEq, NameOrd, NameBounded, NameIx,
	NameStorable :: Name
pattern $mNameShow :: forall r. MemType -> (Void# -> r) -> (Void# -> r) -> r
NameShow <- ((== ''Show) -> True)
pattern $mNameRead :: forall r. MemType -> (Void# -> r) -> (Void# -> r) -> r
NameRead <- ((== ''Read) -> True)
pattern $mNameEq :: forall r. MemType -> (Void# -> r) -> (Void# -> r) -> r
NameEq <- ((== ''Eq) -> True)
pattern $mNameOrd :: forall r. MemType -> (Void# -> r) -> (Void# -> r) -> r
NameOrd <- ((== ''Ord) -> True)
pattern $mNameBounded :: forall r. MemType -> (Void# -> r) -> (Void# -> r) -> r
NameBounded <- ((== ''Bounded) -> True)
pattern $mNameIx :: forall r. MemType -> (Void# -> r) -> (Void# -> r) -> r
NameIx <- ((== ''Ix) -> True)
pattern $mNameStorable :: forall r. MemType -> (Void# -> r) -> (Void# -> r) -> r
NameStorable <- ((== ''Storable) -> True)

-- Show

mkInstanceShow :: StrName -> [MemName] -> DecQ
mkInstanceShow :: StrName -> [StrName] -> Q Dec
mkInstanceShow (StrName -> MemType
mkName (StrName -> MemType)
-> (StrName -> StrName) -> StrName -> (MemType, StrName)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& StrName -> StrName
forall a. a -> a
id -> (MemType
sn, StrName
ssn)) [StrName]
ms = do
	(MemType
s, [MemType]
vs) <- (,) (MemType -> [MemType] -> (MemType, [MemType]))
-> Q MemType -> Q ([MemType] -> (MemType, [MemType]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"s" Q ([MemType] -> (MemType, [MemType]))
-> Q [MemType] -> Q (MemType, [MemType])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [StrName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrName]
ms Int -> Q MemType -> Q [MemType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM` StrName -> Q MemType
newName StrName
"v"
	CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (MemType -> PredQ
conT ''Show PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT MemType
sn) ([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
$ MemType -> [ClauseQ] -> Q Dec
funD 'showsPrec [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP, MemType -> PatQ
varP MemType
s]
			(MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ StrName -> MemPeek
ss (StrName
ssn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
" {") MemPeek -> MemPeek -> MemPeek
...
				StrName -> [StrName] -> [MemType] -> MemPeek
mkShowMems StrName
ssn [StrName]
ms [MemType]
vs MemPeek -> MemPeek -> MemPeek
... StrName -> MemPeek
ss StrName
"}")
			[PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (MemType -> [PatQ] -> PatQ
conP MemType
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs) (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE MemType
s) []]]

mkShowMems :: StrName -> [MemName] -> [Name] -> ExpQ
mkShowMems :: StrName -> [StrName] -> [MemType] -> MemPeek
mkShowMems (StrName -> StrName -> StrName
toLabel -> StrName -> StrName
l) [StrName]
ms [MemType]
vs = (MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr MemPeek -> MemPeek -> MemPeek
(...) (MemType -> MemPeek
varE 'id) ([MemPeek] -> MemPeek)
-> ([MemPeek] -> [MemPeek]) -> [MemPeek] -> MemPeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemPeek -> [MemPeek] -> [MemPeek]
forall a. a -> [a] -> [a]
intersperse (StrName -> MemPeek
ss StrName
", ")
	([MemPeek] -> MemPeek) -> [MemPeek] -> MemPeek
forall a b. (a -> b) -> a -> b
$ (((StrName, MemType) -> MemPeek)
-> [(StrName, MemType)] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StrName] -> [MemType] -> [(StrName, MemType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [StrName]
ms [MemType]
vs) \(StrName
m, MemType
v) ->
		StrName -> StrName
l StrName
m StrName -> StrName -> MemPeek
..+ StrName
" = " MemPeek -> MemPeek -> MemPeek
... MemType -> MemPeek
varE 'showsPrec MemPeek -> MemPeek -> MemPeek
`appE` StrSize -> MemPeek
intE StrSize
0 MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
v

-- Read

mkInstanceRead :: StrName -> [MemName] -> DecQ
mkInstanceRead :: StrName -> [StrName] -> Q Dec
mkInstanceRead StrName
sn [StrName]
ms = [StrName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrName]
ms Int -> Q MemType -> Q [MemType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM` StrName -> Q MemType
newName StrName
"v" Q [MemType] -> ([MemType] -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[MemType]
vs ->
	CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (MemType -> PredQ
conT ''Read PredQ -> PredQ -> PredQ
`appT` PredQ
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 (MemType -> PatQ
varP 'readPrec) (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'parens
			MemPeek -> MemPeek -> MemPeek
.$ MemType -> MemPeek
varE 'prec MemPeek -> MemPeek -> MemPeek
`appE` StrSize -> MemPeek
intE StrSize
10 MemPeek -> MemPeek -> MemPeek
`appE` [StmtQ] -> MemPeek
doE ([
				MemType -> [PatQ] -> PatQ
conP 'Ident [StrName -> PatQ
strP StrName
sn] PatQ -> MemPeek -> StmtQ
`bindS` MemType -> MemPeek
varE 'lexP,
				MemType -> [PatQ] -> PatQ
conP 'Punc [StrName -> PatQ
strP StrName
"{"] PatQ -> MemPeek -> StmtQ
`bindS` MemType -> MemPeek
varE 'lexP ] [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++
				StrName -> [StrName] -> [MemType] -> [StmtQ]
mkReadMems StrName
sn [StrName]
ms [MemType]
vs [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [
				MemType -> [PatQ] -> PatQ
conP 'Punc [StrName -> PatQ
strP StrName
"}"] PatQ -> MemPeek -> StmtQ
`bindS` MemType -> MemPeek
varE 'lexP,
				MemPeek -> StmtQ
noBindS (MemPeek -> StmtQ) -> MemPeek -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'pure
					MemPeek -> MemPeek -> MemPeek
.$ (MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
appE MemPeek
c (MemType -> MemPeek
varE (MemType -> MemPeek) -> [MemType] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs) ])) []
	where t :: PredQ
t = MemType -> PredQ
conT (MemType -> PredQ) -> MemType -> PredQ
forall a b. (a -> b) -> a -> b
$ StrName -> MemType
mkName StrName
sn; c :: MemPeek
c = MemType -> MemPeek
conE (MemType -> MemPeek) -> MemType -> MemPeek
forall a b. (a -> b) -> a -> b
$ StrName -> MemType
mkName StrName
sn

mkReadMems :: StrName -> [MemName] -> [Name] -> [StmtQ]
mkReadMems :: StrName -> [StrName] -> [MemType] -> [StmtQ]
mkReadMems StrName
sn [StrName]
ms [MemType]
vs =
	[StmtQ] -> [[StmtQ]] -> [StmtQ]
forall a. [a] -> [[a]] -> [a]
intercalate [MemType -> [PatQ] -> PatQ
conP 'Punc [StrName -> PatQ
strP StrName
","] PatQ -> MemPeek -> StmtQ
`bindS` MemType -> MemPeek
varE 'lexP]
		([[StmtQ]] -> [StmtQ]) -> [[StmtQ]] -> [StmtQ]
forall a b. (a -> b) -> a -> b
$ (((StrName, MemType) -> [StmtQ])
-> [(StrName, MemType)] -> [[StmtQ]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StrName] -> [MemType] -> [(StrName, MemType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [StrName]
ms [MemType]
vs) \(StrName
m, MemType
v) -> [
			MemType -> [PatQ] -> PatQ
conP 'Ident [StrName -> PatQ
strP (StrName -> PatQ) -> StrName -> PatQ
forall a b. (a -> b) -> a -> b
$ StrName -> StrName -> StrName
toLabel StrName
sn StrName
m] PatQ -> MemPeek -> StmtQ
`bindS` MemType -> MemPeek
varE 'lexP,
			MemType -> [PatQ] -> PatQ
conP 'Punc [StrName -> PatQ
strP StrName
"="] PatQ -> MemPeek -> StmtQ
`bindS` MemType -> MemPeek
varE 'lexP,
			MemType -> PatQ
varP MemType
v PatQ -> MemPeek -> StmtQ
`bindS` (MemType -> MemPeek
varE 'step MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE 'readPrec) ]

-- Eq

mkInstanceEq :: StrName -> [MemName] -> DecQ
mkInstanceEq :: StrName -> [StrName] -> Q Dec
mkInstanceEq StrName
sn [StrName]
ms = (,) (MemType -> MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"s" Q (MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"t" Q (MemType, MemType) -> ((MemType, MemType) -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MemType
s, MemType
t) ->
	CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (MemType -> PredQ
conT ''Eq PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT (StrName -> MemType
mkName StrName
sn)) ([Q Dec] -> Q Dec) -> (ClauseQ -> [Q Dec]) -> ClauseQ -> 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]) -> (ClauseQ -> Q Dec) -> ClauseQ -> [Q Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemType -> [ClauseQ] -> Q Dec
funD '(==) ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: []) (ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> PatQ
varP MemType
s, MemType -> PatQ
varP MemType
t] (MemPeek -> BodyQ
normalB
			(MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ (MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
(.&&) (MemType -> MemPeek
conE 'True) ([MemPeek] -> MemPeek) -> [MemPeek] -> MemPeek
forall a b. (a -> b) -> a -> b
$ StrName -> MemType -> MemType -> StrName -> MemPeek
mkMemEq StrName
sn MemType
s MemType
t (StrName -> MemPeek) -> [StrName] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StrName]
ms) []

mkMemEq :: StrName -> Name -> Name -> MemName -> ExpQ
mkMemEq :: StrName -> MemType -> MemType -> StrName -> MemPeek
mkMemEq StrName
sn (MemType -> MemPeek
varE -> MemPeek
s) (MemType -> MemPeek
varE -> MemPeek
t) StrName
m = let l :: MemPeek
l = MemType -> MemPeek
varE (MemType -> MemPeek) -> (StrName -> MemType) -> StrName -> MemPeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName (StrName -> MemPeek) -> StrName -> MemPeek
forall a b. (a -> b) -> a -> b
$ StrName -> StrName -> StrName
toLabel StrName
sn StrName
m in
	MemPeek
l MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
s MemPeek -> MemPeek -> MemPeek
.== MemPeek
l MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
t

-- Ord

mkInstanceOrd :: StrName -> [MemName] -> DecQ
mkInstanceOrd :: StrName -> [StrName] -> Q Dec
mkInstanceOrd StrName
sn [StrName]
ms = (,) (MemType -> MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"s" Q (MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"t" Q (MemType, MemType) -> ((MemType, MemType) -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MemType
s, MemType
t) ->
	CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (MemType -> PredQ
conT ''Ord PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT (StrName -> MemType
mkName StrName
sn)) ([Q Dec] -> Q Dec) -> (ClauseQ -> [Q Dec]) -> ClauseQ -> 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]) -> (ClauseQ -> Q Dec) -> ClauseQ -> [Q Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemType -> [ClauseQ] -> Q Dec
funD '(<=) ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: []) (ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> PatQ
varP MemType
s, MemType -> PatQ
varP MemType
t] (
			MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'foldr MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemType -> MemPeek
lamOrd MemType
s MemType
t MemPeek -> MemPeek -> MemPeek
`appE`
				MemType -> MemPeek
conE 'True MemPeek -> MemPeek -> MemPeek
`appE` [MemPeek] -> MemPeek
listE [MemPeek]
ln ) []
	where ln :: [MemPeek]
ln = MemType -> MemPeek
varE (MemType -> MemPeek) -> (StrName -> MemType) -> StrName -> MemPeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName (StrName -> MemType) -> (StrName -> StrName) -> StrName -> MemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> StrName -> StrName
toLabel StrName
sn (StrName -> MemPeek) -> [StrName] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StrName]
ms

lamOrd :: Name -> Name -> ExpQ
lamOrd :: MemType -> MemType -> MemPeek
lamOrd (MemType -> MemPeek
varE -> MemPeek
s) (MemType -> MemPeek
varE -> MemPeek
t) =
	(,) (MemType -> MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"x" Q (MemType -> (MemType, MemType))
-> Q MemType -> Q (MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"v" Q (MemType, MemType) -> ((MemType, MemType) -> MemPeek) -> MemPeek
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MemType
x, MemType
v) -> let xe :: MemPeek
xe = MemType -> MemPeek
varE MemType
x in
		[PatQ] -> MemPeek -> MemPeek
lamE [MemType -> PatQ
varP MemType
x, MemType -> PatQ
varP MemType
v] (MemPeek -> MemPeek) -> MemPeek -> MemPeek
forall a b. (a -> b) -> a -> b
$ MemPeek
xe MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
s MemPeek -> MemPeek -> MemPeek
.< MemPeek
xe MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
t MemPeek -> MemPeek -> MemPeek
.||
			MemPeek
xe MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
s MemPeek -> MemPeek -> MemPeek
.== MemPeek
xe MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
t MemPeek -> MemPeek -> MemPeek
.&& MemType -> MemPeek
varE MemType
v

-- Bounded

mkInstanceBounded :: StrName -> [MemName] -> DecQ
mkInstanceBounded :: StrName -> [StrName] -> Q Dec
mkInstanceBounded (StrName -> MemType
mkName -> MemType
sn) ([StrName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Int
n) =
	CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (MemType -> PredQ
conT ''Bounded PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT MemType
sn) [
		PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (MemType -> PatQ
varP 'minBound) (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ (MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
appE (MemType -> MemPeek
conE MemType
sn)
			(Int -> MemPeek -> [MemPeek]
forall a. Int -> a -> [a]
replicate Int
n (MemPeek -> [MemPeek]) -> MemPeek -> [MemPeek]
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'minBound)) [],
		PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (MemType -> PatQ
varP 'maxBound) (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ (MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
appE (MemType -> MemPeek
conE MemType
sn)
			(Int -> MemPeek -> [MemPeek]
forall a. Int -> a -> [a]
replicate Int
n (MemPeek -> [MemPeek]) -> MemPeek -> [MemPeek]
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'maxBound)) [] ]

-- Ix

mkInstanceIx :: StrName -> [MemName] -> DecQ
mkInstanceIx :: StrName -> [StrName] -> Q Dec
mkInstanceIx (StrName -> MemType
mkName -> MemType
sn) [StrName]
ms = CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (MemType -> PredQ
conT ''Ix PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT MemType
sn) [
	MemType -> MemType -> [StrName] -> Q Dec
mkRange 'range MemType
sn [StrName]
ms, MemType -> MemType -> [StrName] -> Q Dec
mkIndex 'index MemType
sn [StrName]
ms, MemType -> MemType -> [StrName] -> Q Dec
mkInRange 'inRange MemType
sn [StrName]
ms ]

mkRange :: Name -> Name -> [MemName] -> DecQ
mkRange :: MemType -> MemType -> [StrName] -> Q Dec
mkRange MemType
fn MemType
sn ([StrName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Int
n) = do
	([MemType]
vs, [MemType]
ws, [MemType]
is) <- [(MemType, MemType, MemType)] -> ([MemType], [MemType], [MemType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(MemType, MemType, MemType)]
 -> ([MemType], [MemType], [MemType]))
-> Q [(MemType, MemType, MemType)]
-> Q ([MemType], [MemType], [MemType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
n Int
-> Q (MemType, MemType, MemType) -> Q [(MemType, MemType, MemType)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM`
		((,,) (MemType -> MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType
-> Q (MemType -> MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"v" Q (MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"w" Q (MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType, MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"i")
	MemType -> [ClauseQ] -> Q Dec
funD MemType
fn ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: []) (ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
		[[PatQ] -> PatQ
tupP [MemType -> [PatQ] -> PatQ
conP MemType
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs, MemType -> [PatQ] -> PatQ
conP MemType
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ws]]
		(MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> ([StmtQ] -> MemPeek) -> [StmtQ] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StmtQ] -> MemPeek
compE ([StmtQ] -> MemPeek) -> ([StmtQ] -> [StmtQ]) -> [StmtQ] -> MemPeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [MemPeek -> StmtQ
noBindS (MemPeek -> StmtQ) -> ([MemPeek] -> MemPeek) -> [MemPeek] -> StmtQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
appE MemPeek
sne ([MemPeek] -> StmtQ) -> [MemPeek] -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE (MemType -> MemPeek) -> [MemType] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
is])
			([StmtQ] -> BodyQ) -> [StmtQ] -> BodyQ
forall a b. (a -> b) -> a -> b
$ (((MemType, (MemType, MemType)) -> StmtQ)
-> [(MemType, (MemType, MemType))] -> [StmtQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
is [MemType]
-> [(MemType, MemType)] -> [(MemType, (MemType, MemType))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ([MemType]
vs [MemType] -> [MemType] -> [(MemType, MemType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [MemType]
ws)) \(MemType
i, (MemType
v, MemType
w)) ->
				PatQ -> MemPeek -> StmtQ
bindS (MemType -> PatQ
varP MemType
i) (MemPeek -> StmtQ) -> MemPeek -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemPeek
rg MemPeek -> MemPeek -> MemPeek
`appE` [MemPeek] -> MemPeek
tupE [MemType -> MemPeek
varE MemType
v, MemType -> MemPeek
varE MemType
w]
			) []
	where rg :: MemPeek
rg = MemType -> MemPeek
varE 'range; sne :: MemPeek
sne = MemType -> MemPeek
conE MemType
sn

mkIndex :: Name -> Name -> [MemName] -> DecQ
mkIndex :: MemType -> MemType -> [StrName] -> Q Dec
mkIndex MemType
fn (MemType -> [PatQ] -> PatQ
conP -> [PatQ] -> PatQ
sn) ([StrName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Int
n) = do
	([MemType]
vs, [MemType]
ws, [MemType]
is) <- [(MemType, MemType, MemType)] -> ([MemType], [MemType], [MemType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(MemType, MemType, MemType)]
 -> ([MemType], [MemType], [MemType]))
-> Q [(MemType, MemType, MemType)]
-> Q ([MemType], [MemType], [MemType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
n Int
-> Q (MemType, MemType, MemType) -> Q [(MemType, MemType, MemType)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM`
		((,,) (MemType -> MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType
-> Q (MemType -> MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"v" Q (MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"w" Q (MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType, MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"i")
	MemType -> [ClauseQ] -> Q Dec
funD MemType
fn ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: []) (ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
		[[PatQ] -> PatQ
tupP [[PatQ] -> PatQ
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs, [PatQ] -> PatQ
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ws], [PatQ] -> PatQ
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
is]
		(MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'foldl MemPeek -> MemPeek -> MemPeek
`appE` MemPeek
mkIndexLam MemPeek -> MemPeek -> MemPeek
`appE` StrSize -> MemPeek
intE StrSize
0
			MemPeek -> MemPeek -> MemPeek
.$ [MemPeek] -> MemPeek
listE (MemType -> MemPeek
varE (MemType -> MemPeek) -> [MemType] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs) MemPeek -> MemPeek -> MemPeek
`zp` [MemPeek] -> MemPeek
listE (MemType -> MemPeek
varE (MemType -> MemPeek) -> [MemType] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ws) MemPeek -> MemPeek -> MemPeek
`zp`
				[MemPeek] -> MemPeek
listE (MemType -> MemPeek
varE (MemType -> MemPeek) -> [MemType] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
is)) []

mkIndexLam :: ExpQ
mkIndexLam :: MemPeek
mkIndexLam =
	(,,) (MemType -> MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType
-> Q (MemType -> MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"v" Q (MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"z" Q (MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType, MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"k" Q (MemType, MemType, MemType)
-> ((MemType, MemType, MemType) -> MemPeek) -> MemPeek
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MemType
v, MemType
z, MemType
k) ->
		[PatQ] -> MemPeek -> MemPeek
lamE [MemType -> PatQ
varP MemType
v, [PatQ] -> PatQ
tupP [MemType -> PatQ
varP MemType
z, MemType -> PatQ
varP MemType
k]]
			(MemPeek -> MemPeek) -> MemPeek -> MemPeek
forall a b. (a -> b) -> a -> b
$ (MemType -> MemPeek
varE 'index MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
z MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
k) MemPeek -> MemPeek -> MemPeek
.+
				(MemType -> MemPeek
varE 'rangeSize MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
z MemPeek -> MemPeek -> MemPeek
.* MemType -> MemPeek
varE MemType
v)

mkInRange :: Name -> Name -> [MemName] -> DecQ
mkInRange :: MemType -> MemType -> [StrName] -> Q Dec
mkInRange MemType
fn (MemType -> [PatQ] -> PatQ
conP -> [PatQ] -> PatQ
sn) ([StrName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Int
n) = do
	([MemType]
vs, [MemType]
ws, [MemType]
is) <- [(MemType, MemType, MemType)] -> ([MemType], [MemType], [MemType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(MemType, MemType, MemType)]
 -> ([MemType], [MemType], [MemType]))
-> Q [(MemType, MemType, MemType)]
-> Q ([MemType], [MemType], [MemType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
n Int
-> Q (MemType, MemType, MemType) -> Q [(MemType, MemType, MemType)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM`
		((,,) (MemType -> MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType
-> Q (MemType -> MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q MemType
newName StrName
"v" Q (MemType -> MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType -> (MemType, MemType, MemType))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"w" Q (MemType -> (MemType, MemType, MemType))
-> Q MemType -> Q (MemType, MemType, MemType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrName -> Q MemType
newName StrName
"i")
	MemType -> [ClauseQ] -> Q Dec
funD MemType
fn ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: []) (ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
		[[PatQ] -> PatQ
tupP [[PatQ] -> PatQ
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs, [PatQ] -> PatQ
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ws], [PatQ] -> PatQ
sn ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ MemType -> PatQ
varP (MemType -> PatQ) -> [MemType] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
is]
		(MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> ([MemPeek] -> MemPeek) -> [MemPeek] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemPeek -> MemPeek -> MemPeek) -> MemPeek -> [MemPeek] -> MemPeek
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr MemPeek -> MemPeek -> MemPeek
(.&&) (MemType -> MemPeek
conE 'True) ([MemPeek] -> BodyQ) -> [MemPeek] -> BodyQ
forall a b. (a -> b) -> a -> b
$
			((((MemType, MemType), MemType) -> MemPeek)
-> [((MemType, MemType), MemType)] -> [MemPeek]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs [MemType] -> [MemType] -> [(MemType, MemType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [MemType]
ws [(MemType, MemType)]
-> [MemType] -> [((MemType, MemType), MemType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [MemType]
is) \((MemType
v, MemType
w), MemType
i) ->
				MemPeek
ir MemPeek -> MemPeek -> MemPeek
`appE` [MemPeek] -> MemPeek
tupE [MemType -> MemPeek
varE MemType
v, MemType -> MemPeek
varE MemType
w] MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
i
			) []
	where ir :: MemPeek
ir = MemType -> MemPeek
varE 'inRange

---------------------------------------------------------------------------
-- STRUCT WITH PRIMITIVE MONAD
---------------------------------------------------------------------------

-- FUNCTION STRUCT PRIM

structPrim :: StrName -> FunCopy -> FunFree -> [DerivClass] -> DecsQ
structPrim :: StrName -> MemType -> MemType -> [MemType] -> DecsQ
structPrim StrName
nt MemType
cp MemType
fr [MemType]
ds = [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
	StrName -> [MemType] -> Q Dec
mkNewtypePrim StrName
nt [MemType]
ds, StrName -> Q Dec
mkTypeST StrName
nt, StrName -> Q Dec
mkTypeIO StrName
nt,
	StrName -> Q Dec
mkFreezeSig StrName
nt, StrName -> MemType -> MemType -> Q Dec
mkFreezeFun StrName
nt MemType
cp MemType
fr, StrName -> Q Dec
mkThawSig StrName
nt, StrName -> MemType -> MemType -> Q Dec
mkThawFun StrName
nt MemType
cp MemType
fr,
	StrName -> Q Dec
mkCopySig StrName
nt, StrName -> MemType -> MemType -> Q Dec
mkCopyFun StrName
nt MemType
cp MemType
fr ]

-- ^
-- Example
--
-- @
-- foreign import ccall "foo_copy" c_foo_copy :: Ptr Foo -> IO (Ptr Foo)
-- foreign import ccall "foo_free" c_foo_free :: Ptr Foo -> IO ()
--
-- structPrim "Foo" 'c_foo_copy 'c_foo_free [''Show]
-- @

type FunCopy = Name; type FunFree = Name

-- NEWTYPE AND TYPE SYNONYM

mkNewtypePrim :: StrName -> [DerivClass] -> DecQ
mkNewtypePrim :: StrName -> [MemType] -> Q Dec
mkNewtypePrim StrName
sn [MemType]
ds = StrName -> Q MemType
newName StrName
"s" Q MemType -> (MemType -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
s ->
	CxtQ
-> MemType
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD ([PredQ] -> CxtQ
cxt []) MemType
snp [MemType -> TyVarBndr
plainTV MemType
s] Maybe Kind
forall a. Maybe a
Nothing
		(MemType -> [BangTypeQ] -> ConQ
normalC MemType
snp ([BangTypeQ] -> ConQ)
-> (BangTypeQ -> [BangTypeQ]) -> BangTypeQ -> ConQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BangTypeQ -> [BangTypeQ] -> [BangTypeQ]
forall a. a -> [a] -> [a]
: []) (BangTypeQ -> ConQ) -> BangTypeQ -> ConQ
forall a b. (a -> b) -> a -> b
$ BangQ -> PredQ -> BangTypeQ
bangType
			(SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
			(MemType -> PredQ
conT ''ForeignPtr PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT (StrName -> MemType
mkName StrName
sn)))
		[Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ([PredQ] -> DerivClauseQ) -> [PredQ] -> DerivClauseQ
forall a b. (a -> b) -> a -> b
$ MemType -> PredQ
conT (MemType -> PredQ) -> [MemType] -> [PredQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ds]
	where snp :: MemType
snp = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim"

mkTypeIO :: StrName -> DecQ
mkTypeIO :: StrName -> Q Dec
mkTypeIO StrName
sn = MemType -> [TyVarBndr] -> PredQ -> Q Dec
tySynD (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"IO") []
	(PredQ -> Q Dec) -> PredQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ MemType -> PredQ
conT (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim") PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT ''RealWorld

mkTypeST :: StrName -> DecQ
mkTypeST :: StrName -> Q Dec
mkTypeST StrName
sn = MemType -> [TyVarBndr] -> PredQ -> Q Dec
tySynD (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"ST") [] (PredQ -> Q Dec) -> (StrName -> PredQ) -> StrName -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemType -> PredQ
conT (MemType -> PredQ) -> (StrName -> MemType) -> StrName -> PredQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName (StrName -> Q Dec) -> StrName -> Q Dec
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim"

-- FREEZE

mkFreezeSig :: StrName -> DecQ
mkFreezeSig :: StrName -> Q Dec
mkFreezeSig StrName
sn = StrName -> Q MemType
newName StrName
"m" Q MemType -> (MemType -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
m ->
	MemType -> PredQ -> Q Dec
sigD MemType
fn (PredQ -> Q Dec) -> (PredQ -> PredQ) -> PredQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT [] ([PredQ] -> CxtQ
cxt [MemType -> PredQ
conT ''PrimMonad PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
varT MemType
m])
		(PredQ -> Q Dec) -> PredQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ MemType -> PredQ
conT MemType
snp PredQ -> PredQ -> PredQ
`appT` (MemType -> PredQ
conT ''PrimState PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
varT MemType
m) PredQ -> PredQ -> PredQ
.->
			MemType -> PredQ
varT MemType
m PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
conT (StrName -> MemType
mkName StrName
sn)
	where fn :: MemType
fn = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Freeze"; snp :: MemType
snp = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim"

mkFreezeFun :: StrName -> FunCopy -> FunFree -> DecQ
mkFreezeFun :: StrName -> MemType -> MemType -> Q Dec
mkFreezeFun StrName
sn MemType
cp MemType
fr = StrName -> Q MemType
newName StrName
"fp" Q MemType -> (MemType -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
fp ->
	MemType -> [ClauseQ] -> Q Dec
funD (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Freeze") ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: []) (ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
		[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> [PatQ] -> PatQ
conP (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim") [MemType -> PatQ
varP MemType
fp]] (MemPeek -> BodyQ
normalB
			(MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ StrName -> MemType -> MemType -> MemType -> MemPeek
mkFreezeBody StrName
sn MemType
cp MemType
fr MemType
fp) []

mkFreezeBody :: StrName -> FunCopy -> FunFree -> Name -> ExpQ
mkFreezeBody :: StrName -> MemType -> MemType -> MemType -> MemPeek
mkFreezeBody StrName
sn MemType
cp MemType
fr MemType
fp =
	MemType -> MemPeek
varE 'unsafeIOToPrim MemPeek -> MemPeek -> MemPeek
... MemType -> MemPeek
conE (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"_") MemPeek -> MemPeek -> MemPeek
`pt` MemType -> MemPeek
varE '(<$>)
		MemPeek -> MemPeek -> MemPeek
.$ MemType -> MemPeek
varE 'withForeignPtr MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
fp MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
cp
			MemPeek -> MemPeek -> MemPeek
.>>= MemType -> MemPeek
varE 'newForeignPtr MemPeek -> MemPeek -> MemPeek
.<$> MemType -> MemPeek
varE 'id MemPeek -> MemPeek -> MemPeek
.<*> MemType -> MemPeek
varE MemType
fr

-- THAW

mkThawSig :: StrName -> DecQ
mkThawSig :: StrName -> Q Dec
mkThawSig StrName
sn = StrName -> Q MemType
newName StrName
"m" Q MemType -> (MemType -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
m ->
	MemType -> PredQ -> Q Dec
sigD MemType
fn (PredQ -> Q Dec) -> (PredQ -> PredQ) -> PredQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT [] ([PredQ] -> CxtQ
cxt [MemType -> PredQ
conT ''PrimMonad PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
varT MemType
m])
		(PredQ -> Q Dec) -> PredQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ MemType -> PredQ
conT (StrName -> MemType
mkName StrName
sn) PredQ -> PredQ -> PredQ
.-> MemType -> PredQ
varT MemType
m PredQ -> PredQ -> PredQ
`appT`
			(MemType -> PredQ
conT MemType
snp PredQ -> PredQ -> PredQ
`appT` (MemType -> PredQ
conT ''PrimState PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
varT MemType
m))
	where fn :: MemType
fn = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Thaw"; snp :: MemType
snp = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim"

mkThawFun :: StrName -> FunCopy -> FunFree -> DecQ
mkThawFun :: StrName -> MemType -> MemType -> Q Dec
mkThawFun StrName
sn MemType
cp MemType
fr = StrName -> Q MemType
newName StrName
"fp" Q MemType -> (MemType -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
fp ->
	MemType -> [ClauseQ] -> Q Dec
funD (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Thaw") ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: [])
		(ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> [PatQ] -> PatQ
conP (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"_") [MemType -> PatQ
varP MemType
fp]] (
			MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ StrName -> MemType -> MemType -> MemType -> MemPeek
mkThawBody StrName
sn MemType
cp MemType
fr MemType
fp) []

mkThawBody :: StrName -> FunCopy -> FunFree -> Name -> ExpQ
mkThawBody :: StrName -> MemType -> MemType -> MemType -> MemPeek
mkThawBody StrName
sn MemType
cp MemType
fr MemType
fp =
	MemType -> MemPeek
varE 'unsafeIOToPrim MemPeek -> MemPeek -> MemPeek
... MemType -> MemPeek
conE (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim") MemPeek -> MemPeek -> MemPeek
`pt` MemType -> MemPeek
varE '(<$>)
		MemPeek -> MemPeek -> MemPeek
.$ MemType -> MemPeek
varE 'withForeignPtr MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
fp MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
cp
			MemPeek -> MemPeek -> MemPeek
.>>= MemType -> MemPeek
varE 'newForeignPtr MemPeek -> MemPeek -> MemPeek
.<$> MemType -> MemPeek
varE 'id MemPeek -> MemPeek -> MemPeek
.<*> MemType -> MemPeek
varE MemType
fr

-- COPY

mkCopySig :: StrName -> DecQ
mkCopySig :: StrName -> Q Dec
mkCopySig StrName
sn = StrName -> Q MemType
newName StrName
"m" Q MemType -> (MemType -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
m ->
	MemType -> PredQ -> Q Dec
sigD MemType
fn (PredQ -> Q Dec) -> (PredQ -> PredQ) -> PredQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT [] ([PredQ] -> CxtQ
cxt [MemType -> PredQ
conT ''PrimMonad PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
varT MemType
m])
		(PredQ -> Q Dec) -> PredQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ MemType -> PredQ
conT MemType
snp PredQ -> PredQ -> PredQ
`appT` (MemType -> PredQ
conT ''PrimState PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
varT MemType
m) PredQ -> PredQ -> PredQ
.->
			MemType -> PredQ
varT MemType
m PredQ -> PredQ -> PredQ
`appT` (MemType -> PredQ
conT MemType
snp PredQ -> PredQ -> PredQ
`appT`
				(MemType -> PredQ
conT ''PrimState PredQ -> PredQ -> PredQ
`appT` MemType -> PredQ
varT MemType
m))
	where fn :: MemType
fn = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Copy"; snp :: MemType
snp = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim"

mkCopyFun :: StrName -> FunCopy -> FunFree -> DecQ
mkCopyFun :: StrName -> MemType -> MemType -> Q Dec
mkCopyFun StrName
sn MemType
cp MemType
fr = StrName -> Q MemType
newName StrName
"fp" Q MemType -> (MemType -> Q Dec) -> Q Dec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
fp ->
	MemType -> [ClauseQ] -> Q Dec
funD (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Copy") ([ClauseQ] -> Q Dec) -> (ClauseQ -> [ClauseQ]) -> ClauseQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: [])
		(ClauseQ -> Q Dec) -> ClauseQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> [PatQ] -> PatQ
conP (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim") [MemType -> PatQ
varP MemType
fp]] (MemPeek -> BodyQ
normalB
			(MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ StrName -> MemType -> MemType -> MemType -> MemPeek
mkCopyBody StrName
sn MemType
cp MemType
fr MemType
fp) []

mkCopyBody :: StrName -> FunCopy -> FunFree -> Name -> ExpQ
mkCopyBody :: StrName -> MemType -> MemType -> MemType -> MemPeek
mkCopyBody StrName
sn MemType
cp MemType
fr MemType
fp =
	MemType -> MemPeek
varE 'unsafeIOToPrim MemPeek -> MemPeek -> MemPeek
... MemType -> MemPeek
conE (StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
sn StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"Prim") MemPeek -> MemPeek -> MemPeek
`pt` MemType -> MemPeek
varE '(<$>)
		MemPeek -> MemPeek -> MemPeek
.$ MemType -> MemPeek
varE 'withForeignPtr MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
fp MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
cp
			MemPeek -> MemPeek -> MemPeek
.>>= MemType -> MemPeek
varE 'newForeignPtr MemPeek -> MemPeek -> MemPeek
.<$> MemType -> MemPeek
varE 'id MemPeek -> MemPeek -> MemPeek
.<*> MemType -> MemPeek
varE MemType
fr

-- DERIVE STORABLE

deriveStorable :: String -> Integer -> Integer -> DecQ
deriveStorable :: StrName -> StrSize -> StrSize -> Q Dec
deriveStorable StrName
n StrSize
sz StrSize
algn = do
	[MemType
ps, MemType
pd, MemType
pd', MemType
fps', MemType
ps'] <-
		StrName -> Q MemType
newName (StrName -> Q MemType) -> [StrName] -> Q [MemType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [StrName
"ps", StrName
"pd", StrName
"pd", StrName
"fps", StrName
"ps"]
	CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD ([PredQ] -> CxtQ
cxt []) (PredQ -> PredQ -> PredQ
appT (MemType -> PredQ
conT ''Storable) (MemType -> PredQ
conT MemType
tp)) [
		MemType -> [ClauseQ] -> Q Dec
funD 'sizeOf [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> (Lit -> MemPeek) -> Lit -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> MemPeek
litE (Lit -> BodyQ) -> Lit -> BodyQ
forall a b. (a -> b) -> a -> b
$ StrSize -> Lit
integerL StrSize
sz) []],
		MemType -> [ClauseQ] -> Q Dec
funD 'alignment
			[[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> (Lit -> MemPeek) -> Lit -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> MemPeek
litE (Lit -> BodyQ) -> Lit -> BodyQ
forall a b. (a -> b) -> a -> b
$ StrSize -> Lit
integerL StrSize
algn) []],
		MemType -> [ClauseQ] -> Q Dec
funD 'peek [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> PatQ
varP MemType
ps] (MemPeek -> BodyQ
normalB (MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ [StmtQ] -> MemPeek
doE [
			PatQ -> MemPeek -> StmtQ
bindS (MemType -> PatQ
varP MemType
pd) (MemPeek -> StmtQ) -> MemPeek -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'malloc,
			MemPeek -> StmtQ
noBindS (MemPeek -> StmtQ) -> MemPeek -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'copyBytes MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
pd MemPeek -> MemPeek -> MemPeek
`appE`
				MemType -> MemPeek
varE MemType
ps MemPeek -> MemPeek -> MemPeek
`appE` Lit -> MemPeek
litE (StrSize -> Lit
integerL StrSize
sz),
			MemPeek -> StmtQ
noBindS (MemPeek -> StmtQ) -> (MemPeek -> MemPeek) -> MemPeek -> StmtQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MemPeek -> MemPeek -> Maybe MemPeek -> MemPeek
infixE (MemPeek -> Maybe MemPeek
forall a. a -> Maybe a
Just (MemPeek -> Maybe MemPeek) -> MemPeek -> Maybe MemPeek
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
conE MemType
dc) (MemType -> MemPeek
varE '(<$>))
				(Maybe MemPeek -> MemPeek)
-> (MemPeek -> Maybe MemPeek) -> MemPeek -> MemPeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemPeek -> Maybe MemPeek
forall a. a -> Maybe a
Just (MemPeek -> StmtQ) -> MemPeek -> StmtQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'newForeignPtr
					MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
pd
					MemPeek -> MemPeek -> MemPeek
`appE` (MemType -> MemPeek
varE 'free MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
pd)
			]) [] ],
		MemType -> [ClauseQ] -> Q Dec
funD 'poke [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [MemType -> PatQ
varP MemType
pd', MemType -> [PatQ] -> PatQ
conP MemType
dc [MemType -> PatQ
varP MemType
fps']] (MemPeek -> BodyQ
normalB
			(MemPeek -> BodyQ) -> MemPeek -> BodyQ
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'withForeignPtr
				MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
fps' MemPeek -> MemPeek -> MemPeek
`appE` ([PatQ] -> MemPeek -> MemPeek
lamE [MemType -> PatQ
varP MemType
ps']
					(MemPeek -> MemPeek) -> MemPeek -> MemPeek
forall a b. (a -> b) -> a -> b
$ MemType -> MemPeek
varE 'copyBytes MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
pd'
						MemPeek -> MemPeek -> MemPeek
`appE` MemType -> MemPeek
varE MemType
ps'
						MemPeek -> MemPeek -> MemPeek
`appE` Lit -> MemPeek
litE (StrSize -> Lit
integerL StrSize
sz))) []]
		]
	where tp :: MemType
tp = StrName -> MemType
mkName StrName
n; dc :: MemType
dc = StrName -> MemType
mkName (StrName -> MemType) -> StrName -> MemType
forall a b. (a -> b) -> a -> b
$ StrName
n StrName -> StrName -> StrName
forall a. [a] -> [a] -> [a]
++ StrName
"_"