module Data.Derive.DSL.SYB(dslSYB) where
import Data.Derive.DSL.HSE
import qualified Language.Haskell.Exts as H
import Data.Derive.DSL.DSL
import Control.Monad.Trans.State
import Control.Monad
import Data.Generics
import Data.Maybe
dslSYB :: DSL -> Maybe Out
dslSYB = syb
syb :: Data a => DSL -> Maybe a
syb = dsimple & dlistAny & dapp
lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)
lift f = maybe Nothing id . cast . f
(&) a b x = a x `mplus` b x
dlistAny :: forall a . Data a => DSL -> Maybe a
dlistAny x | isNothing con = Nothing
| otherwise = res
where
con = readConstr dat "(:)"
val = fromConstr (fromJust con) :: a
dat = dataTypeOf (undefined :: a)
res = gmapQi 0 f val
f :: Data d => d -> Maybe a
f y = fromJust $ cast $ dlist x `asTypeOf` Just [y]
dlist :: Data a => DSL -> Maybe [a]
dlist x = do
List xs <- return x
mapM syb xs
dapp :: forall a . Data a => DSL -> Maybe a
dapp x = do
App name (List args) <- return x
let dat = dataTypeOf (undefined :: a)
(res,s) = runState (fromConstrM f $ readCon dat name) (True,args)
if fst s then Just res else Nothing
where
f :: forall b . Data b => State (Bool,[DSL]) b
f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl
else do
(b,x:xs) <- get
case syb x of
Nothing -> do put (False,xs) ; return undefined
Just y -> do put (b,xs) ; return y
dsimple :: Data a => DSL -> Maybe a
dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle
dinstance :: DSL -> Maybe Decl
dinstance x = do
Instance _ name bod <- return x
bod <- syb bod
return $ InstDecl sl Nothing []
[ClassA (UnQual $ Ident "Data") [TyVar $ Ident "d_type"]]
(UnQual $ Ident name) [TyVar $ Ident "d_type"]
bod
dstring :: DSL -> Maybe String
dstring x = do
String x <- return x
return x
dmapctor :: DSL -> Maybe Exp
dmapctor x = do
App "List" (List [MapCtor x]) <- return x
x <- syb x
return $ ListComp x [QualStmt $ Generator sl (PVar $ Ident "d_ctor")
(H.App (v "d_dataCtors") (Paren $ ExpTypeSig sl (v "undefined") (TyVar $ Ident "d_type")))]
dsingle :: DSL -> Maybe Exp
dsingle (App "Lit" (List [App "Int" (List [CtorArity])])) = Just $ Paren $ H.App (v "d_ctorArity") (v "d_ctor")
dsingle (App "Lit" (List [App "Int" (List [CtorIndex])])) = Just $ Paren $ H.App (v "d_ctorIndex") (v "d_ctor")
dsingle (App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []])) = Just $ Paren $
ExpTypeSig sl (H.App (v "d_ctorValue") (v "d_ctor")) (TyVar $ Ident "d_type")
dsingle _ = Nothing
dapplication :: DSL -> Maybe Exp
dapplication x = do
Application (List xs) <- return x
syb $ f xs
where
f (x:y:z) = f (App "App" (List [x,y]) : z)
f [x] = x
v = Var . UnQual . Ident