"Combining" in parenthesis
[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 generateCodeDet :: AST -> [ TH.Dec ] 
15 generateCodeDet = convCmpl
16
17
18 generateCodeBwd :: (AST, AST, AST, TAST) -> [ TH.Dec ]
19 generateCodeBwd (orig, bwd, cmpl, tinv) = 
20     convCmpl orig ++ convBWD bwd ++ convCmpl cmpl ++ convNDet tinv 
21
22 convP (PCon _ _ (Name "Cons") [p1,p2]) = 
23     TH.InfixP (convP p1) (TH.mkName ":") (convP p2)
24 convP (PCon _ _ (Name "Nil") []) =
25     TH.ListP []
26 convP (PCon _ _ (Name "Unit") []) =
27     TH.TupP []
28 convP (PCon _ _ c cs) = 
29     TH.ConP (TH.mkName $ show c) $ map convP cs
30 convP (PVar _ _ v)    = TH.VarP (TH.mkName $ show v) 
31
32 returnE e     = TH.AppE (TH.VarE $ TH.mkName "return") e
33 mplusE  e1 e2 = TH.AppE (TH.AppE (TH.VarE $ TH.mkName "mplus") e1) e2 
34 mzeroE        = TH.VarE $ TH.mkName "mzero"
35
36 name :: Show a => a -> TH.Name
37 name  = TH.mkName . show 
38 nameE = TH.VarE . name 
39
40 apply f es = foldl TH.AppE f es
41
42 convBWD (AST decls) = map convBWDD decls 
43     where
44       convBWDD (Decl f _ ps e) = TH.FunD (TH.mkName $ show f)
45                                  [ TH.Clause (map convP ps) (TH.NormalB $ convE e) [] ]
46       convE (EFun _ _ (NInv f) [EVar _ _ v]) = 
47           TH.AppE (TH.VarE $ TH.mkName "head") $ 
48             TH.AppE (nameE (NInv f)) (nameE v)
49       convE (EFun _ _ (NInv (NTuple f)) 
50                       [EVar _ _ v, EFun _ _ (NCmpl _) [EVar _ _ s]]) = 
51           TH.AppE (TH.VarE $ TH.mkName "head") $ 
52              apply (nameE (NInv (NTuple f))) 
53                        [nameE v, TH.AppE (nameE (NCmpl f)) (nameE s)]
54
55 convCmpl (AST decls) = map convCmplF $ groupBy isSameFunc decls
56     where 
57       convCmplF (ds@(Decl f _ _ _:_)) =
58           TH.FunD (name f) $ map convCmplD ds 
59       convCmplD (Decl _ _ ps e) = TH.Clause [TH.TupP $ map convP ps] (TH.NormalB $ convE e) []
60       convE (EVar _ _ v)    = nameE v
61       convE (ECon _ _ (Name "Cons") [e1,e2]) = TH.InfixE (Just $ convE e1) (TH.VarE $ TH.mkName ":") (Just $ convE e2)
62       convE (ECon _ _ (Name "Nil")  [])      = TH.ListE []
63       convE (ECon _ _ (Name "Unit")  [])     = TH.TupE []
64       convE (ECon _ _ c es) = apply (TH.ConE (name c)) $ map convE es 
65       convE (EFun _ _ f es) = apply (TH.VarE (name f)) $ [TH.TupE $ map convE es ]
66
67
68 convE (EVar _ _ v)    = nameE v
69 convE (ECon _ _ (Name "Cons") [e1,e2]) = TH.InfixE (Just $ convE e1) (TH.VarE $ TH.mkName ":") (Just $ convE e2)
70 convE (ECon _ _ (Name "Nil")  [])      = TH.ListE []
71 convE (ECon _ _ (Name "Unit") [])      = TH.TupE []
72 convE (ECon _ _ c es) = apply (TH.ConE (name c)) $ map convE es 
73 convE (EFun _ _ f es) = apply (TH.VarE (name f)) $ map convE es 
74
75
76 convNDet (TAST tdecls) 
77     = concatMap convNDetF $ groupBy isSameFuncT tdecls 
78     where
79       isSameFuncT (TDecl f _ _ _) (TDecl g _ _ _) = f == g 
80       vars    = [ TH.mkName $ "x"    ++ show i        | i <- [1..] ]
81       funcs f = [ TH.mkName $ show f ++ "_" ++ show i | i <- [1..] ] -- name f = TH.mkName $ show f 
82       convNDetF (ds@(TDecl f ps _ _:_)) = -- NInj
83           [ TH.FunD (name f) 
84             [ TH.Clause (map TH.VarP $ take (length ps) vars)
85                         (TH.NormalB mpluses)
86                         [] ] ]
87           ++ zipWith convNDetD ds (funcs f)
88           where
89             mpluses = foldr mplusE mzeroE $
90                         map (\f -> apply (TH.VarE f) $ map TH.VarE (take (length ps) vars) ) $
91                             take (length ds) (funcs f)
92       convNDetD (TDecl _ ps es vs) f =
93           TH.FunD f [ TH.Clause (map convP ps)         (TH.NormalB $ convEs es vs) [],
94                       TH.Clause [ TH.WildP | _ <- ps]  (TH.NormalB mzeroE) [] ]
95       
96       convEs es vs = TH.DoE $ (map mkBind vs) ++ [ TH.NoBindS (returnE $ TH.TupE $ map convE es) ]
97           where
98             mkBind (VDecl us f vs) = TH.BindS (TH.TupP $ map (TH.VarP . name) us)
99                                            (apply (nameE f) $ map (TH.VarE . name) vs)
100                                            
101       
102
103 instance Ppr TH.Dec where
104     ppr = text . show . TH.ppr
105     pprList vs = vcat $ map ppr vs