module QuoteBinaryStructure (
binary,
Field(..),
Binary(..),
fii,
tii,
times
) where
import Prelude hiding (sequence)
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Quote
import Data.Traversable hiding (mapM)
import Data.Either
import Data.Maybe
import qualified Data.ByteString.Lazy.Char8 as BSLC
import ParseBinaryStructure
binary :: QuasiQuoter
binary = QuasiQuoter {
quoteExp = undefined,
quotePat = undefined,
quoteType = undefined,
quoteDec = mkHaskellTree . parseBinaryStructure
}
mkHaskellTree :: BinaryStructure -> DecsQ
mkHaskellTree bs = do
d <- mkData bsn body
i <- mkInst bsn argn typ body
return $ d ++ [i]
where
bsn = binaryStructureName bs
argn = binaryStructureArgName bs
typ = binaryStructureArgType bs
body = binaryStructureBody bs
mkInst :: String -> String -> TypeQ -> [BinaryStructureItem] -> DecQ
mkInst bsn argn typ body =
instanceD (cxt []) (appT (conT ''Field) (conT $ mkName bsn)) [
tySynInstD ''FieldArgument [conT $ mkName bsn] typ,
reading "fromBinary" bsn argn body,
writing "toBinary" argn body
]
writing :: String -> String -> [BinaryStructureItem] -> DecQ
writing name argn body = do
arg <- newName "arg"
bs <- newName "bs"
let run = appE (varE 'cc) $ listE $ map
(\bsi -> writeField bs arg argn (bytesOf bsi) (valueOf bsi)) body
funD (mkName name)
[clause [varP arg, varP bs] (normalB run) []]
writeField :: Name -> Name -> String -> Expression -> Either (Either Int String) String -> ExpQ
writeField bs arg argn size (Left (Left n)) =
appsE [fiend', expression bs arg argn size, sigE (litE $ integerL $ fromIntegral n)
(conT ''Int)]
where
fiend' = varE 'toBinary
writeField _ _ _ _ (Left (Right s)) =
appsE [varE 'fs, litE $ stringL s]
writeField bs arg argn bytes (Right v) =
fieldValueToStr bs arg argn bytes False $ getField bs v
fieldValueToStr :: Name -> Name -> String -> Expression -> Bool -> ExpQ -> ExpQ
fieldValueToStr bs arg argn size False =
appE $ appE (varE 'toBinary) (expression bs arg argn size)
fieldValueToStr bs arg argn size True = \val ->
appE (varE 'cc) $ appsE [
varE 'map, appE (varE 'toBinary) (expression bs arg argn size), val]
reading :: String -> String -> String -> [BinaryStructureItem] -> DecQ
reading name bsn argn body = do
arg <- newName "arg"
cs <- newName "cs"
ret <- newName "ret"
funD (mkName name) [clause [varP arg, varP cs]
(normalB $ mkLetRec ret $ mkBody bsn arg argn body cs) []]
mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ
mkLetRec n f = do
rest <- newName "rest"
letE [valD (tupP [varP n, varP rest]) (normalB $ f n) []] $
tupE [varE n, varE rest]
mkBody :: String -> Name -> String -> [BinaryStructureItem] -> Name -> Name -> ExpQ
mkBody bsn arg argn body cs ret = do
namePairs <- for names $ \n -> return . (n ,) =<< newName "tmp"
(defs, rest) <- gather cs body $ mkDef namePairs
letE (map return defs) $ tupE
[recConE (mkName bsn) (map toPair2 namePairs), varE rest]
where
names = rights $ map valueOf body
toPair2 (n, nn) = return (mkName n, VarE nn)
mkDef :: [(String, Name)] -> BinaryStructureItem -> Name -> Q ([Dec], Name)
mkDef np item cs'
| Left (Left val) <- valueOf item = do
cs'' <- newName "cs"
let t = dropE' n $ varE cs'
p = val `equal` appE (varE 'fst)
(appE (appE (varE 'fromBinary) arg') $
takeE' n $ varE cs')
e = [e| error "bad value" |]
d <- valD (varP cs'') (normalB $ condE p t e) []
return ([d], cs'')
| Left (Right val) <- valueOf item = do
cs'' <- newName "cs"
let t = dropE' n $ varE cs'
let p = val `equal'` takeE' n (varE cs')
let e = [e| error "bad value" |]
d <- valD (varP cs'') (normalB $ condE p t e) []
return ([d], cs'')
| Right var <- valueOf item = do
cs'' <- newName "cs"
def <- valD (tupP [varP $ fromJust $ lookup var np, varP cs''])
(normalB $ appE (appE (varE 'fromBinary) arg') $ varE cs') []
return ([def], cs'')
| otherwise = error "bad"
where
n = expression ret arg argn $ bytesOf item
arg' = expression ret arg argn $ bytesOf item
getField :: Name -> String -> ExpQ
getField bs v = appE (varE $ mkName v) (varE bs)
equal :: Int -> ExpQ -> ExpQ
equal x y = infixE (Just $ sigE (litE $ integerL $ fromIntegral x) (conT ''Int))
(varE '(==)) (Just y)
equal' :: String -> ExpQ -> ExpQ
equal' x y = infixE (Just $ litE $ stringL x) (varE '(==)) (Just y)
takeE' :: ExpQ -> ExpQ -> ExpQ
takeE' n xs =
appE (varE 'BSLC.unpack) $ appE (varE 'fst) $ appsE [varE 'getBytes, n, xs]
dropE' :: ExpQ -> ExpQ -> ExpQ
dropE' n xs = appsE [varE 'dp, n, xs]
gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m ([b], s)
gather s [] _ = return ([], s)
gather s (x : xs) f = do
(ys, s') <- f x s
(zs, s'') <- gather s' xs f
return (ys ++ zs, s'')
mkInstance :: String -> DecQ
mkInstance name =
instanceD (cxt []) (appT (conT ''Field) (conT $ mkName name)) [
valD (varP $ 'toBinary)
(normalB $ varE $ mkName $ "write" ++ name) [],
valD (varP $ 'fromBinary)
(normalB $ varE $ mkName $ "read" ++ name) []
]
mkData :: String -> [BinaryStructureItem] -> DecsQ
mkData bsn body = do
d <- dataD (cxt []) name [] [con] [''Show]
_ <- mkInstance bsn
return [d]
where
name = mkName bsn
con = recC (mkName bsn) vsts
vsts = flip map (filter isRight body) $ \item ->
varStrictType (mkName $ fromRight $ valueOf item) $
strictType notStrict $ mkType False $ typeOf item
isRight item
| Right _ <- valueOf item = True
| otherwise = False
mkType :: Bool -> TypeQ -> TypeQ
mkType True t = appT listT $ mkType False t
mkType False typ = typ
fromRight :: Either a b -> b
fromRight = either (error "not Right") id
times :: Int -> (s -> (ret, s)) -> s -> ([ret], s)
times 0 _ s = ([], s)
times n f s = let
(ret, rest) = f s
(rets, rest') = times (n 1) f rest in
(ret : rets, rest')