{-# LANGUAGE TemplateHaskell, CPP #-}
{- |
Module          : Foreign.C.Structs.Templates
Description     : Create C structs from Haskell
Copyright       : (c) Simon Plakolb, 2020
License         : MIT
Maintainer      : s.plakolb@gmail.com
Stability       : beta

This module exposes the template haskell framework to create Struct types.
-}
module Foreign.C.Structs.Templates
    (structT, acs)
where

import Language.Haskell.TH

import Foreign.Storable (Storable, peek, poke, sizeOf, alignment)
import Foreign.Ptr (castPtr)
import Foreign.C.Structs.Utils (next, sizeof, fmax)

-- | All @StructN@ types and their instances of 'Storable' are declared using 'structT'.
-- It can theoretically create C structs with an infinite number of fields.
-- The parameter of 'structT' is the number of fields the struct type should have.
-- Its constructor and type will both be named @StructN@ where N is equal to the argument to 'structT'.
structT :: Int -> DecsQ
structT :: Int -> DecsQ
structT = [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> (Int -> [Dec]) -> Int -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Dec) -> Int -> Dec) -> [Int -> Dec] -> [Int] -> [Dec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Dec) -> Int -> Dec
forall a b. (a -> b) -> a -> b
($) [Int -> Dec
structTypeT, Int -> Dec
storableInstanceT] ([Int] -> [Dec]) -> (Int -> [Int]) -> Int -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. a -> [a]
repeat

-- | Access function for fields of a @StructN@ where @N@ is the number of fields in the struct.
-- N is the first argument passed to 'acs', while the second is the field number.
-- The first field has number 1, the second 2 and so on.
--
-- > s = Struct4 1 2 3 4
-- > $(acs 4 3) s
--
acs :: Int -> Int -> ExpQ
acs :: Int -> Int -> ExpQ
acs Int
big_n Int
small_n = [| \struct -> $(caseE [| struct |] [m]) |]
    where
          m :: MatchQ
          m :: MatchQ
m = PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
pat (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name]
vrs [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! (Int
small_nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) []

          pat :: PatQ
          pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP Name
str ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
big_n [Name]
vrs

          str :: Name
str = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Struct" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
big_n

          vrs :: [Name]
vrs = String -> [Name]
fieldnames String
""

-- Templating functions

structTypeT :: Int -> Dec
#if __GLASGOW_HASKELL__ < 800
structTypeT nfields = DataD [] (structType nfields) tyVars [constructor] deriv''
#elif __GLASGOW_HASKELL__ < 802
structTypeT nfields = DataD [] (structType nfields) tyVars Nothing [constructor] deriv'
#else
structTypeT :: Int -> Dec
structTypeT Int
nfields = Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] (Int -> Name
forall a. Show a => a -> Name
structType Int
nfields) [TyVarBndr]
tyVars Maybe Kind
forall a. Maybe a
Nothing [Con
constructor] [DerivClause
deriv]
#endif
    where
          tyVars :: [TyVarBndr]
tyVars    = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV ([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
nfields ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ String -> [Name]
fieldnames String
""

          constructor :: Con
constructor = Name -> [VarBangType] -> Con
RecC (Int -> Name
forall a. Show a => a -> Name
structType Int
nfields) ([VarBangType] -> Con) -> [VarBangType] -> Con
forall a b. (a -> b) -> a -> b
$ Int -> [VarBangType] -> [VarBangType]
forall a. Int -> [a] -> [a]
take Int
nfields [VarBangType]
records

          records :: [VarBangType]
records     = (Name -> Name -> VarBangType) -> [Name] -> [Name] -> [VarBangType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Name -> VarBangType
forall a. a -> Name -> (a, Bang, Kind)
defRec (Int -> [Name]
getters Int
nfields) (String -> [Name]
fieldnames String
"")
#if __GLASGOW_HASKELL__ < 800
          defRec n t  = (,,) n NotStrict (VarT t)
#else
          defRec :: a -> Name -> (a, Bang, Kind)
defRec a
n Name
t  = (,,) a
n (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness) (Name -> Kind
VarT Name
t)
#endif
          deriv'' :: [Name]
deriv'' = [''Show, ''Eq]

          deriv' :: Cxt
deriv' = (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
ConT [Name]
deriv''
#if __GLASGOW_HASKELL__ > 800
          deriv :: DerivClause
deriv = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing Cxt
deriv'
#endif

storableInstanceT :: Int -> Dec
#if __GLASGOW_HASKELL__ < 800
storableInstanceT nfields = InstanceD cxt tp decs
#else
storableInstanceT :: Int -> Dec
storableInstanceT Int
nfields = Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
cxt Kind
tp [Dec]
decs
#endif
    where
          vars :: [Name]
vars = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
nfields ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ String -> [Name]
fieldnames String
""

          storable :: Kind -> Kind
storable = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind) -> Kind -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
ConT ''Storable
#if __GLASGOW_HASKELL__ < 710
          cxt  = map (\v -> ClassP ''Storable [VarT v]) vars
#else
          cxt :: Cxt
cxt  = (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> Kind
storable (Kind -> Kind) -> (Name -> Kind) -> Name -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Kind
VarT) [Name]
vars
#endif
          tp :: Kind
tp   = Kind -> Kind
storable (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ Int -> Name
forall a. Show a => a -> Name
structType Int
nfields) (Cxt -> Kind) -> Cxt -> Kind
forall a b. (a -> b) -> a -> b
$ (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT [Name]
vars

          decs :: [Dec]
decs = [ Int -> Dec
sizeOfT Int
nfields
                 , Int -> Dec
alignmentT Int
nfields
                 , Int -> Dec
peekT Int
nfields
                 , Int -> Dec
pokeT Int
nfields
                 ]

-- Storable instance function temaples

sizeOfT :: Int -> Dec
sizeOfT :: Int -> Dec
sizeOfT Int
nfields = Name -> [Clause] -> Dec
FunD 'sizeOf [Clause
clause]
    where
          clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
struct] (Exp -> Body
NormalB Exp
body) [Dec]
wheres

          body :: Exp
body = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'sizeof) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Exp
alignments String
"a") (String -> Exp
sizes String
"s")

          alignments :: String -> Exp
alignments = [Exp] -> Exp
ListE ([Exp] -> Exp) -> (String -> [Exp]) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Exp] -> [Exp]
forall a. Int -> [a] -> [a]
take Int
nfields ([Exp] -> [Exp]) -> (String -> [Exp]) -> String -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE ([Name] -> [Exp]) -> (String -> [Name]) -> String -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Name]
fieldnames

          sizes :: String -> Exp
sizes = [Exp] -> Exp
ListE ([Exp] -> Exp) -> (String -> [Exp]) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Exp] -> [Exp]
forall a. Int -> [a] -> [a]
take Int
nfields ([Exp] -> [Exp]) -> (String -> [Exp]) -> String -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE ([Name] -> [Exp]) -> (String -> [Name]) -> String -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Name]
fieldnames

          wheres :: [Dec]
wheres = Name -> Int -> String -> [Dec]
vals 'alignment Int
nfields String
"a" [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ Name -> Int -> String -> [Dec]
vals 'sizeOf Int
nfields String
"s"

alignmentT :: Int -> Dec
alignmentT :: Int -> Dec
alignmentT Int
nfields = Name -> [Clause] -> Dec
FunD 'alignment [Clause
clause]
    where
           clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
struct] (Exp -> Body
NormalB Exp
body) [Dec]
wheres

           body :: Exp
body = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fmax) ([Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> [Exp] -> [Exp]
forall a. Int -> [a] -> [a]
take Int
nfields ([Exp] -> [Exp]) -> [Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE ([Name] -> [Exp]) -> [Name] -> [Exp]
forall a b. (a -> b) -> a -> b
$ String -> [Name]
fieldnames String
"")

           wheres :: [Dec]
wheres = Name -> Int -> String -> [Dec]
vals 'alignment Int
nfields String
""

peekT :: Int -> Dec
peekT :: Int -> Dec
peekT Int
nfields = Name -> [Clause] -> Dec
FunD 'peek [Clause
clause]
    where
          vars :: [Name]
vars = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
nfields ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ String -> [Name]
fieldnames String
""

          ptrs :: [Name]
ptrs = [Name] -> [Name]
forall a. [a] -> [a]
tail ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
nfields ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ String -> [Name]
fieldnames String
"_ptr"

          clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
ptr] (Exp -> Body
NormalB Exp
body) []

          body :: Exp
body = [Stmt] -> Exp
DoE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ [Stmt]
initial [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [[Stmt]] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Stmt]]
gotos [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt]
final

          initial :: [Stmt]
initial = [ Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. [a] -> a
head [Name]
vars) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'peek) Exp
castPtr')
                    , Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. [a] -> a
head [Name]
ptrs) (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'next) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
ptr) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. [a] -> a
head [Name]
vars)
                    ]


          gotos :: [[Stmt]]
gotos = (Name -> Name -> Name -> [Stmt])
-> [Name] -> [Name] -> [Name] -> [[Stmt]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> Name -> [Stmt]
goto ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
vars) [Name]
ptrs ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
ptrs)

          goto :: Name -> Name -> Name -> [Stmt]
goto Name
n Name
p Name
next_p = [Name -> Name -> Stmt
bindVar' Name
p Name
n, Name -> Name -> Exp -> Stmt
bindPtr' Name
next_p Name
p (Name -> Exp
VarE Name
n)]

          final :: [Stmt]
final = [ Name -> Name -> Stmt
bindVar' ([Name] -> Name
forall a. [a] -> a
last [Name]
ptrs) ([Name] -> Name
forall a. [a] -> a
last [Name]
vars)
                  , Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'return) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Int -> Name
forall a. Show a => a -> Name
structType Int
nfields)) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
vars)
                  ]

pokeT :: Int -> Dec
pokeT :: Int -> Dec
pokeT Int
nfields = Name -> [Clause] -> Dec
FunD 'poke [Clause
clause]
    where
          vars :: [Name]
vars = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
nfields ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ String -> [Name]
fieldnames String
""

          ptrs :: [Name]
ptrs = [Name] -> [Name]
forall a. [a] -> [a]
tail ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
nfields ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ String -> [Name]
fieldnames String
"_ptr"

          clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
patterns (Exp -> Body
NormalB Exp
body) []

          patterns :: [Pat]
patterns = [Name -> Pat
VarP Name
ptr, Name -> [Pat] -> Pat
ConP (Int -> Name
forall a. Show a => a -> Name
structType Int
nfields) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vars)]

          body :: Exp
body = [Stmt] -> Exp
DoE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ [Stmt
init_poke, Stmt
init_next] [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [[Stmt]] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Stmt]]
gotos [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt
final]

          init_poke :: Stmt
init_poke = Exp -> Stmt
NoBindS
                    (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
cast_poke_ptr (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. [a] -> a
head [Name]
vars)
                    where  cast_poke_ptr :: Exp
cast_poke_ptr = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'poke) Exp
castPtr'

          init_next :: Stmt
init_next = Name -> Name -> Exp -> Stmt
bindPtr' ([Name] -> Name
forall a. [a] -> a
head [Name]
ptrs) Name
ptr (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. [a] -> a
head [Name]
vars)

          gotos :: [[Stmt]]
gotos = (Name -> Name -> Name -> [Stmt])
-> [Name] -> [Name] -> [Name] -> [[Stmt]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> Name -> [Stmt]
goto ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
vars) [Name]
ptrs ([Name] -> [[Stmt]]) -> [Name] -> [[Stmt]]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
ptrs

          goto :: Name -> Name -> Name -> [Stmt]
goto Name
n Name
p Name
next_p = [Name -> Exp -> Stmt
pokeVar' Name
p Exp
var, Name -> Name -> Exp -> Stmt
bindPtr' Name
next_p Name
p Exp
var]
                where var :: Exp
var = Name -> Exp
VarE Name
n

          final :: Stmt
final = Name -> Exp -> Stmt
pokeVar' ([Name] -> Name
forall a. [a] -> a
last [Name]
ptrs) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. [a] -> a
last [Name]
vars)

-- Helpers and Constants

structType :: a -> Name
structType a
n = String -> Name
mkName (String
"Struct" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n)

struct :: Name
struct   = String -> Name
mkName String
"struct"

ptr :: Name
ptr      = String -> Name
mkName String
"ptr"

castPtr' :: Exp
castPtr' = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'castPtr) (Name -> Exp
VarE Name
ptr)

fieldnames :: String -> [Name]
fieldnames :: String -> [Name]
fieldnames String
s = (Char -> Name) -> String -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (Char -> String) -> Char -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:String
s)) [Char
'a'..Char
'z']

getters    :: Int -> [Name]
getters :: Int -> [Name]
getters Int
n = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"s" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++))
          ([String] -> [Name]) -> [String] -> [Name]
forall a b. (a -> b) -> a -> b
$  [String
"1st",String
"2nd",String
"3rd"]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Integer -> String
forall a. Show a => a -> String
show Integer
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"th" | Integer
n <- [Integer
4..]]

vals :: Name -> Int -> String -> [Dec]
vals Name
f Int
n String
s = Int -> [Dec] -> [Dec]
forall a. Int -> [a] -> [a]
take Int
n ([Dec] -> [Dec]) -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$ (Name -> Name -> Dec) -> [Name] -> [Name] -> [Dec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Name -> Dec
val (String -> [Name]
fieldnames String
s) (Int -> [Name]
getters Int
n)
    where
          val :: Name -> Name -> Dec
val Name
v Name
getter = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
v) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
body Name
getter) []

          body :: Name -> Exp
body Name
getter  = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
f) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
getter) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
struct

bindVar' :: Name -> Name -> Stmt
bindVar' Name
ptr Name
var = Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP Name
var) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'peek) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
ptr)

pokeVar' :: Name -> Exp -> Stmt
pokeVar' Name
ptr Exp
var = Exp -> Stmt
NoBindS
       (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'poke) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
ptr) Exp
var

bindPtr' :: Name -> Name -> Exp -> Stmt
bindPtr' Name
np Name
pp Exp
var = Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP Name
np)
       (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
next_ptr Exp
var
       where next_ptr :: Exp
next_ptr = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'next) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
pp