ghc/compiler/simplCore/SimplHaskell.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[SimplHaskell]{Printing Core that looks like Haskell}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplHaskell ( coreToHaskell ) where
  10
  11 IMPORT_Trace
  12 import Outputable
  13 import Pretty
  14
  15 import BasicLit         ( BasicLit )
  16 import PlainCore
  17 import IdEnv
  18 import IdInfo
  19 import Maybes
  20 import Util
  21 import AbsPrel          ( PrimOp, nilDataCon, consDataCon )
  22 \end{code}
  23
  24 \begin{code}
  25 coreToHaskell :: PlainCoreProgram -> String {- 0 -}
  26 coreToHaskell binds = ("[Haskell:\n\n" ++ ppShow 80 (pprHaskFuns (transformCoreProg binds)) ++ "\n\n]\n")
  27 \end{code}
  28
  29 \begin{code}
  30 data HaskFun = HaskFun Id [([HaskExp],HaskExp)]
  31
  32 data HaskExp
  33         = HaskVar Bool Id               -- true of used many times
  34         | HaskLit BasicLit
  35         | HaskWild
  36         | HaskCon Id [HaskExp]
  37         | HaskPrim PrimOp [HaskExp]
  38         | HaskLam [HaskExp] HaskExp
  39         | HaskApp HaskExp HaskExp
  40         | HaskCase HaskExp [(HaskExp,HaskExp)]
  41         | HaskIf HaskExp HaskExp HaskExp
  42         | HaskLet [HaskFun] HaskExp
  43 \end{code}
  44
  45 Here is where the fun begins, you transform Core into Haskell!
  46
  47 \begin{code}
  48 type InEnv = IdEnv HaskExp
  49 type OutEnv = IdEnv (Int,Bool)  -- number of times used, and if save to inline
  50
  51
  52 mkHaskPatVar :: OutEnv -> Id -> HaskExp
  53 mkHaskPatVar env id = case lookupIdEnv env id of
  54                         Nothing -> HaskWild
  55                         Just (n,_) -> HaskVar (n > 1) id
  56
  57 transformCoreProg :: PlainCoreProgram -> [HaskFun]
  58 transformCoreProg prog = mergeCasesBindings funs
  59   where
  60    (_,_,funs) = transformCoreBindings nullIdEnv nullIdEnv prog
  61
  62 transformCoreBindings :: InEnv -> OutEnv -> [PlainCoreBinding] -> (InEnv,OutEnv,[HaskFun])
  63 transformCoreBindings in_env out_env [bnd]      = transformCoreBinding in_env out_env bnd
  64 transformCoreBindings in_env out_env (bnd:bnds) = (in_env'',out_env',hask_bnd ++ hask_bnds)
  65   where
  66     (in_env',out_env',hask_bnd)    = transformCoreBinding in_env out_env'' bnd
  67     (in_env'',out_env'',hask_bnds) = transformCoreBindings in_env' out_env bnds
  68
  69 transformCoreBinding :: InEnv -> OutEnv -> PlainCoreBinding -> (InEnv,OutEnv,[HaskFun])
  70 transformCoreBinding in_env out_env (CoNonRec v expr) = (in_env',out_env'',[HaskFun v rhs])
  71   where
  72     out_env''      = merge out_env out_env'
  73     (out_env',rhs) = transformCoreRhs in_env expr
  74     in_env'        = in_env `growIdEnvList` [ (v,exp) | [([],exp)] <- [rhs], False ]
  75
  76 transformCoreBinding in_env out_env (CoRec bnds) = (in_env,out_env'',hask_bnds)
  77   where
  78     out_env''  = foldl merge out_env out_envs
  79     (out_envs,hask_bnds) = unzip
  80                 [ (out_env',HaskFun v rhs) |
  81                         (v,exp) <- bnds,
  82                         (out_env',rhs) <- [transformCoreRhs in_env exp]]
  83
  84
  85 transformCoreRhs :: InEnv -> PlainCoreExpr -> (OutEnv,[([HaskExp],HaskExp)])
  86 transformCoreRhs in_env exp = (out_env,[(vars',hask_exp)])
  87     where
  88         vars'              = [ mkHaskPatVar out_env v | v <- vars ]
  89         (vars,exp')        = getLambdaVars exp
  90         (out_env,hask_exp) = transformCoreExp in_env exp'
  91         getLambdaVars (CoTyLam _ e) = getLambdaVars e
  92         getLambdaVars (CoLam xs e) = (xs ++ xs',e')
  93            where (xs',e') = getLambdaVars e
  94         getLambdaVars e = ([],e)
  95
  96 transformCoreExp :: InEnv -> PlainCoreExpr -> (OutEnv,HaskExp)
  97 transformCoreExp _      (CoVar v) = (unitIdEnv v (1,True),HaskVar False v)      -- lookup Env ?
  98 transformCoreExp _      (CoLit i) = (nullIdEnv,HaskLit i)
  99 transformCoreExp in_env (CoCon i _ atoms) = (out_env,HaskCon i hask_exps)
 100   where
 101     (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
 102 transformCoreExp in_env (CoPrim i _ atoms) = (out_env,HaskPrim i hask_exps)
 103   where
 104     (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
 105 -- CoLam
 106 -- CoTyLam
 107 transformCoreExp in_env (CoLam args exp) = (out_env,HaskLam args' h_exp)
 108    where -- modify the env !!!!!
 109         args' = [ mkHaskPatVar out_env v | v <- args ]
 110         (out_env,h_exp) = transformCoreExp in_env exp
 111 transformCoreExp in_env (CoTyLam _ exp) = transformCoreExp in_env exp
 112 transformCoreExp in_env (CoApp fun atom) = (merge o1 o2,HaskApp h_fun h_arg)
 113    where
 114         (o1,h_fun) = transformCoreExp in_env fun
 115         (o2,h_arg) = transformCoreExp in_env (atomToExpr atom)
 116 transformCoreExp in_env (CoTyApp fun _) = transformCoreExp in_env fun
 117 transformCoreExp in_env (CoCase e alts) = (foldl merge o1 o2,HaskCase h_e h_alts)
 118    where
 119         (o1,h_e)    = transformCoreExp in_env e
 120         (o2,h_alts) = unzip [ (out_env,(pat,h_e)) | (out_env,pat,h_e) <- transformCoreAlts in_env alts ]
 121
 122 transformCoreExp in_env exp@(CoLet _ _) = (o1,HaskLet h_binds h_exp)
 123   where
 124         (binds,exp') = getLets exp
 125         (in_env',o1,h_binds) = transformCoreBindings in_env o2 binds
 126         (o2,h_exp) = transformCoreExp in_env' exp'
 127         getLets (CoLet bind exp) = (bind:binds,exp')
 128             where (binds,exp') = getLets exp
 129         getLets exp = ([],exp)
 130
 131 transformCoreExp _ _         = (nullIdEnv,HaskWild)
 132
 133 transformCoreExps :: InEnv -> [PlainCoreExpr] -> (OutEnv,[HaskExp])
 134 transformCoreExps _ []          = (nullIdEnv,[])
 135 transformCoreExps in_env (e:es) = (merge o1 o2,h_e:hs_e)
 136   where
 137    (o1,h_e)  = transformCoreExp  in_env e
 138    (o2,hs_e) = transformCoreExps in_env es
 139
 140 transformCoreAlts :: InEnv -> PlainCoreCaseAlternatives -> [(OutEnv,HaskExp,HaskExp)]
 141 transformCoreAlts in_env (CoAlgAlts alts def) = map trans alts ++ mkdef def
 142    where
 143         trans (id,ids,e) = (o1,HaskCon id (map (mkHaskPatVar o1) ids),h_e)
 144            where
 145                 (o1,h_e) = transformCoreExp in_env e
 146         mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
 147           where
 148             (o1,h_e) = transformCoreExp in_env e
 149         mkdef _ = []
 150 transformCoreAlts in_env (CoPrimAlts alts def) = map trans alts ++ mkdef def
 151    where
 152         trans (lit,e) = (o1,HaskLit lit,h_e)
 153            where
 154                 (o1,h_e) = transformCoreExp in_env e
 155         mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
 156           where
 157             (o1,h_e) = transformCoreExp in_env e
 158         mkdef _ = []
 159 \end{code}
 160
 161 \begin{code}
 162 merge :: OutEnv -> OutEnv -> OutEnv
 163 merge e1 e2 = combineIdEnvs fn e1 e2
 164   where
 165         fn (n,_) (m,_) = (n+m,False)
 166 \end{code}
 167
 168
 169 \begin{code}
 170 mergeCasesBindings = map mergeCasesFun
 171
 172 mergeCasesFun (HaskFun id rhss) = HaskFun id (concat (map mergeCasesRhs rhss))
 173
 174 mergeCasesRhs (pats,exp) = [(pats,exp)]
 175
 176 {-
 177 case v of
 178    A x -> e1    , v             ==> Branch v  [ (A x,e1), (B y,e2) ]
 179    B y -> e2                    OR
 180                                     NoBranches (case v of
 181                                                   A x -> ...
 182                                                   B y -> ...)
 183
 184 -}
 185 --mergeCases :: HaskExp -> Set Id -> [(Id,HaskExp,HaskExp)]
 186 --mergeCases _ _ = []
 187 \end{code}
 188
 189
 190
 191 Maybe ???
 192
 193 type SM a = OutEnv Z
 194 returnSH a s = (a,s)
 195 thenSH m k s = case m s of
 196                 (r,s') -> k r s
 197 thenSH_ m k s = case m s of
 198                 (_,s') -> k s
 199
 200 \begin{code}
 201 pprHaskFuns xs = ppAboves (map pprHaskFun xs)
 202
 203 pprHaskFun (HaskFun id stuff) =
 204         ppAboves [
 205                 ppSep [ ppCat ([ppr PprForUser id] ++ map (pprHaskExp True) pats),
 206                         ppNest 2 (ppCat [ppStr "=",pprHaskExp False rhs])]
 207                 | (pats,rhs) <- stuff]
 208
 209 pprHaskExp :: Bool -> HaskExp -> Pretty
 210 pprHaskExp _ (HaskVar _ id) = ppr PprForUser id
 211 pprHaskExp _ (HaskLit i)  = ppr PprForUser i
 212 pprHaskExp _ (HaskWild)   = ppStr "_"
 213 pprHaskExp True exp       = ppBesides [ppLparen,pprHaskExp False exp,ppRparen]
 214 pprHaskExp _ (HaskCon con []) | con == nilDataCon = ppStr "[]"
 215 pprHaskExp _ (HaskCon con [e1,e2]) | con == consDataCon =
 216                 ppCat [pprHaskExp True e1,ppStr ":",pprHaskExp True e2]
 217 pprHaskExp _ (HaskCon con exps) =
 218                 ppCat (ppr PprForUser con:map (pprHaskExp True) exps)
 219 pprHaskExp _ (HaskPrim prim exps) =
 220                 ppCat (ppr PprForUser prim:map (pprHaskExp True) exps)
 221 pprHaskExp _ app@(HaskLam xs e) = -- \ xs -> e
 222         ppSep [ ppCat ([ppStr "\\"] ++ map (pprHaskExp True) xs),
 223                 ppNest 2 (ppCat [ppStr "->",pprHaskExp False e])]
 224 pprHaskExp _ app@(HaskApp _ _) = pprHaskApp app
 225 pprHaskExp _ (HaskCase e opts)
 226   = ppAboves [ppCat [ppStr "case", pprHaskExp False e,ppStr "of"],
 227         ppNest 2 (
 228            ppAboves [
 229                 (ppSep [ppCat [pprHaskExp False pat,ppStr "->"],
 230                                 ppNest 2 (pprHaskExp False exp)])
 231                         | (pat,exp) <- opts])]
 232 pprHaskExp _ (HaskIf i t e) = ppAboves
 233                 [ppCat [ppStr "if",pprHaskExp False i],
 234                  ppCat [ppStr "then",pprHaskExp False t],
 235                  ppCat [ppStr "else",pprHaskExp False e]]
 236 pprHaskExp _ (HaskLet binds e)
 237   = ppAboves [ppStr "let",
 238            ppNest 2 (pprHaskFuns binds),
 239            ppCat [ppStr "in",ppNest 1 (pprHaskExp False e)]]
 240 pprHaskExp _ _ = panic "pprHaskExp failed"
 241
 242
 243 pprHaskApp (HaskApp fun arg) = ppCat [pprHaskApp fun,pprHaskExp True arg]
 244 pprHaskApp e                 = pprHaskExp True e
 245 \end{code}
 246
 247
 248
 249 pprHaskExp n exp = ppr