module Ivory.BitData.Quote (bitdata) where
import Control.Monad (MonadPlus, liftM, msum, when, unless, mzero)
import Data.Foldable (find, foldl')
import Data.List (sort)
import Data.Maybe (mapMaybe)
import Data.Traversable (mapAccumL)
import MonadLib (ChoiceT, findOne, lift)
import Text.Parsec (parse, setPosition, getPosition,
setSourceLine, setSourceColumn)
import Text.Parsec.String (Parser)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Ivory.Language ((.|), iShiftL, safeCast)
import qualified Ivory.Language as I
import Ivory.BitData.AST
import Ivory.BitData.Parser (parseBitLiteral, parseDefs)
import qualified Ivory.BitData.Bits as B
import qualified Ivory.BitData.BitData as B
import qualified Ivory.BitData.Array as B
bitdata :: QuasiQuoter
bitdata = QuasiQuoter
{ quoteDec = bitdataQuoteDec
, quoteExp = bitdataQuoteExp
, quotePat = error "quotePat not implemented"
, quoteType = error "quoteType not implemented"
}
qParse :: Parser a -> String -> Q a
qParse parser str = do
loc <- location
case parse (body loc) (loc_filename loc) str of
Right defs -> return defs
Left err -> fail (show err)
where
body loc = do
pos <- getPosition
let (line, col) = loc_start loc
setPosition (setSourceLine (setSourceColumn pos col) line)
parser
concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = liftM concat (mapM f xs)
anyOf :: MonadPlus m => [a] -> m a
anyOf = msum . map return
bitdataQuoteExp :: String -> Q Exp
bitdataQuoteExp str = do
lit <- qParse parseBitLiteral str
case lit of
BitLitKnown len val ->
let tylen = litT (numTyLit (fromIntegral len)) in
[| B.unsafeIntToBits (val :: Int) :: B.Bits $tylen |]
BitLitUnknown val ->
[| B.repToBits (fromIntegral (val :: Int)) |]
bitdataQuoteDec :: String -> Q [Dec]
bitdataQuoteDec str = concatMapM mkDef =<< parseDefsQ str
parseDefsQ :: String -> Q [Def]
parseDefsQ = qParse parseDefs
convertType :: BitTy -> Q Type
convertType (TyCon s) = do
m <- lookupTypeName s
case m of
Just ty -> return $ ConT ty
Nothing -> fail $ "undefined type: " ++ s
convertType (TyNat n) = return $ LitT $ NumTyLit n
convertType (TyApp t1 t2) = do
t1' <- convertType t1
t2' <- convertType t2
return $ AppT t1' t2'
getTyBits :: Type -> ChoiceT Q Int
getTyBits ty =
case ty of
ConT name
| name == ''B.Bit -> return 1
| otherwise -> tyInsts ''B.BitType ty >>= decBits
AppT (AppT (ConT name) (LitT (NumTyLit n))) ty2
| name == ''B.BitArray -> do
m <- lift $ tyBits ty2
return (fromIntegral n * m)
AppT (ConT name) (LitT (NumTyLit n))
| name == ''B.Bits -> return $ fromIntegral n
| otherwise -> mzero
_ -> mzero
where
tyInsts name t = lift (reifyInstances name [t]) >>= anyOf
decBits (TySynInstD _ _ t) = getTyBits t
decBits _ = mzero
tyBits :: Type -> Q Int
tyBits ty = do
r <- findOne (getTyBits ty)
case r of
Just x -> return x
Nothing -> fail "invalid bit value base type"
getArrayType :: Type -> Maybe (Int, Type)
getArrayType (AppT (AppT (ConT name) (LitT (NumTyLit n))) ty)
| name == ''B.BitArray = Just (fromIntegral n, ty)
getArrayType _ = Nothing
data THField = THField
{ thFieldName :: Name
, thFieldType :: Type
, thFieldLen :: Int
} deriving Show
annotateField :: Field -> Q THField
annotateField (Field n t) = do
ty <- convertType t
len <- tyBits ty
return $ THField (mkName n) ty len
data THLayoutItem =
THLayoutConst
{ thLayoutValue :: BitLiteral
, thLayoutPos :: Int }
| THLayoutField
{ thLayoutField :: THField
, thLayoutPos :: Int }
deriving Show
type THLayout = [THLayoutItem]
defaultLayout :: Int -> [THField] -> THLayout
defaultLayout len [] = [THLayoutConst (BitLitKnown len 0) 0]
defaultLayout _ fs = snd $ mapAccumL go 0 fs
where
go pos f
| thFieldName f == mkName "_"
, len <- thFieldLen f
= (pos + len, THLayoutConst (BitLitKnown len 0) pos)
| otherwise
= (pos + thFieldLen f, THLayoutField f pos)
annotateLayout :: Int -> Layout -> [THField] -> THLayout
annotateLayout len [] fs = defaultLayout len (reverse fs)
annotateLayout _ ls fs = snd $ mapAccumL go 0 (reverse ls)
where
go pos l =
case l of
LayoutConst lit@(BitLitKnown len _)
-> (pos + len, THLayoutConst lit pos)
LayoutField name
| Just f <- find ((== mkName name) . thFieldName) fs
-> (pos + thFieldLen f, THLayoutField f pos)
_ -> error "invalid bitdata layout"
layoutItemSize :: [THField] -> LayoutItem -> Int
layoutItemSize _ (LayoutConst (BitLitKnown len _)) = len
layoutItemSize _ (LayoutConst (BitLitUnknown _)) = 0
layoutItemSize fs (LayoutField name) =
case find ((== (mkName name)) . thFieldName) fs of
Just field -> fromIntegral (thFieldLen field)
Nothing -> error "undefined field"
layoutSize :: [THField] -> Layout -> Int
layoutSize fs ls = sum (map (layoutItemSize fs) ls)
hasUnknownSize :: LayoutItem -> Bool
hasUnknownSize (LayoutConst (BitLitUnknown _)) = True
hasUnknownSize _ = False
updateSizeL :: Int -> LayoutItem -> LayoutItem
updateSizeL size l =
case l of
LayoutConst (BitLitUnknown x) -> LayoutConst (BitLitKnown size x)
_ -> l
updateFirstL :: Int -> Layout -> Layout
updateFirstL _ [] = []
updateFirstL size (l:ls)
| hasUnknownSize l = updateSizeL size l : ls
| otherwise = l : updateFirstL size ls
updateLiterals :: Int -> [THField] -> Layout -> Q Layout
updateLiterals defLen fs ls = do
let slop = defLen layoutSize fs ls
ls' = updateFirstL slop ls
when (any hasUnknownSize ls') $
fail "multiple unknown size bit fields"
return ls'
foldLayout :: (b -> THLayoutItem -> b) -> b -> THConstr -> b
foldLayout f z c = foldl' f z (thConstrLayout c)
mapLayout :: (THLayoutItem -> a) -> THConstr -> [a]
mapLayout f c = map f (thConstrLayout c)
thLayoutItemSize :: THLayoutItem -> Int
thLayoutItemSize (THLayoutConst (BitLitKnown len _) _) = len
thLayoutItemSize (THLayoutConst _ _) = error "invalid layout item"
thLayoutItemSize (THLayoutField f _) = thFieldLen f
thLayoutSize :: THLayout -> Int
thLayoutSize l = sum $ map thLayoutItemSize l
data THConstr = THConstr
{ thConstrName :: Name
, thConstrFields :: [THField]
, thConstrLayout :: THLayout
} deriving Show
constrFieldNames :: THConstr -> [Name]
constrFieldNames c = map thFieldName (thConstrFields c)
annotateConstr :: Int -> Constr -> Q THConstr
annotateConstr len (Constr n fs ls) = do
fs' <- mapM annotateField fs
ls' <- updateLiterals len fs' ls
return $ THConstr (mkName n) fs' (annotateLayout len ls' fs')
data THDef = THDef
{ thDefName :: Name
, thDefType :: Type
, thDefConstrs :: [THConstr]
, thDefLen :: Int
} deriving Show
annotateDef :: Def -> Q THDef
annotateDef (Def n t cs) = do
ty <- convertType t
len <- tyBits ty
cs' <- mapM (annotateConstr len) cs
return $ THDef (mkName n) ty cs' len
checkDef :: THDef -> Q ()
checkDef def = do
mapM_ (checkConstr def) (thDefConstrs def)
checkConstr :: THDef -> THConstr -> Q ()
checkConstr def constr = do
checkLayout def constr (thConstrLayout constr)
layoutFieldNames :: THLayout -> [Name]
layoutFieldNames = mapMaybe go
where go (THLayoutField f _) = Just $ thFieldName f
go _ = Nothing
checkLayout :: THDef -> THConstr -> THLayout -> Q ()
checkLayout def c l = do
let cnames = filter (/= (mkName "_")) (constrFieldNames c)
lnames = filter (/= (mkName "_")) (layoutFieldNames l)
unless (sort cnames == sort lnames) $
fail "layout does not mention each field exactly once"
when (thLayoutSize l > thDefLen def) $
fail "constructor layout is too large"
mkDef :: Def -> Q [Dec]
mkDef d = do
def <- annotateDef d
checkDef def
sequence $ concat
[ mkDefNewtype def
, mkDefInstance def
, concatMap (mkConstr def) (thDefConstrs def)
, mkArraySizeTypeInsts def
]
mkDefNewtype :: THDef -> [DecQ]
mkDefNewtype def = [newtypeD (cxt []) name []
(normalC name [strictType notStrict (return ty)])
[''I.IvoryType, ''I.IvoryVar, ''I.IvoryExpr, ''I.IvoryEq]]
where
name = thDefName def
ty = thDefType def
mkDefInstance :: THDef -> [DecQ]
mkDefInstance def = [instanceD (cxt []) instTy body]
where
name = thDefName def
baseTy = thDefType def
instTy = [t| B.BitData $(conT (thDefName def)) |]
body = [tyDef, toFun, fromFun]
tyDef = tySynInstD ''B.BitType [conT name] (return baseTy)
x = mkName "x"
toFun = funD 'B.toBits [clause [conP name [varP x]]
(normalB (varE x)) []]
fromFun = valD (varP 'B.fromBits) (normalB (conE name)) []
mkArraySizeTypeInsts :: THDef -> [DecQ]
mkArraySizeTypeInsts def =
concatMap (uncurry mkArraySizeTypeInst)
(mapMaybe getArrayType
(concatMap constrFieldTypes (thDefConstrs def)))
mkArraySizeTypeInst :: Int -> Type -> [DecQ]
mkArraySizeTypeInst n ty = [tySynInstD ''B.ArraySize args size]
where
size = tyBits ty >>= litT . numTyLit . fromIntegral . (* n)
args = [litT (numTyLit (fromIntegral n)), return ty]
constrFieldTypes :: THConstr -> [Type]
constrFieldTypes c = map thFieldType fields
where fields = filter ((/= (mkName "_")) . thFieldName) (thConstrFields c)
mkConstrType :: THDef -> THConstr -> Type
mkConstrType d c = foldr (AppT . AppT ArrowT) (ConT (thDefName d)) fields
where fields = constrFieldTypes c
argName :: Int -> Name
argName n = mkName ("arg" ++ show n)
mkConstrArgs :: THConstr -> [PatQ]
mkConstrArgs c = zipWith f [0..] names
where names = filter (/= (mkName "_")) (constrFieldNames c)
f x _ = varP (argName x)
constrBodyExpr :: (Int, ExpQ) -> THLayoutItem -> (Int, ExpQ)
constrBodyExpr (n, expr) l =
case l of
THLayoutField _ pos ->
(n + 1, infixApp expr (varE '(.|))
(infixApp (appE (varE 'safeCast) (appE (varE 'B.toRep)
(varE (argName n))))
(varE 'iShiftL) (litE (integerL
(fromIntegral pos)))))
THLayoutConst val pos
| bitLitVal val /= 0 ->
(n, infixApp expr (varE '(.|))
(infixApp (litE (integerL (fromIntegral (bitLitVal val))))
(varE 'iShiftL) (litE (integerL (fromIntegral pos)))))
| otherwise -> (n, expr)
mkConstr :: THDef -> THConstr -> [DecQ]
mkConstr def constr = [sig, fun] ++ mkConstrFields def constr
where
cname = thConstrName constr
sig = sigD cname (return (mkConstrType def constr))
args = mkConstrArgs constr
zexpr = litE (integerL 0)
expr = snd (foldLayout constrBodyExpr (0, zexpr) constr)
body = normalB (appE (varE 'B.unsafeFromRep) expr)
fun = funD cname [clause args body []]
mkConstrFields :: THDef -> THConstr -> [DecQ]
mkConstrFields def c = concat $ mapLayout (mkField def) c
mkField :: THDef -> THLayoutItem -> [DecQ]
mkField def l@(THLayoutField f pos) =
[ sigD name ty
, valD (varP name) (normalB [| B.BitDataField $posE $lenE |]) []]
where
name = thFieldName f
lenE = litE (integerL (fromIntegral (thFieldLen f)))
posE = litE (integerL (fromIntegral pos))
fty = return (thFieldType f)
ty = [t| B.BitDataField $(conT (thDefName def)) $fty |]
mkField _ _ = []