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