+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[SimplHaskell]{Printing Core that looks like Haskell}
-
-\begin{code}
-#include "HsVersions.h"
-
-module SimplHaskell ( coreToHaskell ) where
-
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import BasicLit ( BasicLit )
-import PlainCore
-import IdEnv
-import IdInfo
-import Maybes
-import Util
-import AbsPrel ( PrimOp, nilDataCon, consDataCon )
-\end{code}
-
-\begin{code}
-coreToHaskell :: PlainCoreProgram -> String {- 0 -}
-coreToHaskell binds = ("[Haskell:\n\n" ++ ppShow 80 (pprHaskFuns (transformCoreProg binds)) ++ "\n\n]\n")
-\end{code}
-
-\begin{code}
-data HaskFun = HaskFun Id [([HaskExp],HaskExp)]
-
-data HaskExp
- = HaskVar Bool Id -- true of used many times
- | HaskLit BasicLit
- | HaskWild
- | HaskCon Id [HaskExp]
- | HaskPrim PrimOp [HaskExp]
- | HaskLam [HaskExp] HaskExp
- | HaskApp HaskExp HaskExp
- | HaskCase HaskExp [(HaskExp,HaskExp)]
- | HaskIf HaskExp HaskExp HaskExp
- | HaskLet [HaskFun] HaskExp
-\end{code}
-
-Here is where the fun begins, you transform Core into Haskell!
-
-\begin{code}
-type InEnv = IdEnv HaskExp
-type OutEnv = IdEnv (Int,Bool) -- number of times used, and if save to inline
-
-
-mkHaskPatVar :: OutEnv -> Id -> HaskExp
-mkHaskPatVar env id = case lookupIdEnv env id of
- Nothing -> HaskWild
- Just (n,_) -> HaskVar (n > 1) id
-
-transformCoreProg :: PlainCoreProgram -> [HaskFun]
-transformCoreProg prog = mergeCasesBindings funs
- where
- (_,_,funs) = transformCoreBindings nullIdEnv nullIdEnv prog
-
-transformCoreBindings :: InEnv -> OutEnv -> [PlainCoreBinding] -> (InEnv,OutEnv,[HaskFun])
-transformCoreBindings in_env out_env [bnd] = transformCoreBinding in_env out_env bnd
-transformCoreBindings in_env out_env (bnd:bnds) = (in_env'',out_env',hask_bnd ++ hask_bnds)
- where
- (in_env',out_env',hask_bnd) = transformCoreBinding in_env out_env'' bnd
- (in_env'',out_env'',hask_bnds) = transformCoreBindings in_env' out_env bnds
-
-transformCoreBinding :: InEnv -> OutEnv -> PlainCoreBinding -> (InEnv,OutEnv,[HaskFun])
-transformCoreBinding in_env out_env (CoNonRec v expr) = (in_env',out_env'',[HaskFun v rhs])
- where
- out_env'' = merge out_env out_env'
- (out_env',rhs) = transformCoreRhs in_env expr
- in_env' = in_env `growIdEnvList` [ (v,exp) | [([],exp)] <- [rhs], False ]
-
-transformCoreBinding in_env out_env (CoRec bnds) = (in_env,out_env'',hask_bnds)
- where
- out_env'' = foldl merge out_env out_envs
- (out_envs,hask_bnds) = unzip
- [ (out_env',HaskFun v rhs) |
- (v,exp) <- bnds,
- (out_env',rhs) <- [transformCoreRhs in_env exp]]
-
-
-transformCoreRhs :: InEnv -> PlainCoreExpr -> (OutEnv,[([HaskExp],HaskExp)])
-transformCoreRhs in_env exp = (out_env,[(vars',hask_exp)])
- where
- vars' = [ mkHaskPatVar out_env v | v <- vars ]
- (vars,exp') = getLambdaVars exp
- (out_env,hask_exp) = transformCoreExp in_env exp'
- getLambdaVars (CoTyLam _ e) = getLambdaVars e
- getLambdaVars (CoLam xs e) = (xs ++ xs',e')
- where (xs',e') = getLambdaVars e
- getLambdaVars e = ([],e)
-
-transformCoreExp :: InEnv -> PlainCoreExpr -> (OutEnv,HaskExp)
-transformCoreExp _ (CoVar v) = (unitIdEnv v (1,True),HaskVar False v) -- lookup Env ?
-transformCoreExp _ (CoLit i) = (nullIdEnv,HaskLit i)
-transformCoreExp in_env (CoCon i _ atoms) = (out_env,HaskCon i hask_exps)
- where
- (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
-transformCoreExp in_env (CoPrim i _ atoms) = (out_env,HaskPrim i hask_exps)
- where
- (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
--- CoLam
--- CoTyLam
-transformCoreExp in_env (CoLam args exp) = (out_env,HaskLam args' h_exp)
- where -- modify the env !!!!!
- args' = [ mkHaskPatVar out_env v | v <- args ]
- (out_env,h_exp) = transformCoreExp in_env exp
-transformCoreExp in_env (CoTyLam _ exp) = transformCoreExp in_env exp
-transformCoreExp in_env (CoApp fun atom) = (merge o1 o2,HaskApp h_fun h_arg)
- where
- (o1,h_fun) = transformCoreExp in_env fun
- (o2,h_arg) = transformCoreExp in_env (atomToExpr atom)
-transformCoreExp in_env (CoTyApp fun _) = transformCoreExp in_env fun
-transformCoreExp in_env (CoCase e alts) = (foldl merge o1 o2,HaskCase h_e h_alts)
- where
- (o1,h_e) = transformCoreExp in_env e
- (o2,h_alts) = unzip [ (out_env,(pat,h_e)) | (out_env,pat,h_e) <- transformCoreAlts in_env alts ]
-
-transformCoreExp in_env exp@(CoLet _ _) = (o1,HaskLet h_binds h_exp)
- where
- (binds,exp') = getLets exp
- (in_env',o1,h_binds) = transformCoreBindings in_env o2 binds
- (o2,h_exp) = transformCoreExp in_env' exp'
- getLets (CoLet bind exp) = (bind:binds,exp')
- where (binds,exp') = getLets exp
- getLets exp = ([],exp)
-
-transformCoreExp _ _ = (nullIdEnv,HaskWild)
-
-transformCoreExps :: InEnv -> [PlainCoreExpr] -> (OutEnv,[HaskExp])
-transformCoreExps _ [] = (nullIdEnv,[])
-transformCoreExps in_env (e:es) = (merge o1 o2,h_e:hs_e)
- where
- (o1,h_e) = transformCoreExp in_env e
- (o2,hs_e) = transformCoreExps in_env es
-
-transformCoreAlts :: InEnv -> PlainCoreCaseAlternatives -> [(OutEnv,HaskExp,HaskExp)]
-transformCoreAlts in_env (CoAlgAlts alts def) = map trans alts ++ mkdef def
- where
- trans (id,ids,e) = (o1,HaskCon id (map (mkHaskPatVar o1) ids),h_e)
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef _ = []
-transformCoreAlts in_env (CoPrimAlts alts def) = map trans alts ++ mkdef def
- where
- trans (lit,e) = (o1,HaskLit lit,h_e)
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef _ = []
-\end{code}
-
-\begin{code}
-merge :: OutEnv -> OutEnv -> OutEnv
-merge e1 e2 = combineIdEnvs fn e1 e2
- where
- fn (n,_) (m,_) = (n+m,False)
-\end{code}
-
-
-\begin{code}
-mergeCasesBindings = map mergeCasesFun
-
-mergeCasesFun (HaskFun id rhss) = HaskFun id (concat (map mergeCasesRhs rhss))
-
-mergeCasesRhs (pats,exp) = [(pats,exp)]
-
-{-
-case v of
- A x -> e1 , v ==> Branch v [ (A x,e1), (B y,e2) ]
- B y -> e2 OR
- NoBranches (case v of
- A x -> ...
- B y -> ...)
-
--}
---mergeCases :: HaskExp -> Set Id -> [(Id,HaskExp,HaskExp)]
---mergeCases _ _ = []
-\end{code}
-
-
-
-Maybe ???
-
-type SM a = OutEnv Z
-returnSH a s = (a,s)
-thenSH m k s = case m s of
- (r,s') -> k r s
-thenSH_ m k s = case m s of
- (_,s') -> k s
-
-\begin{code}
-pprHaskFuns xs = ppAboves (map pprHaskFun xs)
-
-pprHaskFun (HaskFun id stuff) =
- ppAboves [
- ppSep [ ppCat ([ppr PprForUser id] ++ map (pprHaskExp True) pats),
- ppNest 2 (ppCat [ppStr "=",pprHaskExp False rhs])]
- | (pats,rhs) <- stuff]
-
-pprHaskExp :: Bool -> HaskExp -> Pretty
-pprHaskExp _ (HaskVar _ id) = ppr PprForUser id
-pprHaskExp _ (HaskLit i) = ppr PprForUser i
-pprHaskExp _ (HaskWild) = ppStr "_"
-pprHaskExp True exp = ppBesides [ppLparen,pprHaskExp False exp,ppRparen]
-pprHaskExp _ (HaskCon con []) | con == nilDataCon = ppStr "[]"
-pprHaskExp _ (HaskCon con [e1,e2]) | con == consDataCon =
- ppCat [pprHaskExp True e1,ppStr ":",pprHaskExp True e2]
-pprHaskExp _ (HaskCon con exps) =
- ppCat (ppr PprForUser con:map (pprHaskExp True) exps)
-pprHaskExp _ (HaskPrim prim exps) =
- ppCat (ppr PprForUser prim:map (pprHaskExp True) exps)
-pprHaskExp _ app@(HaskLam xs e) = -- \ xs -> e
- ppSep [ ppCat ([ppStr "\\"] ++ map (pprHaskExp True) xs),
- ppNest 2 (ppCat [ppStr "->",pprHaskExp False e])]
-pprHaskExp _ app@(HaskApp _ _) = pprHaskApp app
-pprHaskExp _ (HaskCase e opts)
- = ppAboves [ppCat [ppStr "case", pprHaskExp False e,ppStr "of"],
- ppNest 2 (
- ppAboves [
- (ppSep [ppCat [pprHaskExp False pat,ppStr "->"],
- ppNest 2 (pprHaskExp False exp)])
- | (pat,exp) <- opts])]
-pprHaskExp _ (HaskIf i t e) = ppAboves
- [ppCat [ppStr "if",pprHaskExp False i],
- ppCat [ppStr "then",pprHaskExp False t],
- ppCat [ppStr "else",pprHaskExp False e]]
-pprHaskExp _ (HaskLet binds e)
- = ppAboves [ppStr "let",
- ppNest 2 (pprHaskFuns binds),
- ppCat [ppStr "in",ppNest 1 (pprHaskExp False e)]]
-pprHaskExp _ _ = panic "pprHaskExp failed"
-
-
-pprHaskApp (HaskApp fun arg) = ppCat [pprHaskApp fun,pprHaskExp True arg]
-pprHaskApp e = pprHaskExp True e
-\end{code}
-
-
-
-pprHaskExp n exp = ppr
projects / ghc-hetmet.git / blobdiff