{-# LANGUAGE TemplateHaskell, TypeFamilies, CPP #-}
module Language.KansasLava.Rep.TH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax as S
import Language.KansasLava.Types as KLT
import Language.KansasLava.Rep.Class
repIntegral :: Name -> KLT.Type -> Q [Dec]
repIntegral tyName tyType = do
x <- newName "x"
sequence [ instanceD
(return [])
(appT (conT ''Rep) (conT tyName))
[ tySynInstD ''W (tySynEqn [conT tyName] (conT (mkName xSize)))
, dataInstD (return [])
''X [conT tyName] Nothing
[ normalC xConsName
[ bangType (bang noSourceUnpackedness noSourceStrictness)
(appT (conT ''Maybe) (conT tyName)) ]
]
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(return [])
#endif
, funD 'optX
[clause [varP x]
(normalB
(appE (conE xConsName)
(varE x)))
[]
]
, funD 'unX
[clause [conP xConsName [varP x]]
(normalB
(varE x))
[]
]
, funD 'repType
[clause [wildP]
(normalB [| tyType |])
[]
]
, valD (varP 'toRep)
(normalB (varE 'toRepFromIntegral))
[]
, valD (varP 'fromRep)
(normalB (varE 'fromRepToIntegral))
[]
, valD (varP 'showRep)
(normalB (varE 'showRepDefault))
[]
]
]
where
strName = nameBase tyName
xConsName = mkName ("X" ++ strName)
xSize = "X" ++ show (typeWidth tyType)
repBitRep :: Name -> Int -> Q [Dec]
repBitRep tyName width = do
x <- newName "x"
sequence [ instanceD
(return [])
(appT (conT ''Rep) (conT tyName))
[ tySynInstD ''W (tySynEqn [conT tyName] (conT (mkName xSize)))
, dataInstD (return [])
''X [conT tyName] Nothing
[ normalC xConsName
[ bangType (bang noSourceUnpackedness noSourceStrictness)
(appT (conT ''Maybe) (conT tyName)) ]
]
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(return [])
#endif
, funD 'optX
[clause [varP x]
(normalB
(appE (conE xConsName)
(varE x)))
[]
]
, funD 'unX
[clause [conP xConsName [varP x]]
(normalB
(varE x))
[]
]
, funD 'repType
[clause [wildP]
(normalB (appE (conE 'V)
(litE (integerL (fromIntegral width)))
))
[]
]
, valD (varP 'toRep)
(normalB (varE 'bitRepToRep))
[]
, valD (varP 'fromRep)
(normalB (varE 'bitRepFromRep))
[]
, valD (varP 'showRep)
(normalB (varE 'showRepDefault))
[]
]
]
where
strName = nameBase tyName
xConsName = mkName ("X" ++ strName)
xSize = "X" ++ show width
instance S.Lift KLT.Type where
lift (S n) = conE 'S `appE` (lift n)
lift (U n) = conE 'U `appE` (lift n)
lift other = error ("lift " ++ show other)