- pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
-
- mkConstructor :: Integer -> Name -> [Field] -> Dec
- mkConstructor _ consName fs = fun (constructorName consName) (map (VarP . ffresh) fs) (pcons `AppE` pargs)
- where pcons = VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName)
- pargs = foldl (ifx ">->") (pl "") $ map (VarE . ffresh) fs
-
- mkSelector :: Integer -> Field -> Dec
- mkSelector _ Field{fname=n} = fun (selectorName n) [VarP argName] (ifx ">>" (VarE argName) $ pl ('.':stringName n))
-
- mkPredicate :: Integer -> Name -> Dec
- mkPredicate _ n = fun (predicateName n) [VarP argName] (ifx ">->" (pl $ stringName $ predicateName n) $ VarE argName)
-
- mkCompiler :: Dec
- mkCompiler = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Compiler")) $ mkDecls mkConstructor mkSelector mkPredicate
+ pl s = varE (mkName "printLit") `appE` string s
+
+ mkConstructor :: Name -> [Field] -> DecQ
+ mkConstructor consName fs = do
+ fresh <- sequence [newName "f" | _<- fs]
+ fun (constructorName consName) (map varP fresh) (pcons `appE` pargs fresh)
+ where pcons = varE (mkName "printCons") `appE` string (stringName consName)
+ pargs fresh = foldl (ifx ">->") (pl "") $ map varE fresh
+
+ mkSelector :: Field -> DecQ
+ mkSelector Field{fname=n} = do
+ fresh <- newName "f"
+ fun (selectorName n) [varP fresh] (ifx ">>" (varE fresh) $ pl ('.':stringName n))
+
+ mkPredicate :: Name -> DecQ
+ mkPredicate n = do
+ fresh <- newName "f"
+ fun (predicateName n) [varP fresh] (ifx ">->" (pl $ stringName $ predicateName n) $ varE fresh)
+
+ mkCompiler :: DecQ
+ mkCompiler = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Compiler"))
+ $ zipWith3 mkConstructor [0..] consNames fields
+ ++ concat (zipWith (map . mkSelector) [0..] fields)
+ ++ zipWith mkPredicate [0..] consNames
+ where
+ instrE e = varE (mkName "instr") `appE` listE e
+
+ mkConstructor :: Integer -> Name -> [Field] -> DecQ
+ mkConstructor consNum consName fs = do
+ fresh <- sequence [newName "f" | _<-fs]
+ fun (constructorName consName) (map varP fresh)
+ $ ifx "*>" pushCons $ ifx "<*" (mkBody $ map varE fresh) storeHeap
+ where storeHeap = instrE [conE (mkName "Sth") `appE` (ifx "+" (int 1) (int $ length fs))]
+ mkBody = foldl (ifx "<*>") (varE (mkName "pure") `appE` conE consName)
+ pushCons = instrE [conE (mkName "Push") `appE` int consNum]
+
+ mkSelector :: Integer -> Field -> DecQ
+ mkSelector consNum Field{fname=f} = do
+ fresh <- newName "f"
+ fun (selectorName f) [varP fresh]
+ $ ifx ">>" (varE fresh) $ instrE [conE (mkName "Ldh") `appE` int consNum]
+
+ mkPredicate :: Integer -> Name -> DecQ
+ mkPredicate consNum consName = do
+ fresh <- newName "f"
+ fun (predicateName consName) [varP fresh]
+ $ ifx ">>" (varE fresh) $ instrE
+ [ conE (mkName "Ldh") `appE` int (-1)
+ , conE (mkName "Push") `appE` int consNum
+ , conE (mkName "Eq")
+ ]
+
+ mkInterpreter :: DecQ
+ mkInterpreter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Interpreter"))
+ $ zipWith mkConstructor consNames fields
+ ++ concatMap (map mkSelector) fields
+ ++ zipWith mkPredicate consNames fields