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 -> Integer -> Name
  23 adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx
  24
  25 data Field = Field { fcons :: Name, ftotal :: Integer, fnum :: Integer, fname :: Name, ftype :: Type }
  26
  27 toNameType :: Con -> [Field]
  28 toNameType (NormalC consName fs) = [Field {fcons=consName, ftotal=toInteger $ length fs, fnum=i, fname=adtFieldName consName i, ftype=t} | (_, t) <- fs | i <- [0..]]
  29 toNameType (RecC consName fs) = [Field consName (toInteger $ length fs) i n t | (n, _, t)<-fs | i <- [0..]]
  30 toNameType c = fail $ "Unsupported constructor type: " ++ show c
  31
  32 getConsName :: Con -> Q Name
  33 getConsName (NormalC consName _)
  34     | head (stringName consName) == ':' = fail "Infix constructors are not supported"
  35     | otherwise = pure consName
  36 getConsName (RecC consName _) = pure consName
  37 getConsName c = fail $ "Unsupported constructor type: " ++ show c
  38
  39 int :: Integral a => a -> ExpQ
  40 int = litE . integerL . toInteger
  41
  42 string :: String -> ExpQ
  43 string = litE . stringL
  44
  45 ifx :: String -> ExpQ -> ExpQ -> ExpQ
  46 ifx op a b = infixE (Just a) (varE $ mkName op) (Just b)
  47
  48 getNameTyVarBndr :: TyVarBndr -> Name
  49 getNameTyVarBndr (PlainTV name) = name
  50 getNameTyVarBndr (KindedTV name _) = name
  51
  52 fun :: Name -> [PatQ] -> ExpQ -> DecQ
  53 fun name args body = funD name [clause args (normalB body) []]
  54
  55 genDSL :: Name -> DecsQ
  56 genDSL typename = reify typename >>= \info->case info of
  57     TyConI (DataD _ _ tyvars _ constructors _)
  58         -> mapM getConsName constructors >>= mkDSL typename tyvars (map toNameType constructors)
  59     t
  60         -> fail $ "mkConsClass only supports datatypes and not: " ++ show t
  61
  62 mkDSL :: Name -> [TyVarBndr] -> [[Field]] -> [Name] -> DecsQ
  63 mkDSL typeName typeVars fields consNames = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ]
  64   where
  65     mkClass :: DecQ
  66     mkClass = classD (pure []) (className typeName) [PlainTV (mkName "v")] []
  67         (  zipWith mkConstructor consNames fields
  68         ++ concatMap (map mkSelector) fields
  69         ++ map mkPredicate consNames
  70         )
  71       where
  72         view a = varT (mkName "v") `appT` a
  73         arrow = appT . appT arrowT
  74
  75         mkConstructor :: Name -> [Field] -> DecQ
  76         mkConstructor n fs = sigD (constructorName n) $ foldr arrow resultT $ map (view . pure . ftype) fs
  77
  78         mkSelector :: Field -> DecQ
  79         mkSelector f = sigD (selectorName (fname f)) $ resultT `arrow` view (pure $ ftype f)
  80
  81         mkPredicate :: Name -> DecQ
  82         mkPredicate n = sigD (predicateName n) $ resultT `arrow` view (conT (mkName "Bool"))
  83
  84         resultT :: TypeQ
  85         resultT = view $ foldl appT (conT typeName) $ map (varT . getNameTyVarBndr) $ typeVars
  86
  87     mkPrinter :: DecQ
  88     mkPrinter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Printer"))
  89         $  zipWith mkConstructor consNames fields
  90         ++ concatMap (map mkSelector) fields
  91         ++ map mkPredicate consNames
  92       where
  93         pl s = varE (mkName "printLit") `appE` string s
  94
  95         mkConstructor :: Name -> [Field] -> DecQ
  96         mkConstructor consName fs = do
  97             fresh <- sequence [newName "f" | _<- fs]
  98             fun (constructorName consName) (map varP fresh) (pcons `appE` pargs fresh)
  99           where pcons = varE (mkName "printCons") `appE` string (stringName consName)
 100                 pargs fresh = foldl (ifx ">->") (pl "") $ map varE fresh
 101
 102         mkSelector :: Field -> DecQ
 103         mkSelector Field{fname=n} = do
 104             fresh <- newName "f"
 105             fun (selectorName n) [varP fresh] (ifx ">>" (varE fresh) $ pl ('.':stringName n))
 106
 107         mkPredicate :: Name -> DecQ
 108         mkPredicate n = do
 109             fresh <- newName "f"
 110             fun (predicateName n) [varP fresh] (ifx ">->" (pl $ stringName $ predicateName n) $ varE fresh)
 111
 112     mkCompiler :: DecQ
 113     mkCompiler = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Compiler"))
 114         $ zipWith3 mkConstructor [0..] consNames fields
 115         ++ concat (zipWith (map . mkSelector) [0..] fields)
 116         ++ zipWith mkPredicate [0..] consNames
 117       where
 118         instrE e = varE (mkName "instr") `appE` listE e
 119
 120         mkConstructor :: Integer -> Name -> [Field] -> DecQ
 121         mkConstructor consNum consName fs = do
 122             fresh <- sequence [newName "f" | _<-fs]
 123             fun (constructorName consName) (map varP fresh)
 124                 $ ifx "*>" pushCons $ ifx "<*" (mkBody $ map varE fresh) storeHeap
 125           where storeHeap = instrE [conE (mkName "Sth") `appE` (ifx "+" (int 1) (int $ length fs))]
 126                 mkBody = foldl (ifx "<*>") (varE (mkName "pure") `appE` conE consName)
 127                 pushCons = instrE [conE (mkName "Push") `appE` int consNum]
 128
 129         mkSelector :: Integer -> Field -> DecQ
 130         mkSelector consNum Field{fname=f} = do
 131             fresh <- newName "f"
 132             fun (selectorName f) [varP fresh]
 133                 $ ifx ">>" (varE fresh) $ instrE [conE (mkName "Ldh") `appE` int consNum]
 134
 135         mkPredicate :: Integer -> Name -> DecQ
 136         mkPredicate consNum consName = do
 137             fresh <- newName "f"
 138             fun (predicateName consName) [varP fresh]
 139                 $ ifx ">>" (varE fresh) $ instrE
 140                     [ conE (mkName "Ldh") `appE` int (-1)
 141                     , conE (mkName "Push") `appE` int consNum
 142                     , conE (mkName "Eq")
 143                     ]
 144
 145     mkInterpreter :: DecQ
 146     mkInterpreter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Interpreter"))
 147         $  zipWith mkConstructor consNames fields
 148         ++ concatMap (map mkSelector) fields
 149         ++ zipWith mkPredicate consNames fields
 150       where
 151         wildcase e = if length consNames == 1 then [] else
 152             [match wildP (normalB e) []]
 153
 154         mkConstructor :: Name -> [Field] -> DecQ
 155         mkConstructor consName fs = do
 156             fresh <- sequence [newName "f" | _<-fs]
 157             fun (constructorName consName) (map varP fresh)
 158                 $ foldl (ifx "<*>") (varE (mkName "pure") `appE` conE consName) (map varE fresh)
 159
 160         mkSelector :: Field -> DecQ
 161         mkSelector f = do
 162             fresh <- newName "f"
 163             fun (selectorName $ fname f) [varP fresh] $
 164                 ifx ">>=" (varE fresh) $ lamCaseE $ mkMatch : wilds
 165           where
 166             mkMatch = do
 167                 fresh <- newName "e"
 168                 match (conP (fcons f) [if fnum f == i then (varP fresh) else wildP | i<-[0..ftotal f-1]])
 169                     (normalB $ varE (mkName "pure") `appE` varE fresh) []
 170             wilds = wildcase (varE (mkName "fail") `appE` string "Exhausted case")
 171
 172         mkPredicate :: Name -> [Field] -> DecQ
 173         mkPredicate n fs = do
 174             fresh <- newName "f"
 175             fun (predicateName n) [varP fresh] $ ifx "<$>" (lamCaseE (mkMatch:wilds)) (varE fresh)
 176           where mkMatch = match (conP n [wildP | _<-fs]) (normalB $ conE (mkName "True")) []
 177                 wilds = wildcase (conE $ mkName "False")