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