External Core lib: lots of cleanup

[ghc-hetmet.git] / utils / ext-core / Language / Core / CoreUtils.hs

diff --git a/utils/ext-core/Language/Core/CoreUtils.hs b/utils/ext-core/Language/Core/CoreUtils.hs
index afe4039..52d51f2 100644 (file)
--- a/utils/ext-core/Language/Core/CoreUtils.hs
+++ b/utils/ext-core/Language/Core/CoreUtils.hs
@@ -2,9 +2,13 @@ module Language.Core.CoreUtils where
 
 import Language.Core.Core
 import Language.Core.Utils
+import Language.Core.Printer()
+
+--import Debug.Trace
 
 import Data.Generics
 import Data.List
+import Data.Maybe
 
 splitDataConApp_maybe :: Exp -> Maybe (Qual Dcon, [Ty], [Exp])
 splitDataConApp_maybe (Dcon d) = Just (d, [], [])
@@ -56,11 +60,18 @@ vdefTys :: [Vdef] -> [Ty]
 vdefTys = map (\ (Vdef (_,t,_)) -> t)
 
 vdefgNames :: Vdefg -> [Var]
-vdefgNames (Rec vds) = map (\ (Vdef ((_,v),_,_)) -> v) vds
-vdefgNames (Nonrec (Vdef ((_,v),_,_))) = [v]
+vdefgNames = snd . unzip . vdefgNamesQ
+
+vdefgNamesQ :: Vdefg -> [Qual Var]
+vdefgNamesQ (Rec vds) = map (\ (Vdef (v,_,_)) -> v) vds
+vdefgNamesQ (Nonrec (Vdef (v,_,_))) = [v]
+
 vdefgTys :: Vdefg -> [Ty]
 vdefgTys (Rec vds) = map (\ (Vdef (_,t,_)) -> t) vds
 vdefgTys (Nonrec (Vdef (_,t,_))) = [t]
+vdefgBodies :: Vdefg -> [Exp]
+vdefgBodies (Rec vds) = map (\ (Vdef (_,_,e)) -> e) vds
+vdefgBodies (Nonrec (Vdef (_,_,e))) = [e]
 
 vbNames :: [Vbind] -> [Var]
 vbNames = fst . unzip
@@ -82,3 +93,120 @@ tdefNames = concatMap doOne
         doOne (Newtype qtc qtc1 _ _) = [qtc, qtc1]
         doCdef (Constr qdc _ _) = [qdc]
 
+tdefDcons :: [Tdef] -> [Qual Var]
+tdefDcons = concatMap doOne
+  where doOne (Data _ _ cds) = concatMap doCdef cds
+        doOne _ = []
+        doCdef (Constr qdc _ _) = [qdc]
+
+tdefTcons :: [Tdef] -> [Qual Var]
+tdefTcons = concatMap doOne
+  where doOne (Data qtc _ _) = [qtc]
+        doOne (Newtype qtc qtc1 _ _) = [qtc, qtc1]
+
+filterVdefgs :: (Vdef -> Bool) -> [Vdefg] -> [Vdefg]
+filterVdefgs ok = catMaybes . (map dropNames)
+  where dropNames (Nonrec v) | not (ok v) = Nothing
+        dropNames v@(Nonrec _) = Just v
+        dropNames (Rec bs) = case filter ok bs of
+           [] -> Nothing
+           newBs -> Just (Rec newBs)
+
+applyNewtype :: CoercionKind -> [Ty] -> (Ty,Ty)
+applyNewtype _d@(DefinedCoercion tbs (from,to)) tys = 
+  let (tvs,_) = unzip tbs in
+    let res = (substl tvs tys from,substl tvs tys to) in
+      -- trace ("co = " ++ show d ++ " args  = " ++ show tys ++ " res = " ++ show res) $
+        res
+
+{- Simultaneous substitution on types for type variables,
+   renaming as neceessary to avoid capture.
+   No checks for correct kindedness. -}
+substl :: [Tvar] -> [Ty] -> Ty -> Ty
+substl tvs ts t = f (zip tvs ts) t
+  where 
+    f env t0 =
+     case t0 of
+       Tcon _ -> t0
+       Tvar v -> case lookup v env of
+                   Just t1 -> t1
+                   Nothing -> t0
+       Tapp t1 t2 -> Tapp (f env t1) (f env t2)
+       Tforall (tv,k) t1 -> 
+         if tv `elem` free then
+           Tforall (t',k) (f ((tv,Tvar t'):env) t1)
+         else 
+          Tforall (tv,k) (f (filter ((/=tv).fst) env) t1)
+       TransCoercion t1 t2 -> TransCoercion (f env t1) (f env t2)
+       SymCoercion t1 -> SymCoercion (f env t1)
+       UnsafeCoercion t1 t2 -> UnsafeCoercion (f env t1) (f env t2)
+       LeftCoercion t1 -> LeftCoercion (f env t1)
+       RightCoercion t1 -> RightCoercion (f env t1)
+       InstCoercion t1 t2 -> InstCoercion (f env t1) (f env t2)
+     where free = foldr union [] (map (freeTvars.snd) env)
+           t' = freshTvar free 
+
+   
+{- Return free tvars in a type -}
+freeTvars :: Ty -> [Tvar]
+freeTvars (Tcon _) = []
+freeTvars (Tvar v) = [v]
+freeTvars (Tapp t1 t2) = freeTvars t1 `union` freeTvars t2
+freeTvars (Tforall (t,_) t1) = delete t (freeTvars t1) 
+freeTvars (TransCoercion t1 t2) = freeTvars t1 `union` freeTvars t2
+freeTvars (SymCoercion t) = freeTvars t
+freeTvars (UnsafeCoercion t1 t2) = freeTvars t1 `union` freeTvars t2
+freeTvars (LeftCoercion t) = freeTvars t
+freeTvars (RightCoercion t) = freeTvars t
+freeTvars (InstCoercion t1 t2) = freeTvars t1 `union` freeTvars t2
+
+{- Return any tvar *not* in the argument list. -}
+freshTvar :: [Tvar] -> Tvar
+freshTvar tvs = maximum ("":tvs) ++ "x" -- one simple way!
+
+splitLambda :: Exp -> ([Bind],Exp)
+splitLambda (Lam vb e) = case splitLambda e of
+  (vbs,rhs) -> (vb:vbs,rhs)
+splitLambda (Note _ e) = splitLambda e
+splitLambda e          = ([],e)
+
+vbinds :: [Bind] -> [(Var,Ty)]
+vbinds = foldl' stuff []
+  where stuff :: [(Var,Ty)] -> Bind -> [(Var,Ty)]
+        stuff rest (Tb _) = rest
+        stuff rest (Vb p) = p:rest
+
+splitBinds :: [Bind] -> ([(Tvar,Kind)],[(Var,Ty)])
+splitBinds = foldr stuff ([],[])
+  where stuff (Tb t) (tbs,vbs) = (t:tbs,vbs)
+        stuff (Vb v) (tbs,vbs) = (tbs,v:vbs)
+
+freeVars :: Exp -> [Qual Var]
+freeVars (Var v)                    = [v]
+freeVars (Dcon _)                   = []
+freeVars (Lit _)                    = []
+freeVars (App f g)                  = freeVars f `union` freeVars g
+freeVars (Appt e _)                 = freeVars e
+freeVars (Lam (Tb _) e)             = freeVars e
+freeVars (Lam (Vb (v,_)) e)         = delete (unqual v) (freeVars e)
+freeVars (Let (Nonrec (Vdef (v,_,rhs))) e) = freeVars rhs `union` (delete v (freeVars e))
+freeVars (Let r@(Rec _) e)         = (freeVars e \\ boundVars) `union` (freeVarss rhss \\ boundVars)
+  where boundVars = map unqual $ vdefgNames r
+        rhss      = vdefgBodies r
+freeVars (Case e (v,_) _ alts)      = freeVars e `union` (delete v1 (boundVarsAlts alts))
+  where v1 = unqual v
+        boundVarsAlts as = freeVarss rhss \\ (v1:caseVars)
+          where rhss = map (\ a -> case a of
+                             Acon _ _ _ r -> r
+                             Alit _ r     -> r
+                             Adefault r   -> r) as
+                caseVars = foldl' union [] (map (\ a -> case a of
+                                               Acon _ _ vbs _ ->
+                                                 (map unqual (fst (unzip vbs)))
+                                               _              -> []) as)
+freeVars (Cast e _)                 = freeVars e
+freeVars (Note _ e)                 = freeVars e
+freeVars (External {})              = []
+
+freeVarss :: [Exp] -> [Qual Var]
+freeVarss = foldl' union [] . map freeVars
\ No newline at end of file