+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