datatype/Language/GenDSL.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# LANGUAGE ParallelListComp #-}
   3 module Language.GenDSL where
   4
   5 import Language.Haskell.TH.Syntax
   6 import Language.Haskell.TH
   7 import Data.Char
   8 import Control.Monad
   9
  10 className,constructorName,selectorName,predicateName :: Name -> Name
  11 className = mkName . (++"'") . stringName
  12 constructorName = mkName . map toLower . stringName
  13 selectorName = mkName . map toLower . (++"'") . stringName
  14 predicateName = mkName . ("is"++) . stringName
  15
  16 stringName :: Name -> String
  17 stringName (Name occ _) = occString occ
  18
  19 numberedArgs :: [a] -> Q [Name]
  20 numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..]
  21
  22 data Field = Field { fname :: Name, ffresh :: Name, ftype :: Type }
  23
  24 toNameType :: Con -> Q [Field]
  25 toNameType (NormalC consName fs) = numberedArgs fs
  26     >>= \nfs->pure [Field (mkName $ map toLower (stringName consName) ++ "f" ++ show i) nf t | (_, t) <- fs | nf <- nfs | i <- [0 :: Int ..]]
  27 toNameType (RecC _ fs) = numberedArgs fs
  28     >>= \nfs->pure [Field n nf t | (n, _, t)<-fs | nf <- nfs]
  29 toNameType c = fail $ "Unsupported constructor type: " ++ show c
  30
  31 getConsName :: Con -> Q Name
  32 getConsName (NormalC consName _) = pure consName
  33 getConsName (RecC consName _) = pure consName
  34 getConsName c = fail $ "Unsupported constructor type: " ++ show c
  35
  36 ifx :: String -> Exp -> Exp -> Exp
  37 ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
  38
  39 getNameTyVarBndr :: TyVarBndr -> Name
  40 getNameTyVarBndr (PlainTV name) = name
  41 getNameTyVarBndr (KindedTV name _) = name
  42
  43 genDSL :: Name -> DecsQ
  44 genDSL typename = reify typename >>= \info->case info of
  45     TyConI (DataD _ _ tyvars _ constructors _)
  46         -> mkDSL typename tyvars <$> newName "view" <*> newName "d" <*> mapM getConsName constructors <*> mapM toNameType constructors
  47     t
  48         -> fail $ "mkConsClass only supports datatypes and not: " ++ show t
  49
  50 mkDSL :: Name -> [TyVarBndr] -> Name -> Name -> [Name] -> [[Field]] -> [Dec]
  51 mkDSL typeName typeVars viewName argName consNames fields = [ mkClass, mkPrinter, mkCompiler ]
  52   where
  53     mkDecls mkConstructor mkSelector mkPredicate
  54         =  zipWith3 mkConstructor [0..] consNames fields
  55         ++ concatMap (zipWith mkSelector [0..]) fields
  56         ++ zipWith mkPredicate [0..] consNames
  57
  58     mkClass :: Dec
  59     mkClass = ClassD [] (className typeName) [PlainTV viewName] [] $ mkDecls mkConstructor mkSelector mkPredicate
  60       where
  61         view a = VarT viewName `AppT` a
  62         arrow = AppT . AppT ArrowT
  63
  64         mkConstructor :: Integer -> Name -> [Field] -> Dec
  65         mkConstructor _ n fs = SigD (constructorName n) $ foldr arrow resultT $ map (view . ftype) fs
  66
  67         mkSelector :: Integer -> Field -> Dec
  68         mkSelector _ f = SigD (selectorName (fname f)) $ resultT `arrow` view (ftype f)
  69
  70         mkPredicate :: Integer -> Name -> Dec
  71         mkPredicate _ n = SigD (predicateName n) $ resultT `arrow` view (ConT (mkName "Bool"))
  72
  73         resultT = view $ foldl AppT (ConT typeName) $ map (VarT . getNameTyVarBndr) $ typeVars
  74
  75     fun name args body = FunD name [Clause args (NormalB body) []]
  76
  77     mkPrinter :: Dec
  78     mkPrinter = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Printer")) $ mkDecls mkConstructor mkSelector mkPredicate
  79       where
  80         pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
  81
  82         mkConstructor :: Integer -> Name -> [Field] -> Dec
  83         mkConstructor _ consName fs = fun (constructorName consName) (map (VarP . ffresh) fs) (pcons `AppE` pargs)
  84           where pcons = VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName)
  85                 pargs = foldl (ifx ">->") (pl "") $ map (VarE . ffresh) fs
  86
  87         mkSelector :: Integer -> Field -> Dec
  88         mkSelector _ Field{fname=n} = fun (selectorName n) [VarP argName] (ifx ">>" (VarE argName) $ pl ('.':stringName n))
  89
  90         mkPredicate :: Integer -> Name -> Dec
  91         mkPredicate _ n = fun (predicateName n) [VarP argName] (ifx ">->" (pl $ stringName $ predicateName n) $ VarE argName)
  92
  93     mkCompiler :: Dec
  94     mkCompiler = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Compiler")) $ mkDecls mkConstructor mkSelector mkPredicate
  95       where
  96         instrE e = VarE (mkName "instr") `AppE` ListE e
  97
  98         mkConstructor :: Integer -> Name -> [Field] -> Dec
  99         mkConstructor consNum consName fs = fun (constructorName consName) (map (VarP . ffresh) fs)
 100             $ ifx "*>" pushCons $ ifx "<*" (mkBody $ map (VarE . ffresh) fs) storeHeap
 101           where storeHeap = instrE [ConE (mkName "Sth") `AppE` (ifx "+" (LitE $ IntegerL 1) (LitE $ IntegerL $ toInteger $ length fs))]
 102                 mkBody = foldl (ifx "<*>") (VarE (mkName "pure") `AppE` ConE consName)
 103                 pushCons = instrE [ConE (mkName "Push") `AppE` LitE (IntegerL consNum)]
 104
 105         mkSelector :: Integer -> Field -> Dec
 106         mkSelector consNum Field{fname=f} = fun (selectorName f) [VarP argName]
 107             $ ifx ">>" (VarE argName) $ instrE
 108                 [ConE (mkName "Ldh") `AppE` LitE (IntegerL consNum)]
 109
 110         mkPredicate :: Integer -> Name -> Dec
 111         mkPredicate consNum consName = fun (predicateName consName) [VarP argName]
 112             $ ifx ">>" (VarE argName) $ instrE
 113                 [ ConE (mkName "Ldh") `AppE` LitE (IntegerL (-1))
 114                 , ConE (mkName "Push") `AppE` LitE (IntegerL $ toInteger consNum)
 115                 , ConE (mkName "Eq")
 116                 ]