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 import Printer
  11 import Compiler
  12 import Interpreter
  13
  14 className,constructorName,selectorName,predicateName :: Name -> Name
  15 className = mkName . (++"'") . stringName
  16 constructorName = mkName . map toLower . stringName
  17 selectorName = mkName . map toLower . (++"'") . stringName
  18 predicateName = mkName . ("is"++) . stringName
  19
  20 stringName :: Name -> String
  21 stringName (Name occ _) = occString occ
  22
  23 adtFieldName :: Name -> Integer -> Name
  24 adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx
  25
  26 getConsName :: Con -> Q (Name, [(Name, TypeQ)])
  27 getConsName (NormalC consName fs)
  28     | head (stringName consName) == ':' = fail "Infix constructors are not supported"
  29     | otherwise = pure (consName, [(adtFieldName consName i, pure t)|(_, t)<-fs | i<-[0..]])
  30 getConsName (RecC consName fs) = pure (consName, [(n, pure t) | (n, _, t)<-fs])
  31 getConsName c = fail $ "Unsupported constructor type: " ++ show c
  32
  33 ifx :: String -> ExpQ -> ExpQ -> ExpQ
  34 ifx op a b = infixE (Just a) (varE $ mkName op) (Just b)
  35
  36 fun :: Name -> [PatQ] -> ExpQ -> DecQ
  37 fun name args body = funD name [clause args (normalB body) []]
  38
  39 class GenDSL a where genDSL :: a -> DecsQ
  40 instance GenDSL a => GenDSL [a] where genDSL = fmap concat . mapM genDSL
  41 instance GenDSL Name where
  42     genDSL typename = reify typename >>= \info->case info of
  43         TyConI (DataD _ _ tyvars _ constructors _)
  44             -> mapM getConsName constructors >>= mkDSL typename tyvars
  45         t
  46             -> fail $ "mkConsClass only supports simple datatypes and not: " ++ show t
  47
  48 mkDSL :: Name -> [TyVarBndr] -> [(Name, [(Name, TypeQ)])] -> DecsQ
  49 mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ]
  50   where
  51     (consNames, fields) = unzip constructors
  52
  53     mkClass :: DecQ
  54     mkClass = classD (pure []) (className typeName) [PlainTV (mkName "v")] []
  55         (  map (uncurry mkConstructor) constructors
  56         ++ concatMap (map mkSelector) fields
  57         ++ map mkPredicate consNames
  58         )
  59       where
  60         v = varT $ mkName "v"
  61         arrow x y = [t|$x-> $y|]
  62
  63         mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ
  64         mkConstructor n fs = sigD (constructorName n) $ foldr arrow resultT $ map (appT v . snd) fs
  65
  66         mkSelector :: (Name, TypeQ) -> DecQ
  67         mkSelector (n, t) = sigD (selectorName n) [t|$resultT -> $v $t|]
  68
  69         mkPredicate :: Name -> DecQ
  70         mkPredicate n = sigD (predicateName n) [t|$resultT -> $v Bool|]
  71
  72         resultT :: TypeQ
  73         resultT = appT v $ foldl appT (conT typeName) $ map (varT . getName) $ typeVars
  74           where getName (PlainTV name) = name
  75                 getName (KindedTV name _) = name
  76
  77     mkPrinter :: DecQ
  78     mkPrinter = instanceD (pure []) [t|$(conT $ className typeName) Printer|]
  79         $  map (uncurry mkConstructor) constructors
  80         ++ concatMap (map (mkSelector . fst)) fields
  81         ++ map mkPredicate consNames
  82       where
  83         pl s = [|printLit $(lift s)|]
  84
  85         mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ
  86         mkConstructor consName fs = do
  87             fresh <- sequence [newName "f" | _<- fs]
  88             fun (constructorName consName) (map varP fresh) (pcons `appE` pargs fresh)
  89           where pcons = [|printCons $(lift $ stringName consName)|]
  90                 pargs fresh = foldl (ifx ">->") (pl "") $ map varE fresh
  91
  92         mkSelector :: Name -> DecQ
  93         mkSelector n = fun (selectorName n) [] [|\x->x >> $(pl ('.':stringName n))|]
  94
  95         mkPredicate :: Name -> DecQ
  96         mkPredicate n = fun (predicateName n) []
  97             [|\x-> $(pl $ stringName $ predicateName n) >-> x|]
  98
  99     mkCompiler :: DecQ
 100     mkCompiler = instanceD (pure []) [t|$(conT $ className typeName) Compiler|]
 101         $  zipWith (uncurry . mkConstructor) [0..] constructors
 102         ++ concatMap (zipWith mkSelector [0..] . map fst) fields
 103         ++ zipWith mkPredicate [0..] consNames
 104       where
 105         mkConstructor :: Integer -> Name -> [(Name, TypeQ)] -> DecQ
 106         mkConstructor consNum consName fs = do
 107             fresh <- sequence [newName "f" | _<-fs]
 108             fun (constructorName consName) (map varP fresh)
 109                 $ ifx "*>" pushCons $ ifx "<*" (mkBody $ map varE fresh) storeHeap
 110           where storeHeap = [|instr [Sth $ 1 + $(lift $ length fs)]|]
 111                 mkBody = foldl (ifx "<*>") [|pure $(conE consName)|]
 112                 pushCons = [|instr [Push $(lift consNum)]|]
 113
 114         mkSelector :: Integer -> Name -> DecQ
 115         mkSelector fn n = fun (selectorName n) [] [|\x->x >> instr [Ldh $(lift fn)]|]
 116
 117         mkPredicate :: Integer -> Name -> DecQ
 118         mkPredicate consNum consName = fun (predicateName consName) []
 119             [|\x->x >> instr [Ldh (-1), Push $(lift consNum), Eq]|]
 120
 121     mkInterpreter :: DecQ
 122     mkInterpreter = instanceD (pure []) [t|$(conT $ className typeName) Interpreter|]
 123         $  map (uncurry mkConstructor) constructors
 124         ++ concatMap (\(cn, fs)->zipWith (mkSelector cn (length fs)) [0..] (map fst fs)) constructors
 125         ++ map (uncurry mkPredicate) constructors
 126       where
 127         mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ
 128         mkConstructor consName fs = do
 129             fresh <- sequence [newName "f" | _<-fs]
 130             fun (constructorName consName) (map varP fresh)
 131                 $ foldl (ifx "<*>") [|pure $(conE consName)|] (map varE fresh)
 132
 133         mkSelector :: Name -> Int -> Int -> Name -> DecQ
 134         mkSelector consName ftotal fnum n = do
 135             fresh <- newName "f"
 136             fun (selectorName n) [varP fresh] $
 137                 [|$(varE fresh) >>= $(lamCaseE $ mkMatch:wilds)|]
 138           where
 139             mkMatch = do
 140                 fresh <- newName "e"
 141                 match (conP consName [if fnum == i then varP fresh else wildP | i<-[0..ftotal-1]])
 142                     (normalB [|pure $(varE fresh)|]) []
 143             wilds = if length consNames == 1 then [] else
 144                 [match wildP (normalB [|fail "Exhausted case"|]) []]
 145
 146         mkPredicate :: Name -> [(Name, TypeQ)] -> DecQ
 147         mkPredicate n fs = fun (predicateName n) []
 148             $ if length consNames == 1 then [|\_->true|] else
 149             [|\x->x >>= \p->case p of $(conP n [wildP | _<-fs]) -> true; _ -> false|]