{-# 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,
	lookupTypeName, lookupValueName )
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, isJust, fromJust)
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 (
	(.->), (.$), (...), (.<$>), (.<*>), (.>>=),
	(.&&), (.||), (.==), (.<), (.+), (.*),
	intE, strP, pt, zp, ss, (..+), toLabel, lcfirst,
	bigTupleData, sbTupP, sbTupT, sbTupleE )

import Foreign.C.Struct.Ord

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

-- * 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 (forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 -> ([StrName]
mns, [MemType]
mts, [MemPeek]
mpes, [MemPeek]
mpos)) [MemType]
dcs_ = do
	Maybe (MemType, MemType)
mtpl <- if Int
ln forall a. Ord a => a -> a -> Bool
> Int
62
		then do	Maybe MemType
nm <- StrName -> Q (Maybe MemType)
lookupTypeName StrName
tplnm
			Maybe MemType
nm' <- StrName -> Q (Maybe MemType)
lookupValueName StrName
tplnm
			if forall a. Maybe a -> Bool
isJust Maybe MemType
nm Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe MemType
nm'
			then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. HasCallStack => Maybe a -> a
fromJust Maybe MemType
nm, forall a. HasCallStack => Maybe a -> a
fromJust Maybe MemType
nm')
			else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
tplnm forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
tplnm)
		else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
	(\Maybe Dec
mtd [Dec]
dt [Dec]
ist -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe Dec
mtd forall a b. (a -> b) -> a -> b
$ [Dec]
dt forall a. [a] -> [a] -> [a]
++ [Dec]
ist)
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do	Bool
b <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrName -> Q (Maybe MemType)
lookupTypeName StrName
tplnm
			if Bool
b
			then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
			else forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
				(\(MemType
tpl, MemType
tpl') -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MemType -> MemType -> Int -> DecQ
bigTupleData MemType
tpl MemType
tpl' Int
ln) Maybe (MemType, MemType)
mtpl
		forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
			StrName -> DecQ
mkNewtype StrName
sn,
			forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pragma -> Dec
PragmaD forall a b. (a -> b) -> a -> b
$ [MemType] -> Maybe MemType -> Pragma
CompleteP [StrName -> MemType
mkName StrName
sn] forall a. Maybe a
Nothing,
			StrName -> [MemType] -> DecQ
mkPatternSig StrName
sn [MemType]
mts,
			Maybe (MemType, MemType)
-> StrName -> StrSize -> [StrName] -> [MemPeek] -> DecQ
mkPatternBody Maybe (MemType, MemType)
mtpl StrName
sn StrSize
sz [StrName]
mns [MemPeek]
mpos,
			Maybe (MemType, MemType) -> StrName -> [MemType] -> DecQ
mkPatternFunSig Maybe (MemType, MemType)
mtpl StrName
sn [MemType]
mts,
			Maybe (MemType, MemType) -> StrName -> [MemPeek] -> DecQ
mkPatternFunBody Maybe (MemType, MemType)
mtpl StrName
sn [MemPeek]
mpes ]
		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) -> forall a. HasCallStack => StrName -> a
error forall a b. (a -> b) -> a -> b
$ StrName
"Can't derive: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> StrName
show [MemType]
os
	ln :: Int
ln = forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrName]
mns
	tplnm :: StrName
tplnm = StrName
"Tuple" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> StrName
show Int
ln

-- ^
-- 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 -> DecQ
mkNewtype StrName
sn =
	forall (m :: * -> *).
Quote m =>
m Cxt
-> MemType
-> [TyVarBndr ()]
-> Maybe Kind
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (StrName -> MemType
mkName StrName
sn) [] forall a. Maybe a
Nothing (forall (m :: * -> *). Quote m => MemType -> [m BangType] -> m Con
normalC (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"_") [
		forall (m :: * -> *). Quote m => m Bang -> m Kind -> m BangType
bangType
			(forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness)
			(forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''ForeignPtr forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` forall (m :: * -> *). Quote m => MemType -> m Kind
conT (StrName -> MemType
mkName StrName
sn)) ]) []

-- PATTERN

-- Function Mk Pattern

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

mkPatternBody :: Maybe (Name, Name) -> StrName -> StrSize -> [MemName] -> [MemPoke] -> DecQ
mkPatternBody :: Maybe (MemType, MemType)
-> StrName -> StrSize -> [StrName] -> [MemPeek] -> DecQ
mkPatternBody Maybe (MemType, MemType)
mtpl StrName
sn StrSize
sz [StrName]
ms_ [MemPeek]
pos = forall (m :: * -> *).
Quote m =>
MemType -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD (StrName -> MemType
mkName StrName
sn) (forall (m :: * -> *). Quote m => [MemType] -> m PatSynArgs
recordPatSyn [MemType]
ms)
	(forall (m :: * -> *). Quote m => [m Clause] -> m PatSynDir
explBidir [StrName -> StrSize -> [MemPeek] -> Q Clause
mkPatternBodyClause StrName
sn StrSize
sz [MemPeek]
pos])
	(forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP (forall (m :: * -> *). Quote m => MemType -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn) (Maybe (MemType, MemType) -> [PatQ] -> PatQ
sbTupP Maybe (MemType, MemType)
mtpl forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ms))
	where ms :: [MemType]
ms = StrName -> MemType
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> StrName -> StrName
toLabel StrName
sn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StrName]
ms_

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

-- Function Mk Pattern Fun

mkPatternFunSig :: Maybe (Name, Name) -> StrName -> [MemType] -> DecQ
mkPatternFunSig :: Maybe (MemType, MemType) -> StrName -> [MemType] -> DecQ
mkPatternFunSig Maybe (MemType, MemType)
mtpl (StrName -> MemType
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> StrName
lcfirst forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (m :: * -> *). Quote m => MemType -> m Kind
conT forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName -> (MemType
fn, Q Kind
st)) =
	forall (m :: * -> *). Quote m => MemType -> m Kind -> m Dec
sigD MemType
fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Kind
st Q Kind -> Q Kind -> Q Kind
.->) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (MemType, MemType) -> [Q Kind] -> Q Kind
sbTupT Maybe (MemType, MemType)
mtpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *). Quote m => MemType -> m Kind
conT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

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

mkPatternFunPeeks :: Maybe (Name, Name) -> Name -> [MemPeek] -> ExpQ
mkPatternFunPeeks :: Maybe (MemType, MemType) -> MemType -> [MemPeek] -> MemPeek
mkPatternFunPeeks Maybe (MemType, MemType)
mtpl (forall (m :: * -> *). Quote m => MemType -> m Exp
varE -> MemPeek
p) (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id -> (Int
n, [MemPeek]
pes)) =
	forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
(.<*>) (forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'pure MemPeek -> MemPeek -> MemPeek
.$ Maybe (MemType, MemType) -> Int -> MemPeek
sbTupleE Maybe (MemType, MemType)
mtpl Int
n) forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` MemPeek
p) 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 =
	forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ (\(DecQ
t, Bool
b) -> forall a. a -> a -> Bool -> a
bool forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just DecQ
t) Bool
b) forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` forall a b. [a] -> [b] -> [(a, b)]
zip [
		StrName -> [StrName] -> DecQ
mkInstanceShow StrName
sn [StrName]
ms, StrName -> [StrName] -> DecQ
mkInstanceRead StrName
sn [StrName]
ms, StrName -> [StrName] -> DecQ
mkInstanceEq StrName
sn [StrName]
ms,
		StrName -> [StrName] -> DecQ
mkInstanceOrd StrName
sn [StrName]
ms, StrName -> [StrName] -> DecQ
mkInstanceBounded StrName
sn [StrName]
ms, StrName -> [StrName] -> DecQ
mkInstanceIx StrName
sn [StrName]
ms,
		StrName -> StrSize -> StrSize -> DecQ
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
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 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 -> ((# #) -> r) -> ((# #) -> r) -> r
NameShow <- ((== ''Show) -> True)
pattern $mNameRead :: forall {r}. MemType -> ((# #) -> r) -> ((# #) -> r) -> r
NameRead <- ((== ''Read) -> True)
pattern $mNameEq :: forall {r}. MemType -> ((# #) -> r) -> ((# #) -> r) -> r
NameEq <- ((== ''Eq) -> True)
pattern $mNameOrd :: forall {r}. MemType -> ((# #) -> r) -> ((# #) -> r) -> r
NameOrd <- ((== ''Ord) -> True)
pattern $mNameBounded :: forall {r}. MemType -> ((# #) -> r) -> ((# #) -> r) -> r
NameBounded <- ((== ''Bounded) -> True)
pattern $mNameIx :: forall {r}. MemType -> ((# #) -> r) -> ((# #) -> r) -> r
NameIx <- ((== ''Ix) -> True)
pattern $mNameStorable :: forall {r}. MemType -> ((# #) -> r) -> ((# #) -> r) -> r
NameStorable <- ((== ''Storable) -> True)

-- Show

mkInstanceShow :: StrName -> [MemName] -> DecQ
mkInstanceShow :: StrName -> [StrName] -> DecQ
mkInstanceShow (StrName -> MemType
mkName forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id -> (MemType
sn, StrName
ssn)) [StrName]
ms = do
	(MemType
s, [MemType]
vs) <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"s" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrName]
ms forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM` forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"v"
	forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''Show forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` forall (m :: * -> *). Quote m => MemType -> m Kind
conT MemType
sn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])
		forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD 'showsPrec [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
s]
			(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ StrName -> MemPeek
ss (StrName
ssn 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
"}")
			[forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => MemType -> [m Pat] -> m Pat
conP MemType
sn forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr MemPeek -> MemPeek -> MemPeek
(...) (forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (StrName -> MemPeek
ss StrName
", ")
	forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
... forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'showsPrec forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` StrSize -> MemPeek
intE StrSize
0 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
v

-- Read

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

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

-- Eq

mkInstanceEq :: StrName -> [MemName] -> DecQ
mkInstanceEq :: StrName -> [StrName] -> DecQ
mkInstanceEq StrName
sn [StrName]
ms = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"s" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"t" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MemType
s, MemType
t) ->
	forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''Eq forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` forall (m :: * -> *). Quote m => MemType -> m Kind
conT (StrName -> MemType
mkName StrName
sn)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])
		forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD '(==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
s, forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
t] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
			forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MemPeek -> MemPeek -> MemPeek
(.&&) (forall (m :: * -> *). Quote m => MemType -> m Exp
conE 'True) forall a b. (a -> b) -> a -> b
$ StrName -> MemType -> MemType -> StrName -> MemPeek
mkMemEq StrName
sn MemType
s MemType
t 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 (forall (m :: * -> *). Quote m => MemType -> m Exp
varE -> MemPeek
s) (forall (m :: * -> *). Quote m => MemType -> m Exp
varE -> MemPeek
t) StrName
m = let l :: MemPeek
l = forall (m :: * -> *). Quote m => MemType -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName -> StrName -> StrName
toLabel StrName
sn StrName
m in
	MemPeek
l forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` MemPeek
s MemPeek -> MemPeek -> MemPeek
.== MemPeek
l forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` MemPeek
t

-- Ord

mkInstanceOrd :: StrName -> [MemName] -> DecQ
mkInstanceOrd :: StrName -> [StrName] -> DecQ
mkInstanceOrd StrName
sn [StrName]
ms = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"s" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"t" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MemType
s, MemType
t) ->
	forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''Ord forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` forall (m :: * -> *). Quote m => MemType -> m Kind
conT (StrName -> MemType
mkName StrName
sn)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])
		forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD '(<=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
s, forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
t]
			(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ [MemPeek] -> MemPeek -> MemPeek -> MemPeek
compareAllMember
				(forall (m :: * -> *). Quote m => MemType -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> MemType
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrName -> StrName -> StrName
toLabel StrName
sn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StrName]
ms)
				(forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
s) (forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
t)) []

{-
		(
			normalB $ varE 'foldr `appE` lamOrd s t `appE`
				conE 'True `appE` listE ln ) []
	where ln = varE . mkName . toLabel sn <$> ms

lamOrd :: Name -> Name -> ExpQ
lamOrd (varE -> s) (varE -> t) =
	(,) <$> newName "x" <*> newName "v" >>= \(x, v) -> let xe = varE x in
		lamE [varP x, varP v] $ xe `appE` s .< xe `appE` t .||
			xe `appE` s .== xe `appE` t .&& varE v
-}

-- Bounded

mkInstanceBounded :: StrName -> [MemName] -> DecQ
mkInstanceBounded :: StrName -> [StrName] -> DecQ
mkInstanceBounded (StrName -> MemType
mkName -> MemType
sn) (forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Int
n) =
	forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''Bounded forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` forall (m :: * -> *). Quote m => MemType -> m Kind
conT MemType
sn) [
		forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => MemType -> m Pat
varP 'minBound) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => MemType -> m Exp
conE MemType
sn)
			(forall a. Int -> a -> [a]
replicate Int
n forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'minBound)) [],
		forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => MemType -> m Pat
varP 'maxBound) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => MemType -> m Exp
conE MemType
sn)
			(forall a. Int -> a -> [a]
replicate Int
n forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'maxBound)) [] ]

-- Ix

mkInstanceIx :: StrName -> [MemName] -> DecQ
mkInstanceIx :: StrName -> [StrName] -> DecQ
mkInstanceIx (StrName -> MemType
mkName -> MemType
sn) [StrName]
ms = forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''Ix forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` forall (m :: * -> *). Quote m => MemType -> m Kind
conT MemType
sn) [
	MemType -> MemType -> [StrName] -> DecQ
mkRange 'range MemType
sn [StrName]
ms, MemType -> MemType -> [StrName] -> DecQ
mkIndex 'index MemType
sn [StrName]
ms, MemType -> MemType -> [StrName] -> DecQ
mkInRange 'inRange MemType
sn [StrName]
ms ]

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

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

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

mkInRange :: Name -> Name -> [MemName] -> DecQ
mkInRange :: MemType -> MemType -> [StrName] -> DecQ
mkInRange MemType
fn (forall (m :: * -> *). Quote m => MemType -> [m Pat] -> m Pat
conP -> [PatQ] -> PatQ
sn) (forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Int
n) = do
	([MemType]
vs, [MemType]
ws, [MemType]
is) <- forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
n forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
`replicateM`
		((,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"v" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"w" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"i")
	forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD MemType
fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
		[forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [[PatQ] -> PatQ
sn forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs, [PatQ] -> PatQ
sn forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ws], [PatQ] -> PatQ
sn forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
is]
		(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr MemPeek -> MemPeek -> MemPeek
(.&&) (forall (m :: * -> *). Quote m => MemType -> m Exp
conE 'True) forall a b. (a -> b) -> a -> b
$
			(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
vs forall a b. [a] -> [b] -> [(a, b)]
`zip` [MemType]
ws forall a b. [a] -> [b] -> [(a, b)]
`zip` [MemType]
is) \((MemType
v, MemType
w), MemType
i) ->
				MemPeek
ir forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
v, forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
w] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
i
			) []
	where ir :: MemPeek
ir = forall (m :: * -> *). Quote m => MemType -> m Exp
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 = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
	StrName -> [MemType] -> DecQ
mkNewtypePrim StrName
nt [MemType]
ds, StrName -> DecQ
mkTypeST StrName
nt, StrName -> DecQ
mkTypeIO StrName
nt,
	StrName -> DecQ
mkFreezeSig StrName
nt, StrName -> MemType -> MemType -> DecQ
mkFreezeFun StrName
nt MemType
cp MemType
fr, StrName -> DecQ
mkThawSig StrName
nt, StrName -> MemType -> MemType -> DecQ
mkThawFun StrName
nt MemType
cp MemType
fr,
	StrName -> DecQ
mkCopySig StrName
nt, StrName -> MemType -> MemType -> DecQ
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] -> DecQ
mkNewtypePrim StrName
sn [MemType]
ds = forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"s" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
s ->
	forall (m :: * -> *).
Quote m =>
m Cxt
-> MemType
-> [TyVarBndr ()]
-> Maybe Kind
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) MemType
snp [MemType -> TyVarBndr ()
plainTV MemType
s] forall a. Maybe a
Nothing
		(forall (m :: * -> *). Quote m => MemType -> [m BangType] -> m Con
normalC MemType
snp forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Bang -> m Kind -> m BangType
bangType
			(forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness)
			(forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''ForeignPtr forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` forall (m :: * -> *). Quote m => MemType -> m Kind
conT (StrName -> MemType
mkName StrName
sn)))
		[forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Kind
conT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemType]
ds]
	where snp :: MemType
snp = StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Prim"

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

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

-- FREEZE

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

mkFreezeFun :: StrName -> FunCopy -> FunFree -> DecQ
mkFreezeFun :: StrName -> MemType -> MemType -> DecQ
mkFreezeFun StrName
sn MemType
cp MemType
fr = forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"fp" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
fp ->
	forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Freeze") forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall a b. (a -> b) -> a -> b
$
		forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => MemType -> [m Pat] -> m Pat
conP (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Prim") [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
fp]] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
			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 =
	forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'unsafeIOToPrim MemPeek -> MemPeek -> MemPeek
... forall (m :: * -> *). Quote m => MemType -> m Exp
conE (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"_") MemPeek -> MemPeek -> MemPeek
`pt` forall (m :: * -> *). Quote m => MemType -> m Exp
varE '(<$>)
		MemPeek -> MemPeek -> MemPeek
.$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'withForeignPtr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
fp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
cp
			MemPeek -> MemPeek -> MemPeek
.>>= forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'newForeignPtr MemPeek -> MemPeek -> MemPeek
.<$> forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'id MemPeek -> MemPeek -> MemPeek
.<*> forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
fr

-- THAW

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

mkThawFun :: StrName -> FunCopy -> FunFree -> DecQ
mkThawFun :: StrName -> MemType -> MemType -> DecQ
mkThawFun StrName
sn MemType
cp MemType
fr = forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"fp" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
fp ->
	forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Thaw") forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])
		forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => MemType -> [m Pat] -> m Pat
conP (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"_") [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
fp]] (
			forall (m :: * -> *). Quote m => m Exp -> m Body
normalB 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 =
	forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'unsafeIOToPrim MemPeek -> MemPeek -> MemPeek
... forall (m :: * -> *). Quote m => MemType -> m Exp
conE (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Prim") MemPeek -> MemPeek -> MemPeek
`pt` forall (m :: * -> *). Quote m => MemType -> m Exp
varE '(<$>)
		MemPeek -> MemPeek -> MemPeek
.$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'withForeignPtr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
fp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
cp
			MemPeek -> MemPeek -> MemPeek
.>>= forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'newForeignPtr MemPeek -> MemPeek -> MemPeek
.<$> forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'id MemPeek -> MemPeek -> MemPeek
.<*> forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
fr

-- COPY

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

mkCopyFun :: StrName -> FunCopy -> FunFree -> DecQ
mkCopyFun :: StrName -> MemType -> MemType -> DecQ
mkCopyFun StrName
sn MemType
cp MemType
fr = forall (m :: * -> *). Quote m => StrName -> m MemType
newName StrName
"fp" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MemType
fp ->
	forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName -> StrName
lcfirst StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Copy") forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])
		forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => MemType -> [m Pat] -> m Pat
conP (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Prim") [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
fp]] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
			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 =
	forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'unsafeIOToPrim MemPeek -> MemPeek -> MemPeek
... forall (m :: * -> *). Quote m => MemType -> m Exp
conE (StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
sn forall a. [a] -> [a] -> [a]
++ StrName
"Prim") MemPeek -> MemPeek -> MemPeek
`pt` forall (m :: * -> *). Quote m => MemType -> m Exp
varE '(<$>)
		MemPeek -> MemPeek -> MemPeek
.$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'withForeignPtr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
fp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
cp
			MemPeek -> MemPeek -> MemPeek
.>>= forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'newForeignPtr MemPeek -> MemPeek -> MemPeek
.<$> forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'id MemPeek -> MemPeek -> MemPeek
.<*> forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
fr

-- DERIVE STORABLE

deriveStorable :: String -> Integer -> Integer -> DecQ
deriveStorable :: StrName -> StrSize -> StrSize -> DecQ
deriveStorable StrName
n StrSize
sz StrSize
algn = do
	[MemType
ps, MemType
pd, MemType
pd', MemType
fps', MemType
ps'] <-
		forall (m :: * -> *). Quote m => StrName -> m MemType
newName 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"]
	forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (forall (m :: * -> *). Quote m => MemType -> m Kind
conT ''Storable) (forall (m :: * -> *). Quote m => MemType -> m Kind
conT MemType
tp)) [
		forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD 'sizeOf [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ StrSize -> Lit
integerL StrSize
sz) []],
		forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD 'alignment
			[forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ StrSize -> Lit
integerL StrSize
algn) []],
		forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD 'peek [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
ps] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [
			forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
pd) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'malloc,
			forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'copyBytes forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
pd forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
				forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
ps forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (StrSize -> Lit
integerL StrSize
sz),
			forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
conE MemType
dc) (forall (m :: * -> *). Quote m => MemType -> m Exp
varE '(<$>))
				forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'newForeignPtr
					forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
pd
					forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'free forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
pd)
			]) [] ],
		forall (m :: * -> *). Quote m => MemType -> [m Clause] -> m Dec
funD 'poke [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
pd', forall (m :: * -> *). Quote m => MemType -> [m Pat] -> m Pat
conP MemType
dc [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
fps']] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
			forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'withForeignPtr
				forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
fps' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => MemType -> m Pat
varP MemType
ps']
					forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => MemType -> m Exp
varE 'copyBytes forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
pd'
						forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => MemType -> m Exp
varE MemType
ps'
						forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (StrSize -> Lit
integerL StrSize
sz))) []]
		]
	where tp :: MemType
tp = StrName -> MemType
mkName StrName
n; dc :: MemType
dc = StrName -> MemType
mkName forall a b. (a -> b) -> a -> b
$ StrName
n forall a. [a] -> [a] -> [a]
++ StrName
"_"