{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module TH.Derive.Storable
( makeStorableInst
) where
import Control.Applicative
import Control.Monad
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.Word
import Foreign.Ptr
import Foreign.Storable
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Prelude
import TH.Derive.Internal
import TH.ReifySimple
import TH.Utilities
instance Deriver (Storable a) where
runDeriver :: Proxy (Storable a) -> Cxt -> Type -> Q [Dec]
runDeriver Proxy (Storable a)
_ = Cxt -> Type -> Q [Dec]
makeStorableInst
makeStorableInst :: Cxt -> Type -> Q [Dec]
makeStorableInst :: Cxt -> Type -> Q [Dec]
makeStorableInst Cxt
preds Type
ty = do
Type
argTy <- Name -> Type -> Q Type
expectTyCon1 ''Storable Type
ty
DataType
dt <- Type -> Q DataType
reifyDataTypeSubstituted Type
argTy
Cxt -> Type -> [DataCon] -> Q [Dec]
makeStorableImpl Cxt
preds Type
ty (DataType -> [DataCon]
dtCons DataType
dt)
makeStorableImpl :: Cxt -> Type -> [DataCon] -> Q [Dec]
makeStorableImpl :: Cxt -> Type -> [DataCon] -> Q [Dec]
makeStorableImpl Cxt
preds Type
headTy [DataCon]
cons = do
Exp
alignmentMethod <- [| 1 |]
Exp
sizeOfMethod <- Q Exp
sizeExpr
Exp
peekMethod <- Q Exp
peekExpr
Exp
pokeMethod <- Q Exp
pokeExpr
let methods :: [Dec]
methods =
[ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"alignment") [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
alignmentMethod) []]
, Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"sizeOf") [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
sizeOfMethod) []]
, Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"peek") [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
ptrName] (Exp -> Body
NormalB Exp
peekMethod) []]
, Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"poke") [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
ptrName, Name -> Pat
VarP Name
valName] (Exp -> Body
NormalB Exp
pokeMethod) []]
]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
plainInstanceD Cxt
preds Type
headTy [Dec]
methods]
where
(Name
tagType, Int
_, Int
tagSize) =
(Name, Int, Int) -> Maybe (Name, Int, Int) -> (Name, Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Name, Int, Int)
forall a. HasCallStack => String -> a
error String
"Too many constructors") (Maybe (Name, Int, Int) -> (Name, Int, Int))
-> Maybe (Name, Int, Int) -> (Name, Int, Int)
forall a b. (a -> b) -> a -> b
$
((Name, Int, Int) -> Bool)
-> [(Name, Int, Int)] -> Maybe (Name, Int, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Name
_, Int
maxN, Int
_) -> Int
maxN Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [DataCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
cons) [(Name, Int, Int)]
tagTypes
tagTypes :: [(Name, Int, Int)]
tagTypes :: [(Name, Int, Int)]
tagTypes =
[ ('(), Int
1, Int
0)
, (''Word8, Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8), Int
1)
, (''Word16, Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16), Int
2)
, (''Word32, Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32), Int
4)
, (''Word64, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64), Int
8)
]
valName :: Name
valName = String -> Name
mkName String
"val"
tagName :: Name
tagName = String -> Name
mkName String
"tag"
ptrName :: Name
ptrName = String -> Name
mkName String
"ptr"
fName :: a -> Name
fName a
ix = String -> Name
mkName (String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
ix)
ptrExpr :: Q Exp
ptrExpr = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
ptrName
sizeExpr :: Q Exp
sizeExpr = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'const) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'maximum) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'sum) ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Type -> Q Exp
forall {m :: * -> *}. Quote m => Type -> m Exp
sizeOfExpr Type
ty | (Maybe Name
_, Type
ty) <- [(Maybe Name, Type)]
fields])
| (DataCon Name
_ [Name]
_ Cxt
_ [(Maybe Name, Type)]
fields) <- [DataCon]
cons
]
peekExpr :: Q Exp
peekExpr = case [DataCon]
cons of
[] -> [| error ("Attempting to peek type with no constructors (" ++ $(lift (pprint headTy)) ++ ")") |]
[DataCon
con] -> DataCon -> Q Exp
peekCon DataCon
con
[DataCon]
_ -> [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE
[ Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tagName) [| peek (castPtr $(ptrExpr)) |]
, Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tagName) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tagType))
(((Integer, DataCon) -> Q Match)
-> [(Integer, DataCon)] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, DataCon) -> Q Match
peekMatch ([Integer] -> [DataCon] -> [(Integer, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [DataCon]
cons) [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Match
peekErr]))
]
peekMatch :: (Integer, DataCon) -> Q Match
peekMatch (Integer
ix, DataCon
con) = Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Integer -> Lit
IntegerL Integer
ix)) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (DataCon -> Q Exp
peekCon DataCon
con)) []
peekErr :: Q Match
peekErr = Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| error ("Found invalid tag while peeking (" ++ $(lift (pprint headTy)) ++ ")") |]) []
peekCon :: DataCon -> Q Exp
peekCon (DataCon Name
cname [Name]
_ Cxt
_ [(Maybe Name, Type)]
fields) =
[Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE ([(Maybe Name, Type)] -> [Q Dec]
forall {m :: * -> *} {a}. Quote m => [(a, Type)] -> [m Dec]
offsetDecls [(Maybe Name, Type)]
fields) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
case [(Maybe Name, Type)]
fields of
[] -> [| pure $(conE cname) |]
((Maybe Name, Type)
_:[(Maybe Name, Type)]
fields') ->
(Q Exp -> (Int, (Maybe Name, Type)) -> Q Exp)
-> Q Exp -> [(Int, (Maybe Name, Type))] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
acc (Int
ix, (Maybe Name, Type)
_) -> [| $(acc) <*> $(peekOffset ix) |] )
[| $(conE cname) <$> $(peekOffset 0) |]
([Int] -> [(Maybe Name, Type)] -> [(Int, (Maybe Name, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [(Maybe Name, Type)]
fields')
peekOffset :: Int -> Q Exp
peekOffset Int
ix = [| peek (castPtr (plusPtr $(ptrExpr) $(varE (offset ix)))) |]
pokeExpr :: Q Exp
pokeExpr = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valName) (((Int, DataCon) -> Q Match) -> [(Int, DataCon)] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (Int, DataCon) -> Q Match
pokeMatch ([Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [DataCon]
cons))
pokeMatch :: (Int, DataCon) -> MatchQ
pokeMatch :: (Int, DataCon) -> Q Match
pokeMatch (Int
ixcon, DataCon Name
cname [Name]
_ Cxt
_ [(Maybe Name, Type)]
fields) =
Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cname ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ((Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
forall {a}. Show a => a -> Name
fName [Int]
ixs)))
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (case [Q Stmt]
tagPokes [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt]
offsetLet [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt]
fieldPokes of
[] -> [|return ()|]
[Q Stmt]
stmts -> [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [Q Stmt]
stmts))
[]
where
tagPokes :: [Q Stmt]
tagPokes = case [DataCon]
cons of
(DataCon
_:DataCon
_:[DataCon]
_) -> [Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS [| poke (castPtr $(ptrExpr)) (ixcon :: $(conT tagType)) |]]
[DataCon]
_ -> []
offsetLet :: [Q Stmt]
offsetLet
| [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ixs = []
| Bool
otherwise = [[Q Dec] -> Q Stmt
forall (m :: * -> *). Quote m => [m Dec] -> m Stmt
letS ([(Maybe Name, Type)] -> [Q Dec]
forall {m :: * -> *} {a}. Quote m => [(a, Type)] -> [m Dec]
offsetDecls [(Maybe Name, Type)]
fields)]
fieldPokes :: [Q Stmt]
fieldPokes = (Int -> Q Stmt) -> [Int] -> [Q Stmt]
forall a b. (a -> b) -> [a] -> [b]
map (Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> Q Stmt) -> (Int -> Q Exp) -> Int -> Q Stmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Q Exp
pokeField) [Int]
ixs
ixs :: [Int]
ixs = ((Int, (Maybe Name, Type)) -> Int)
-> [(Int, (Maybe Name, Type))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (Maybe Name, Type)) -> Int
forall a b. (a, b) -> a
fst ([Int] -> [(Maybe Name, Type)] -> [(Int, (Maybe Name, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Maybe Name, Type)]
fields)
pokeField :: Int -> Q Exp
pokeField Int
ix = [| poke (castPtr (plusPtr $(ptrExpr)
$(varE (offset ix))))
$(varE (fName ix)) |]
offsetDecls :: [(a, Type)] -> [m Dec]
offsetDecls [(a, Type)]
fields =
[m Dec] -> [m Dec]
forall a. [a] -> [a]
init ([m Dec] -> [m Dec]) -> [m Dec] -> [m Dec]
forall a b. (a -> b) -> a -> b
$
((Int, m Exp) -> m Dec) -> [(Int, m Exp)] -> [m Dec]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
ix, m Exp
expr) -> m Pat -> m Body -> [m Dec] -> m Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Int -> Name
offset Int
ix)) (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
expr) []) ([(Int, m Exp)] -> [m Dec]) -> [(Int, m Exp)] -> [m Dec]
forall a b. (a -> b) -> a -> b
$
((Int
0, [| tagSize |]) (Int, m Exp) -> [(Int, m Exp)] -> [(Int, m Exp)]
forall a. a -> [a] -> [a]
:) ([(Int, m Exp)] -> [(Int, m Exp)])
-> [(Int, m Exp)] -> [(Int, m Exp)]
forall a b. (a -> b) -> a -> b
$
((Int, (a, Type)) -> (Int, m Exp))
-> [(Int, (a, Type))] -> [(Int, m Exp)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
ix, (a
_, Type
ty)) -> (Int
ix, Int -> Type -> m Exp
forall {m :: * -> *}. Quote m => Int -> Type -> m Exp
offsetExpr Int
ix Type
ty)) ([(Int, (a, Type))] -> [(Int, m Exp)])
-> [(Int, (a, Type))] -> [(Int, m Exp)]
forall a b. (a -> b) -> a -> b
$
[Int] -> [(a, Type)] -> [(Int, (a, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [(a, Type)]
fields
where
offsetExpr :: Int -> Type -> m Exp
offsetExpr Int
ix Type
ty = [| $(sizeOfExpr ty) + $(varE (offset (ix - 1))) |]
sizeOfExpr :: Type -> m Exp
sizeOfExpr Type
ty = [| $(varE 'sizeOf) (error "sizeOf evaluated its argument" :: $(return ty)) |]
offset :: Int -> Name
offset Int
ix = String -> Name
mkName (String
"offset" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
ix :: Int))