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