[Init] Implementation of "Combining Syntactic and Semantic Bidirectionalization"
[darcs-mirror-sem_syn.git] / CodeGen.hs
1 {-# OPTIONS -XMultiParamTypeClasses -XTemplateHaskell #-}
2
3 module CodeGen where
4
5 import qualified Language.Haskell.TH as TH
6
7 import Text.PrettyPrint 
8 import Debug.Trace
9 import Data.List (groupBy)
10
11 import AST
12 import Util
13
14 generateCodeBwd :: (AST, AST, AST, TAST) -> [ TH.Dec ]
15 generateCodeBwd (orig, bwd, cmpl, tinv) = 
16     convCmpl orig ++ convBWD bwd ++ convCmpl cmpl ++ convNDet tinv 
17
18 convP (PCon _ _ (Name "Cons") [p1,p2]) = 
19     TH.InfixP (convP p1) (TH.mkName ":") (convP p2)
20 convP (PCon _ _ (Name "Nil") []) =
21     TH.ListP []
22 convP (PCon _ _ c cs) = 
23     TH.ConP (TH.mkName $ show c) $ map convP cs
24 convP (PVar _ _ v)    = TH.VarP (TH.mkName $ show v) 
25
26 returnE e     = TH.AppE (TH.VarE $ TH.mkName "return") e
27 mplusE  e1 e2 = TH.AppE (TH.AppE (TH.VarE $ TH.mkName "mplus") e1) e2 
28 mzeroE        = TH.VarE $ TH.mkName "mzero"
29
30 name :: Show a => a -> TH.Name
31 name  = TH.mkName . show 
32 nameE = TH.VarE . name 
33
34 apply f es = foldl TH.AppE f es
35
36 convBWD (AST decls) = map convBWDD decls 
37     where
38       convBWDD (Decl f _ ps e) = TH.FunD (TH.mkName $ show f)
39                                  [ TH.Clause (map convP ps) (TH.NormalB $ convE e) [] ]
40       convE (EFun _ _ (NInv f) [EVar _ _ v]) = 
41           TH.AppE (TH.VarE $ TH.mkName "head") $ 
42             TH.AppE (nameE (NInv f)) (nameE v)
43       convE (EFun _ _ (NInv (NTuple f)) 
44                       [EVar _ _ v, EFun _ _ (NCmpl _) [EVar _ _ s]]) = 
45           TH.AppE (TH.VarE $ TH.mkName "head") $ 
46              apply (nameE (NInv (NTuple f))) 
47                        [nameE v, TH.AppE (nameE (NCmpl f)) (nameE s)]
48
49 convCmpl (AST decls) = map convCmplF $ groupBy isSameFunc decls
50     where 
51       convCmplF (ds@(Decl f _ _ _:_)) =
52           TH.FunD (name f) $ map convCmplD ds 
53       convCmplD (Decl _ _ ps e) = TH.Clause [TH.TupP $ map convP ps] (TH.NormalB $ convE e) []
54       convE (EVar _ _ v)    = nameE v
55       convE (ECon _ _ (Name "Cons") [e1,e2]) = TH.InfixE (Just $ convE e1) (TH.VarE $ TH.mkName ":") (Just $ convE e2)
56       convE (ECon _ _ (Name "Nil")  [])      = TH.ListE []
57       convE (ECon _ _ c es) = apply (TH.ConE (name c)) $ map convE es 
58       convE (EFun _ _ f es) = apply (TH.VarE (name f)) $ [TH.TupE $ map convE es ]
59
60
61 convE (EVar _ _ v)    = nameE v
62 convE (ECon _ _ (Name "Cons") [e1,e2]) = TH.InfixE (Just $ convE e1) (TH.VarE $ TH.mkName ":") (Just $ convE e2)
63 convE (ECon _ _ (Name "Nil")  [])      = TH.ListE []
64 convE (ECon _ _ c es) = apply (TH.ConE (name c)) $ map convE es 
65 convE (EFun _ _ f es) = apply (TH.VarE (name f)) $ map convE es 
66
67
68 convNDet (TAST tdecls) 
69     = concatMap convNDetF $ groupBy isSameFuncT tdecls 
70     where
71       isSameFuncT (TDecl f _ _ _) (TDecl g _ _ _) = f == g 
72       vars    = [ TH.mkName $ "x"    ++ show i        | i <- [1..] ]
73       funcs f = [ TH.mkName $ show f ++ "_" ++ show i | i <- [1..] ] -- name f = TH.mkName $ show f 
74       convNDetF (ds@(TDecl f ps _ _:_)) = -- NInj
75           [ TH.FunD (name f) 
76             [ TH.Clause (map TH.VarP $ take (length ps) vars)
77                         (TH.NormalB mpluses)
78                         [] ] ]
79           ++ zipWith convNDetD ds (funcs f)
80           where
81             mpluses = foldr mplusE mzeroE $
82                         map (\f -> apply (TH.VarE f) $ map TH.VarE (take (length ps) vars) ) $
83                             take (length ds) (funcs f)
84       convNDetD (TDecl _ ps es vs) f =
85           TH.FunD f [ TH.Clause (map convP ps)         (TH.NormalB $ convEs es vs) [],
86                       TH.Clause [ TH.WildP | _ <- ps]  (TH.NormalB mzeroE) [] ]
87       
88       convEs es vs = TH.DoE $ (map mkBind vs) ++ [ TH.NoBindS (returnE $ TH.TupE $ map convE es) ]
89           where
90             mkBind (VDecl us f vs) = TH.BindS (TH.TupP $ map (TH.VarP . name) us)
91                                            (apply (nameE f) $ map (TH.VarE . name) vs)
92                                            
93       
94
95 instance Ppr TH.Dec where
96     ppr = text . show . TH.ppr
97     pprList vs = vcat $ map ppr vs