LslPlus-0.4.0: src/Language/Lsl/Internal/SerializationGenerator.hs
{-# OPTIONS_GHC -XTemplateHaskell -XFlexibleInstances -XTypeSynonymInstances
-XScopedTypeVariables -XOverlappingInstances
#-}
module Language.Lsl.Internal.SerializationGenerator where
import Language.Haskell.TH
import Control.Monad
import Data.Maybe
import qualified Control.Monad.State as State
import qualified Data.Map as M
import Language.Lsl.Internal.XmlCreate
import Language.Lsl.Internal.DOMProcessing
import Language.Lsl.Internal.DOMCombinators
import Data.Generics
import Data.Int
import Data.List
import Debug.Trace
import Text.XML.HaXml.Parse hiding (fst3,snd3,thd3)
import Text.XML.HaXml.Posn
class JavaRep a where
representative :: a
xmlSerialize :: Maybe String -> a -> String -> String
xmlDefaultTag :: a -> String
subElemDescriptor :: String -> ElementTester a
elemDescriptor :: ElementTester a
contentFinder :: String -> ContentFinder a
instance JavaRep Int where
representative = (0 :: Int)
xmlSerialize t i = emit (maybe "int" id t) [] [shows i]
xmlDefaultTag _ = "int"
subElemDescriptor tag = el tag id readableContent
elemDescriptor = el "int" id readableContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep Int32 where
representative = (0 :: Int32)
xmlSerialize t i = emit (maybe "int" id t) [] [shows i]
xmlDefaultTag _ = "int"
subElemDescriptor tag = el tag id readableContent
elemDescriptor = el "int" id readableContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep Int64 where
representative = (0 :: Int64)
xmlSerialize t i = emit (maybe "long" id t) [] [shows i]
xmlDefaultTag _ = "long"
subElemDescriptor tag = el tag id readableContent
elemDescriptor = el "int" id readableContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep Float where
representative = (0 :: Float)
xmlSerialize t i = emit (maybe "float" id t) [] [shows i]
xmlDefaultTag _ = "float"
subElemDescriptor tag = el tag id readableContent
elemDescriptor = el "float" id readableContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep Double where
representative = (0 :: Double)
xmlSerialize t i = emit (maybe "double" id t) [] [shows i]
xmlDefaultTag _ = "double"
subElemDescriptor tag = el tag id readableContent
elemDescriptor = el "double" id readableContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep Char where
representative = (' ')
xmlSerialize t c = emit (maybe "char" id t) [] [shows c]
xmlDefaultTag _ = "char"
subElemDescriptor tag = el tag id readableContent
elemDescriptor = el "char" id readableContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep Bool where
representative = True
xmlSerialize t b = emit (maybe "boolean" id t) [] [shows b]
xmlDefaultTag _ = "boolean"
subElemDescriptor tag = el tag id boolContent
elemDescriptor = el "boolean" id boolContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep String where
representative = ""
xmlSerialize t s = emit (maybe "string" id t) (maybe [] (const [("class","string")]) t) [showString s]
xmlDefaultTag _ = "string"
subElemDescriptor tag = el tag id simpleContent
elemDescriptor = el "string" id simpleContent
contentFinder tag = mustHaveElem $ subElemDescriptor tag
instance JavaRep a => JavaRep [a] where
representative = [ (representative :: a) ]
xmlSerialize t l =
emit (maybe (xmlDefaultTag (representative :: [a])) id t) (maybe [] (const [("class","linked-list")]) t)
(map (\ v -> xmlSerialize Nothing v) l)
xmlDefaultTag _ = "linked-list"
subElemDescriptor tag = el tag id (many $ elemDescriptor)
elemDescriptor = el (xmlDefaultTag (representative :: [a])) id (many $ elemDescriptor)
contentFinder tag = mustHaveElem $ subElemDescriptor tag
-- instance JavaRep a => JavaRep (Maybe a) where
-- representative = Just (representative :: a)
-- xmlSerialize t Nothing = id
-- xmlSerialize t (Just v) = xmlSerialize t v
-- xmlDefaultTag x = xmlDefaultTag (representative :: a)
-- subElemDescriptor tag = \ p e -> subElemDescriptor tag p e >>= return . Just
-- elemDescriptor = \ p e -> elemDescriptor p e >>= return . Just
-- contentFinder tag = (canHaveElem $ (\ p e -> subElemDescriptor tag p e))
deriveJavaRepTups l = mapM deriveJavaRepTup l >>= return . concat
deriveJavaRepTup n = do
let ns = show n
vs <- mapM newName (replicate n "v")
let ctx = mapM (appT javaRepCon . varT) vs
let typ = appT javaRepCon $ foldl appT (tupleT n) (map varT vs)
let representativeD =
valD (varP 'representative) (normalB $ tupE (replicate n (varE 'representative))) []
let nameE = stringE ("Tuple" ++ show n)
let repGenE = do
pkgVarName <- newName "pkg"
let pkgE = varE pkgVarName
let pkgP = varP pkgVarName
let tparms = intercalate "," (zipWith (\ x y -> x ++ show y) (replicate n "E") [1..n])
let fields = concatMap (\ i -> " public E" ++ show i ++ " el" ++ show i ++ ";\n") [1..n]
let clsE = [| "package " ++ $pkgE ++
$(stringE ( concat [
";\nimport com.thoughtworks.xstream.XStream;\n",
"public class Tuple", ns, "<", tparms, "> {\n", fields,
" public static void init(XStream xstream) {\n",
" xstream.alias(\"Tuple", ns, "\",Tuple", ns, ".class); //$NON-NLS-1$\n }\n",
"}\n"])) |]
lam1E pkgP ([|[($nameE,$clsE)]|])
let mkClause = do
tagName <- newName "tag"
vs <- mapM newName (replicate n "v")
let tagNmE = varE tagName
let tagE = [| maybe $nameE id $tagNmE |]
let attrsE = [| maybe [] (const [("class",$nameE)]) $tagNmE |]
let subElem i x = [e|xmlSerialize (Just $(stringE ("el" ++ show i))) $(varE x)|]
let lst = listE (zipWith subElem [1..n] vs)
let expr = [| emit $tagE $attrsE $lst |]
clause [varP tagName, return (TupP (map VarP vs))] (normalB $ expr) []
let xmlSerD = funD 'xmlSerialize [mkClause]
let stmts vs [] = return [noBindS [| return $(tupE (map varE vs))|] ]
stmts vs ((t,v):ts) = do
rest <- stmts vs ts
let stmt = bindS (varP v) [| contentFinder $(stringE t) |]
return (stmt : rest)
let fields vs terms = doE =<< (stmts vs terms)
let subElemDescriptorD = do
tagNm <- newName "tag"
vs <- mapM newName (replicate n "v")
let tagNmE = varE tagNm
let tags = map (("el" ++) . show) [1..n]
let terms = zip tags vs
let elE = [| el $tagNmE id $
comprises $(fields vs terms) |]
funD 'subElemDescriptor [clause [varP tagNm] (normalB elE) []]
let elemDescriptorD = do
vs <- mapM newName (replicate n "v")
let tags = map (("el" ++) . show) [1..n]
let terms = zip tags vs
let elE = [| el $nameE id (comprises $(fields vs terms)) |]
funD 'elemDescriptor [clause [] (normalB elE) []]
let contentFinderD = do
tagNm <- newName "tag"
funD 'contentFinder
[clause [(varP tagNm)] (normalB [| mustHaveElem (subElemDescriptor $(varE tagNm)) |]) [] ]
sequence [instanceD ctx typ [representativeD,xmlSerD,funD 'xmlDefaultTag [clause [wildP] (normalB nameE) []],
subElemDescriptorD, elemDescriptorD, contentFinderD],
valD (varP $ mkName ("jrep'" ++ "Tuple" ++ show n)) (normalB repGenE) []]
deriveJavaRep nm = if nm == ''[] then return [] else
do info <- reify nm
case info of
TyConI d -> deriveInstance d
_ -> fail $ ("can't generate serializer for specified name: " ++ show nm)
where
deriveInstance (DataD _ tnm vs cs _) = do
checkAllFields cs
sequence [instanceD ctx typ [representativeD,xmlSerializeD,dec1,
subElemDescriptorD,elemDescriptorD,contentFinderD],
valD (varP (mkName $ "jrep'" ++ (nameBase tnm))) (normalB representationE) []]
where ctx = mapM (appT javaRepCon . varT) vs
typ = appT javaRepCon $ foldl appT (conT tnm) (map varT vs)
representativeV = varE 'representative
mkRepresentative [] = [e|undefined|]
mkRepresentative (c:_) = getCInfo c >>=
\ (cnm,fts) -> foldl appE (conE cnm) (replicate (length fts) representativeV)
representativeD = firstDec [d|representative = $(mkRepresentative cs)|]
nameE = stringE (nameBase tnm)
representationE = do
pkgVarName <- newName "pkg"
let pkgE = varE pkgVarName
let pkgP = varP pkgVarName
let tparms = zipWith (\ v i -> (v, "E" ++ show i)) vs [1..]
let gparms = if null tparms then "" else "<" ++ intercalate "," (map snd tparms) ++ ">"
let baseclassBody =
"import com.thoughtworks.xstream.XStream;\n" ++
"public class " ++ (nameBase tnm ++ gparms) ++ "{\n" ++
" public static void init(XStream xstream) {\n" ++
" xstream.alias(\"" ++ (nameBase tnm) ++ "\"," ++
(nameBase tnm) ++ ".class); //$NON-NLS-1$\n }\n}\n"
let baseclass = [|"package " ++ $pkgE ++ ";\n" ++ $(stringE baseclassBody)|]
let mkSubClassExpr c = do
(cnm,fts) <- getCInfo c
let cname = (nameBase tnm) ++ "_" ++ (nameBase cnm)
let basenm = (nameBase tnm)
fts' <- forM fts $ (\ (nm,t) -> (deSyn [] t) >>= return . (,) nm)
let importList = hasList (map snd fts')
let fields =
flip concatMap fts' (\ (nm,t) ->
" public " ++ (repT tparms 0 t) ++
" " ++ nameBase nm ++ ";\n")
let classStr = "import com.thoughtworks.xstream.XStream;\n" ++
(if importList
then "import java.util.LinkedList;\n"
else "") ++
"public class " ++ cname ++ gparms ++
" extends " ++ basenm ++ gparms ++ "{\n" ++
fields ++
" public static void init(XStream xstream) {\n" ++
" xstream.alias(\"" ++ cname ++ "\"," ++ cname ++ ".class); //$NON-NLS-1$\n" ++
" }\n}\n"
let subclass = [|"package " ++ $pkgE ++ ";\n" ++ $(stringE classStr)|]
[e|($(nameE) ++ "_" ++ $(stringE $ nameBase cnm),$subclass)|]
let subClassExprs = map mkSubClassExpr cs
lam1E pkgP [e| ($nameE,$baseclass) : $(listE subClassExprs) |]
xmlSerializeD = funD (mkName "xmlSerialize") (map mkClause cs)
dec1 = funD (mkName "xmlDefaultTag") [clause [wildP] (normalB nameE) []]
computeVarInfo (nm,_) = newName "x" >>= return . ((,) nm)
mkClause c = do
(cnm,fts) <- getCInfo c
vis <- mapM computeVarInfo fts
tagVarName <- newName "tag"
let tagVarE = varE tagVarName
let cnmE = [| $(nameE) ++ "__" ++ $(stringE $ nameBase cnm)|]
let cnmEA = [| $(nameE) ++ "_" ++ $(stringE $ nameBase cnm)|]
let termf (fnm,vnm) = [|xmlSerialize (Just $(stringE $ nameBase fnm)) $(varE vnm)|]
let terms = map termf vis
let maybeE = [| maybe $cnmE id $tagVarE|]
let attrs = [| maybe [] (const [("class",$cnmEA)]) $tagVarE|]
let termsE = listE (if null terms then [] else [foldl1 (\ x y -> [| $x . $y |]) terms])
let exp = [| emit $maybeE $attrs $termsE |]
clause [varP tagVarName,conP cnm (map (varP . snd) vis)] (normalB exp) []
mkNoBindS cnm vs = [noBindS $ [| return $(foldl (appE) (conE cnm) (map varE $ reverse vs)) |]]
mkCnmE cnm = [| $(nameE) ++ "__" ++ $(stringE $ nameBase cnm)|]
mkCnmEA cnm = [| $(nameE) ++ "_" ++ $(stringE $ nameBase cnm)|]
stmts cnm vs [] = return (mkNoBindS cnm vs)
stmts cnm vs ((fnm,_):vis) = do
vn <- newName "v"
rest <- stmts cnm (vn:vs) vis
let stmt = bindS (varP vn) [| contentFinder $(stringE (nameBase fnm)) |]
return $ stmt : rest
fields cnm vis = doE =<< (stmts cnm [] vis)
contentE cnm vis = [| comprises $(fields cnm vis) |]
subElemDescriptorD = do
tagNm <- newName "tag"
let choices = listE (map (mkChoice tagNm) cs)
funD 'subElemDescriptor
[clause [(varP tagNm)] (normalB [| choice $choices |]) []]
where mkChoice tagNm c = do
(cnm,fts) <- getCInfo c
let tagNmE = varE tagNm
let cnmE = mkCnmEA cnm
vis <- mapM computeVarInfo fts
[| elWith $tagNmE (const id) (thisAttr "class" $cnmE) $(contentE cnm vis) |]
elemDescriptorD = do
funD 'elemDescriptor [clause [] (normalB [| choice $choices |]) []]
where choices = listE (map mkChoice cs)
mkChoice c = do
(cnm,fts) <- getCInfo c
let cnmE = mkCnmE cnm
vis <- mapM computeVarInfo fts
[| el $cnmE id $(contentE cnm vis) |]
contentFinderD = do
tagNm <- newName "tag"
funD 'contentFinder
[clause [(varP tagNm)]
(normalB [| mustHaveElem (subElemDescriptor $(varE tagNm)) |]) []]
deriveInstance dec = fail ("can't derive instance for: " ++ show (ppr dec) ++ " (" ++ show dec ++ ")")
getCInfo c = case c of
RecC cnm fvs -> return (cnm, map (\ (f,_,t) -> (f,t)) fvs)
NormalC cnm vs -> return (cnm, zipWith (\ i (_,t) -> (mkName $ "el" ++ show i, t)) [1..(length vs)] vs)
_ -> fail ("can't create java representation for " ++ show (ppr c))
checkField (_,t) | appliesVar t = fail ("can't generate serializer for type with type variables of kind other than '*'")
| otherwise = return ()
checkFields = mapM checkField
checkAllFields = mapM (\ c -> getCInfo c >>= \ (_,fts) -> checkFields fts)
appliesVar :: Type -> Bool
appliesVar = everything (||) (False `mkQ` chkApp)
where chkApp :: Type -> Bool
chkApp (AppT (VarT _) _) = True
chkApp t = False
cName :: Type -> [Name]
cName (ConT nm) = [nm]
cName _ = []
deriveRep nm = case nameBase nm of
-- '(':cs -> deriveJavaRepTups [(length cs)]
_ -> deriveJavaRep nm
predef nm = nm `elem` [''Char,''Int,''Float,''Double,''String,''[],''Bool {-,''Maybe -}]
subst args t@(VarT nm) = maybe t id (lookup nm args)
subst args (AppT t0 t1) = AppT (subst args t0) (subst args t1)
subst args t = t
firstDec :: Q [Dec] -> Q Dec
firstDec = liftM head
collectReps names = do
allNames <- foldM go M.empty names >>= return . catMaybes . M.elems
let allFuncs = listE $ map (varE . mkName . ("jrep'" ++)) allNames
[| \ pkg -> concatMap (\ f -> f pkg) $allFuncs |]
where go m n = case M.lookup n m of
Just _ -> return m
Nothing -> reify n >>= \ info -> case info of
PrimTyConI _ _ _ -> return (M.insert n Nothing m)
TyConI (DataD _ nm _ cs _) -> case nameBase nm of
'(':rest -> return (M.insert nm (Just $ "Tuple" ++ show (length rest)) m)
_ -> foldM collectCReps (M.insert nm (Just $ nameBase nm) m) cs
TyConI (NewtypeD _ nm _ c _) -> collectCReps (M.insert nm (Just $ nameBase nm) m) c
TyConI (TySynD _ _ t1) -> decomposeType (M.insert n Nothing m) t1
decomposeType m (VarT _) = return m
decomposeType m (TupleT n) = return m
decomposeType m ListT = return m
decomposeType m (ConT nm) | nm == ''Bool ||
nm == ''Int ||
nm == ''Char ||
nm == ''[] ||
-- nm == ''Maybe ||
nm == ''Float ||
nm == ''Double = return m
| otherwise = go m nm
decomposeType m (AppT x y) = decomposeType m x >>= flip decomposeType y
collectCReps m (NormalC _ sts) = foldM decomposeType m (map snd sts)
collectCReps m (RecC _ vsts) = foldM decomposeType m (map (\ (_,_,t) -> t) vsts)
collectCReps m (InfixC (_,t0) _ (_,t1)) = decomposeType m t0 >>= \ m' -> decomposeType m' t1
saveReps :: String -> [(String,String)] -> IO ()
saveReps pkg codeInfo = do
mapM_ ( \ (nm,txt) -> writeFile (nm ++ ".java") txt) codeInfo
writeFile "InitAll.java" $
"package " ++ pkg ++ ";\n" ++
"import com.thoughtworks.xstream.XStream;\n" ++
"public class InitAll {\n" ++
" public static void initAll(XStream xstream) {\n" ++
concatMap (\ (nm,_) -> " " ++ nm ++ ".init(xstream);\n") codeInfo ++
" }\n" ++
"}\n"
concatNM = '(++)
concatV = varE concatNM
specialNames = [(''[],"LinkedList"),
(''(,),"Tuple2"),
(''(,,),"Tuple3"),
(''(,,,),"Tuple4"),
(''(,,,,),"Tuple5"),
(''(,,,,,),"Tuple6"),
(''(,,,,,,),"Tuple7"),
(''Int,"Integer"),
(''Bool,"Boolean"),
(''Char,"Character"),
(''Int32,"Integer"),
(''Int64,"Long")]
deriveName nm = case lookup nm specialNames of
Nothing -> nameBase nm
Just s -> s
stringForms = [AppT ListT (ConT ''Char),AppT (ConT ''[]) (ConT ''Char)]
hasList :: [Type] -> Bool
hasList = foldl (\ x y -> x || hasList' y) False
where hasList' (VarT _) = False
hasList' (ConT nm) | nm == ''[] = True
| otherwise = False
hasList' form@(AppT x y) | form `elem` stringForms = False
| otherwise = hasList' x || hasList' y
hasList' _ = False
repT :: [(Name,String)] -> Int -> Type -> String
repT dict _ (ConT nm) = deriveName nm
repT dict _ (VarT nm) = maybe "?" id (lookup nm dict)
repT dict mult (AppT (ConT nm) y) | nm == ''[] && y == (ConT ''Char) = "String"
-- | nm == ''Maybe = repT dict mult y
| otherwise = (deriveName nm) ++ "<" ++ repT dict 0 y ++ (if mult /= 0 then "," else ">")
repT dict mult (AppT ListT y) = "LinkedList" ++ "<" ++ repT dict 0 y ++ ">" ++ (if mult == 0 then ">" else ",")
repT dict mult (AppT x y) = repT dict (mult + 1) x ++ repT dict 0 y ++ if mult == 0 then ">" else ","
deSyn :: [Type] -> Type -> Q Type
deSyn targs t@(ConT nm) = reify nm >>= \ info -> case info of
PrimTyConI _ _ _ -> return (foldl AppT t targs)
TyConI (DataD _ _ _ _ _) -> return (foldl AppT t targs)
TyConI (NewtypeD _ _ _ _ _) -> return (foldl AppT t targs)
TyConI (TySynD _ params t1) -> return (foldl AppT (subst t1) targs')
where targs' = drop (length params) targs
substs = zip params targs
subst t@(VarT nm) = maybe t id (lookup nm substs)
subst (AppT x y) = (AppT (subst x) (subst y))
subst t = t
other -> fail ("can't handle " ++ show (ppr other))
deSyn targs (AppT x y) = do
arg <- deSyn [] y
deSyn (arg:targs) x
deSyn targs t@(VarT nm) = return $ foldl AppT t targs
javaRepCon = conT ''JavaRep