From a1da4b7c4808b3da1a0dba5a85b5e35134d9222c Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 26 Jun 2008 21:05:50 +0000 Subject: removed Transfer interpreter --- src/Transfer/SyntaxToCore.hs | 766 ------------------------------------------- 1 file changed, 766 deletions(-) delete mode 100644 src/Transfer/SyntaxToCore.hs (limited to 'src/Transfer/SyntaxToCore.hs') diff --git a/src/Transfer/SyntaxToCore.hs b/src/Transfer/SyntaxToCore.hs deleted file mode 100644 index 32796eb50..000000000 --- a/src/Transfer/SyntaxToCore.hs +++ /dev/null @@ -1,766 +0,0 @@ --- | Translate to the core language -module Transfer.SyntaxToCore where - -import Transfer.Syntax.Abs -import Transfer.Syntax.Print - -import Control.Monad.State -import Data.List -import Data.Maybe -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Monoid - -import Debug.Trace - -type C a = State CState a - -data CState = CState { - nextVar :: Integer, - nextMeta :: Integer - } - - - -declsToCore :: [Decl] -> [Decl] -declsToCore m = evalState (declsToCore_ m) newState - -declsToCore_ :: [Decl] -> C [Decl] -declsToCore_ = deriveDecls - >>> desugar - >>> compilePattDecls - >>> numberMetas - >>> replaceCons - >>> expandOrPatts - >>> optimize - -optimize :: [Decl] -> C [Decl] -optimize = uniqueVars - >>> removeUselessMatch - >>> betaReduce - -newState :: CState -newState = CState { - nextVar = 0, - nextMeta = 0 - } - - --- --- * Make all variable names unique --- - -uniqueVars :: [Decl] -> C [Decl] -uniqueVars = mapM (f Map.empty) - where - f :: Map Ident Ident -> Tree a -> C (Tree a) - f ss t = case t of - ELet ds _ -> - do - let vs = Set.toList (letDefBinds ds) - vs' <- freshIdents (length vs) - let ss' = addToSubstEnv (zip vs vs') ss - composOpM (f ss') t - LetDef i e -> - case Map.lookup i ss of - Nothing -> fail $ "let var " ++ printTree i ++ " not renamed" - Just i' -> liftM (LetDef i') (f ss e) - Case p _ _ -> - do - let vs = Set.toList (binds p) - vs' <- freshIdents (length vs) - let ss' = addToSubstEnv (zip vs vs') ss - composOpM (f ss') t - EAbs (VVar i) e -> - do - i' <- freshIdent - let ss' = addToSubstEnv [(i,i')] ss - liftM (EAbs (VVar i')) (f ss' e) - EPi (VVar i) e1 e2 -> - do - i' <- freshIdent - let ss' = addToSubstEnv [(i,i')] ss - liftM2 (EPi (VVar i')) (f ss e1) (f ss' e2) - EVar i -> return $ case Map.lookup i ss of - Nothing -> t -- constructor - Just i' -> EVar i' - PVar i -> return $ case Map.lookup i ss of - Nothing -> t -- constructor - Just i' -> PVar i' - _ -> composOpM (f ss) t - where addToSubstEnv bs m = foldr (\ (k,v) -> Map.insert k v) m bs - --- --- * Number meta variables --- - -numberMetas :: [Decl] -> C [Decl] -numberMetas = mapM f - where - f :: Tree a -> C (Tree a) - f t = case t of - EMeta -> do - st <- get - put (st { nextMeta = nextMeta st + 1}) - return $ EVar $ Ident $ "?" ++ show (nextMeta st) -- FIXME: hack - _ -> composOpM f t - - --- --- * Pattern equations --- - -compilePattDecls :: [Decl] -> C [Decl] -compilePattDecls [] = return [] -compilePattDecls (d@(ValueDecl x _ _ _):ds) = - do - let (xs,rest) = span (isValueDecl x) ds - d <- mergeDecls (d:xs) - rs <- compilePattDecls rest - return (d:rs) -compilePattDecls (d:ds) = liftM (d:) (compilePattDecls ds) - --- | Checks if a declaration is a value declaration --- of the given identifier. -isValueDecl :: Ident -> Decl -> Bool -isValueDecl x (ValueDecl y _ _ _) = x == y -isValueDecl _ _ = False - --- | Take a non-empty list of pattern equations with guards --- for the same function, and produce a single declaration. -mergeDecls :: [Decl] -> C Decl -mergeDecls ds@(ValueDecl x p _ _:_) - = do let cs = [ (ps,g,rhs) | ValueDecl _ ps g rhs <- ds ] - (pss,_,_) = unzip3 cs - n = length p - when (not (all ((== n) . length) pss)) - $ fail $ "Pattern count mismatch for " ++ printTree x - vs <- freshIdents n - let cases = map (\ (ps,g,rhs) -> Case (mkPTuple ps) g rhs) cs - c = ECase (mkETuple (map EVar vs)) cases - f = foldr (EAbs . VVar) c vs - return $ ValueDecl x [] GuardNo f - --- --- * Derived function definitions --- - -deriveDecls :: [Decl] -> C [Decl] -deriveDecls ds = liftM concat (mapM der ds) - where - ts = dataTypes ds - der (DeriveDecl (Ident f) t) = - case lookup f derivators of - Just d -> d t k cs - _ -> fail $ "Don't know how to derive " ++ f - where (k,cs) = getDataType ts t - der d = return [d] - -type Derivator = Ident -> Exp -> [(Ident,Exp)] -> C [Decl] - -derivators :: [(String, Derivator)] -derivators = [ - ("Compos", deriveCompos), - ("Show", deriveShow), - ("Eq", deriveEq), - ("Ord", deriveOrd) - ] - --- --- * Deriving instances of Compos --- - -deriveCompos :: Derivator -deriveCompos t@(Ident ts) k cs = - do - co <- deriveComposOp t k cs - cf <- deriveComposFold t k cs - let [c] = argumentTypes k -- FIXME: what if there is not exactly one argument to t? - d = Ident ("compos_"++ts) - dt = apply (var "Compos") [c, EVar t] - r = ERec [FieldValue (Ident "composOp") co, - FieldValue (Ident "composFold") cf] - return [TypeDecl d dt, ValueDecl d [] GuardNo r] - -deriveComposOp :: Ident -> Exp -> [(Ident,Exp)] -> C Exp -deriveComposOp t k cs = - do - f <- freshIdent - x <- freshIdent - let e = EVar - pv = VVar - infixr 3 \-> - (\->) = EAbs - mkCase ci ct = - do - vars <- freshIdents (arity ct) - -- FIXME: the type argument to f is wrong if the constructor - -- has a dependent type - -- FIXME: make a special case for lists? - let rec v at = case at of - EApp (EVar t') c | t' == t -> apply (e f) [c, e v] - _ -> e v - calls = zipWith rec vars (argumentTypes ct) - return $ Case (PCons ci (map PVar vars)) gtrue (apply (e ci) calls) - cases <- mapM (uncurry mkCase) cs - let cases' = cases ++ [Case PWild gtrue (e x)] - fb <- abstract (arity k) $ const $ pv f \-> pv x \-> ECase (e x) cases' - return fb - -deriveComposFold :: Ident -> Exp -> [(Ident,Exp)] -> C Exp -deriveComposFold t k cs = - do - f <- freshIdent - x <- freshIdent - b <- freshIdent - r <- freshIdent - let e = EVar - pv = VVar - infixr 3 \-> - (\->) = EAbs - mkCase ci ct = - do - vars <- freshIdents (arity ct) - -- FIXME: the type argument to f is wrong if the constructor - -- has a dependent type - -- FIXME: make a special case for lists? - let rec v at = case at of - EApp (EVar t') c | t' == t -> apply (e f) [c, e v] - _ -> e v - calls = zipWith rec vars (argumentTypes ct) - z = EProj (e r) (Ident "mzero") - p = EProj (e r) (Ident "mplus") - joinCalls [] = z - joinCalls cs = foldr1 (\x y -> apply p [x,y]) cs - return $ Case (PCons ci (map PVar vars)) gtrue (joinCalls calls) - cases <- mapM (uncurry mkCase) cs - let cases' = cases ++ [Case PWild gtrue (e x)] - fb <- abstract (arity k) $ const $ pv f \-> pv x \-> ECase (e x) cases' - return $ VWild \-> pv r \-> fb - --- --- * Deriving instances of Show --- - -deriveShow :: Derivator -deriveShow t k cs = fail $ "derive Show not implemented" - --- --- * Deriving instances of Eq --- - --- FIXME: how do we require Eq instances for all --- constructor arguments? - -deriveEq :: Derivator -deriveEq t@(Ident tn) k cs = - do - dt <- abstractType ats (EApp (var "Eq") . apply (EVar t)) - f <- mkEq - r <- abstract (arity k) (\_ -> ERec [FieldValue (Ident "eq") f]) - return [TypeDecl d dt, ValueDecl d [] GuardNo r] - where - ats = argumentTypes k - d = Ident ("eq_"++tn) - mkEq = do - x <- freshIdent - y <- freshIdent - cases <- mapM (uncurry mkEqCase) cs - let fc = Case PWild gtrue false - abstract 2 (\es -> ECase (mkETuple es) (cases++[fc])) - mkEqCase c ct = - do - let n = arity ct - ts = argumentTypes ct - vs1 <- freshIdents n - vs2 <- freshIdents n - let pr = mkPTuple [PCons c (map PVar vs1), PCons c (map PVar vs2)] - eqs = concat $ zipWith3 child_eq ts vs1 vs2 - rhs [] = true - rhs xs = foldr1 EAnd xs - return $ Case pr gtrue (rhs eqs) - -- FIXME: hack: this returns a list to skip testing type arguments. - child_eq EType _ _ = [] - child_eq t x y = [apply (var "eq") [t,eq_dict t, EVar x, EVar y]] - -- FIXME: this is a hack to at least support Tree types - eq_dict (EApp (EVar t') _) - | t' == t = apply (EVar d) (replicate (arity k) EMeta) - eq_dict (EVar (Ident x)) - | x `elem` ["String","Integer","Double"] = var ("eq_"++x) - eq_dict _ = EMeta - --- --- * Deriving instances of Ord --- - -deriveOrd :: Derivator -deriveOrd t k cs = fail $ "derive Ord not implemented" - --- --- * Constructor patterns and applications. --- - -type DataConsInfo = Map Ident Int - -consArities :: [Decl] -> DataConsInfo -consArities ds = Map.fromList [ (c, arity t) | DataDecl _ _ cs <- ds, - ConsDecl c t <- cs ] - --- | Get the arity of a function type. -arity :: Exp -> Int -arity = length . argumentTypes - --- | Get the argument type of a function type. Note that --- the returned types may contains free variables --- which should be bound to the values of earlier arguments. -argumentTypes :: Exp -> [Exp] -argumentTypes e = case e of - EPi _ t e' -> t : argumentTypes e' - EPiNoVar t e' -> t : argumentTypes e' - _ -> [] - --- | Fix up constructor patterns and applications. -replaceCons :: [Decl] -> C [Decl] -replaceCons ds = mapM (f cs) ds - where - cs = consArities ds - f :: DataConsInfo -> Tree a -> C (Tree a) - f cs x = case x of - -- get rid of the PConsTop hack - PConsTop id p1 ps -> f cs (PCons id (p1:ps)) - -- replace patterns C where C is a constructor with (C) - PVar id | isCons id -> return $ PCons id [] - -- don't eta-expand overshadowed constructors - EAbs (VVar id) e | isCons id -> - liftM (EAbs (VVar id)) (f (Map.delete id cs) e) - EPi (VVar id) t e | isCons id -> - liftM2 (EPi (VVar id)) (f cs t) (f (Map.delete id cs) e) - -- eta-expand constructors. betaReduce will remove any beta - -- redexes produced here. - EVar id | isCons id -> do - let Just n = Map.lookup id cs - abstract n (apply x) - _ -> composOpM (f cs) x - where isCons = (`Map.member` cs) - --- --- * Do simple beta reductions. --- - -betaReduce :: [Decl] -> C [Decl] -betaReduce = return . map f - where - f :: Tree a -> Tree a - f t = case t of - EApp e1 e2 -> - case (f e1, f e2) of - (EAbs (VVar x) b, e) | countFreeOccur x b == 1 -> f (subst x e b) - (e1',e2') -> EApp e1' e2' - _ -> composOp f t - --- --- * Remove useless pattern matching and variable binding. --- - -removeUselessMatch :: [Decl] -> C [Decl] -removeUselessMatch = return . map f - where - f :: Tree a -> Tree a - f x = case x of - EAbs (VVar x) b -> - case f b of - -- replace \x -> case x of { y | True -> e } with \y -> e, - -- if x is not free in e - ECase (EVar x') [Case (PVar y) g e] - | x' == x && isTrueGuard g && not (x `isFreeIn` e) - -> f (EAbs (VVar y) e) - -- replace unused variable in lambda with wild card - e | not (x `isFreeIn` e) -> f (EAbs VWild e) - e -> EAbs (VVar x) e - -- replace unused variable in pi with wild card - EPi (VVar x) t e -> - let e' = f e - v = if not (x `isFreeIn` e') then VWild else VVar x - in EPi v (f t) e' - -- replace unused variables in case patterns with wild cards - Case p (GuardExp g) e -> - let g' = f g - e' = f e - used = freeVars g' `Set.union` freeVars e' - p' = f (removeUnusedVarPatts used p) - in Case p' (GuardExp g') e' - -- for value declarations without patterns, compilePattDecls - -- generates pattern matching on the empty record, remove these - ECase (ERec []) [Case (PRec []) g e] | isTrueGuard g -> f e - -- if the pattern matching is on a single field of a record expression - -- with only one field, there is no need to wrap it in a record - ECase (ERec [FieldValue x e]) cs | all (isSingleFieldPattern x) (casePatterns cs) - -> f (ECase e [ Case p g r | Case (PRec [FieldPattern _ p]) g r <- cs ]) - -- for all fields in record matching where all patterns for the field just - -- bind variables, substitute in the field value (if it is a variable) - -- in the guards and right hand sides. - ECase (ERec fs) cs | all isPRec (casePatterns cs) -> - let h (FieldValue f v@(EVar _):fs) xs - | all (onlyBindsFieldToVariable f) (casePatterns xs) - = h fs (map (inlineField f v) xs) - h (f:fs) xs = let (fs',xs') = h fs xs in (f:fs',xs') - h [] xs = ([],xs) - inlineField f v (Case (PRec fps) (GuardExp g) e) = - let p' = PRec [fp | fp@(FieldPattern f' _) <- fps, f' /= f] - ss = zip (fieldPatternVars f fps) (repeat v) - in Case p' (GuardExp (substs ss g)) (substs ss e) - (fs',cs') = h fs cs - x' = ECase (ERec fs') cs' - in if length fs' < length fs then f x' else composOp f x' - -- Remove wild card patterns in record patterns - PRec fps -> PRec (map f (fps \\ wildcards)) - where wildcards = [fp | fp@(FieldPattern _ PWild) <- fps] - _ -> composOp f x - -isTrueGuard :: Guard -> Bool -isTrueGuard (GuardExp (EVar (Ident "True"))) = True -isTrueGuard GuardNo = True -isTrueGuard _ = False - -removeUnusedVarPatts :: Set Ident -> Tree a -> Tree a -removeUnusedVarPatts keep x = case x of - PVar id | not (id `Set.member` keep) -> PWild - _ -> composOp (removeUnusedVarPatts keep) x - -isSingleFieldPattern :: Ident -> Pattern -> Bool -isSingleFieldPattern x p = case p of - PRec [FieldPattern y _] -> x == y - _ -> False - -casePatterns :: [Case] -> [Pattern] -casePatterns cs = [p | Case p _ _ <- cs] - -isPRec :: Pattern -> Bool -isPRec (PRec _) = True -isPRec _ = False - --- | Checks if given pattern is a record pattern, and matches the field --- with just a variable, with a wild card, or not at all. -onlyBindsFieldToVariable :: Ident -> Pattern -> Bool -onlyBindsFieldToVariable f (PRec fps) = - all isVar [p | FieldPattern f' p <- fps, f == f'] - where isVar (PVar _) = True - isVar PWild = True - isVar _ = False -onlyBindsFieldToVariable _ _ = False - -fieldPatternVars :: Ident -> [FieldPattern] -> [Ident] -fieldPatternVars f fps = [p | FieldPattern f' (PVar p) <- fps, f == f'] - --- --- * Expand disjunctive patterns. --- - -expandOrPatts :: [Decl] -> C [Decl] -expandOrPatts = return . map f - where - f :: Tree a -> Tree a - f x = case x of - ECase e cs -> ECase (f e) (concatMap (expandCase . f) cs) - _ -> composOp f x - -expandCase :: Case -> [Case] -expandCase (Case p g e) = [ Case p' g e | p' <- expandPatt p ] - -expandPatt :: Pattern -> [Pattern] -expandPatt p = case p of - POr p1 p2 -> expandPatt p1 ++ expandPatt p2 - PCons i ps -> map (PCons i) $ expandPatts ps - PRec fps -> let (fs,ps) = unzip $ fromPRec fps - fpss = map (zip fs) (expandPatts ps) - in map (PRec . toPRec) fpss - _ -> [p] - -expandPatts :: [Pattern] -> [[Pattern]] -expandPatts [] = [[]] -expandPatts (p:ps) = [ p':ps' | p' <- expandPatt p, ps' <- expandPatts ps] - --- --- * Remove simple syntactic sugar. --- - -desugar :: [Decl] -> C [Decl] -desugar = return . map f - where - f :: Tree a -> Tree a - f x = case x of - PListCons p1 p2 -> pListCons <| p1 <| p2 - PEmptyList -> pList [] - PList xs -> pList [f p | CommaPattern p <- xs] - PTuple x xs -> mkPTuple [f p | CommaPattern p <- (x:xs)] - GuardNo -> gtrue - EIf exp0 exp1 exp2 -> ifBool <| exp0 <| exp1 <| exp2 - EDo bs e -> mkDo (map f bs) (f e) - BindNoVar exp0 -> BindVar VWild <| exp0 - EPiNoVar exp0 exp1 -> EPi VWild <| exp0 <| exp1 - EBind exp0 exp1 -> appBind <| exp0 <| exp1 - EBindC exp0 exp1 -> appBindC <| exp0 <| exp1 - EOr exp0 exp1 -> orBool <| exp0 <| exp1 - EAnd exp0 exp1 -> andBool <| exp0 <| exp1 - EEq exp0 exp1 -> overlBin "eq" <| exp0 <| exp1 - ENe exp0 exp1 -> overlBin "ne" <| exp0 <| exp1 - ELt exp0 exp1 -> overlBin "lt" <| exp0 <| exp1 - ELe exp0 exp1 -> overlBin "le" <| exp0 <| exp1 - EGt exp0 exp1 -> overlBin "gt" <| exp0 <| exp1 - EGe exp0 exp1 -> overlBin "ge" <| exp0 <| exp1 - EListCons exp0 exp1 -> appCons <| exp0 <| exp1 - EAdd exp0 exp1 -> overlBin "plus" <| exp0 <| exp1 - ESub exp0 exp1 -> overlBin "minus" <| exp0 <| exp1 - EMul exp0 exp1 -> overlBin "times" <| exp0 <| exp1 - EDiv exp0 exp1 -> overlBin "div" <| exp0 <| exp1 - EMod exp0 exp1 -> overlBin "mod" <| exp0 <| exp1 - ENeg exp0 -> overlUn "neg" <| exp0 - EEmptyList -> mkList [] - EList exps -> mkList (map f exps) - ETuple exp1 exps -> mkETuple (map f (exp1:exps)) - _ -> composOp f x - where g <| x = g (f x) - --- --- * List patterns --- - -pListCons :: Pattern -> Pattern -> Pattern -pListCons p1 p2 = PCons (Ident "Cons") [PWild,p1,p2] - -pList :: [Pattern] -> Pattern -pList = foldr pListCons (PCons (Ident "Nil") [PWild]) - --- --- * Use an overloaded function. --- - -overlUn :: String -> Exp -> Exp -overlUn f e1 = apply (EVar (Ident f)) [EMeta,EVar (Ident "num_Integer"),e1] -- FIXME: hack, should be ? - -overlBin :: String -> Exp -> Exp -> Exp -overlBin f e1 e2 = apply (EVar (Ident f)) [EMeta,EVar (Ident "num_Integer"),e1,e2] -- FIXME: hack, should be ? - --- --- * Monad --- - -mkDo :: [Bind] -> Exp -> Exp -mkDo bs e = foldr (\ (BindVar v r) x -> appBind r (EAbs v x)) e bs - -appBind :: Exp -> Exp -> Exp -appBind e1 e2 = apply (EVar (Ident "bind")) [EMeta,EMeta,EMeta,EMeta,e1,e2] - -appBindC :: Exp -> Exp -> Exp -appBindC e1 e2 = appBind e1 (EAbs VWild e2) - --- --- * List --- - -mkList :: [Exp] -> Exp -mkList = foldr appCons (EApp (EVar (Ident "Nil")) EMeta) - -appCons :: Exp -> Exp -> Exp -appCons e1 e2 = apply (EVar (Ident "Cons")) [EMeta,e1,e2] - - --- --- * Booleans --- - -andBool :: Exp -> Exp -> Exp -andBool e1 e2 = ifBool e1 e2 false - -orBool :: Exp -> Exp -> Exp -orBool e1 e2 = ifBool e1 true e2 - -ifBool :: Exp -> Exp -> Exp -> Exp -ifBool c t e = ECase c [Case (PCons (Ident "True") []) gtrue t, - Case (PCons (Ident "False") []) gtrue e] - - --- --- * Substitution --- - -subst :: Ident -> Exp -> Exp -> Exp -subst x e = substs [(x,e)] - - - --- | Simultaneuous substitution -substs :: [(Ident, Exp)] -> Exp -> Exp -substs ss = f (Map.fromList ss) - where - f :: Map Ident Exp -> Tree a -> Tree a - f ss t | Map.null ss = t - f ss t = case t of - EVar i -> Map.findWithDefault t i ss - _ -> composOp (f ss) t - - -{- --- not needed now that variable names are unique --- FIXE: this function does not properly rename bound variables -substs :: [(Ident, Exp)] -> Exp -> Exp -substs ss = f (Map.fromList ss) - where - f :: Map Ident Exp -> Tree a -> Tree a - f ss t | Map.null ss = t - f ss t = case t of - ELet ds e3 -> - ELet [LetDef id (f ss' e2) | LetDef id e2 <- ds] (f ss' e3) - where ss' = ss `mapMinusSet` letDefBinds ds - Case p g e -> Case p (f ss' g) (f ss' e) where ss' = ss `mapMinusSet` binds p - EAbs (VVar id) e -> EAbs (VVar id) (f ss' e) where ss' = Map.delete id ss - EPi (VVar id) e1 e2 -> - EPi (VVar id) (f ss e1) (f ss' e2) where ss' = Map.delete id ss - EVar i -> Map.findWithDefault t i ss - _ -> composOp (f ss) t --} - --- --- * Abstract syntax utilities --- - -var :: String -> Exp -var s = EVar (Ident s) - -true :: Exp -true = var "True" - -false :: Exp -false = var "False" - -gtrue :: Guard -gtrue = GuardExp true - - -mkETuple :: [Exp] -> Exp -mkETuple = ERec . zipWith (\i -> FieldValue (Ident ("p"++show i))) [1..] - -mkPTuple :: [Pattern] -> Pattern -mkPTuple = PRec . zipWith (\i -> FieldPattern (Ident ("p"++show i))) [1..] - --- | Apply an expression to a list of arguments. -apply :: Exp -> [Exp] -> Exp -apply = foldl EApp - --- | Abstract a value over some arguments. -abstract :: Int -- ^ number of arguments - -> ([Exp] -> Exp) -> C Exp -abstract n f = - do - vs <- freshIdents n - return $ foldr EAbs (f (map EVar vs)) (map VVar vs) - --- | Abstract a type over some arguments. -abstractType :: [Exp] -- ^ argument types - -> ([Exp] -> Exp) -- ^ function from variable expressions - -- to the expression to return - -> C Exp -abstractType ts f = - do - vs <- freshIdents (length ts) - let pi (v,t) e = EPi (VVar v) t e - return $ foldr pi (f (map EVar vs)) (zip vs ts) - --- | Get an identifier which cannot occur in user-written --- code, and which has not been generated before. -freshIdent :: C Ident -freshIdent = do - st <- get - put (st { nextVar = nextVar st + 1 }) - return (Ident ("x_"++show (nextVar st))) - -freshIdents :: Int -> C [Ident] -freshIdents n = replicateM n freshIdent - --- | Get the variables bound by a set of let definitions. -letDefBinds :: [LetDef] -> Set Ident -letDefBinds defs = Set.fromList [ id | LetDef id _ <- defs] - -letDefRhss :: [LetDef] -> [Exp] -letDefRhss defs = [ exp | LetDef _ exp <- defs ] - --- | Get the free variables in an expression. -freeVars :: Exp -> Set Ident -freeVars = f - where - f :: Tree a -> Set Ident - f t = case t of - ELet defs exp -> - Set.unions (f exp:map f (letDefRhss defs)) Set.\\ letDefBinds defs - ECase exp cases -> f exp `Set.union` - Set.unions [(f g `Set.union` f e) Set.\\ binds p - | Case p g e <- cases] - EAbs (VVar id) exp -> Set.delete id (f exp) - EPi (VVar id) exp1 exp2 -> f exp1 `Set.union` Set.delete id (f exp2) - EVar i -> Set.singleton i - _ -> composOpMonoid f t - -isFreeIn :: Ident -> Exp -> Bool -isFreeIn x e = countFreeOccur x e > 0 - --- | Count the number of times a variable occurs free in an expression. -countFreeOccur :: Ident -> Exp -> Int -countFreeOccur x = f - where - f :: Tree a -> Int - f t = case t of - ELet defs _ | x `Set.member` letDefBinds defs -> 0 - Case p _ _ | x `Set.member` binds p -> 0 - EAbs (VVar id) _ | id == x -> 0 - EPi (VVar id) exp1 _ | id == x -> f exp1 - EVar id | id == x -> 1 - _ -> composOpFold 0 (+) f t - --- | Get the variables bound by a pattern. -binds :: Pattern -> Set Ident -binds = f - where - f :: Tree a -> Set Ident - f p = case p of - -- replaceCons removes non-variable PVars - PVar id -> Set.singleton id - _ -> composOpMonoid f p - - -fromPRec :: [FieldPattern] -> [(Ident,Pattern)] -fromPRec fps = [ (l,p) | FieldPattern l p <- fps ] - -toPRec :: [(Ident,Pattern)] -> [FieldPattern] -toPRec = map (uncurry FieldPattern) - --- --- * Data types --- - -type DataTypes = Map Ident (Exp,[(Ident,Exp)]) - --- | Get a map of data type names to the type of the type constructor --- and all data constructors with their types. -dataTypes :: [Decl] -> Map Ident (Exp,[(Ident,Exp)]) -dataTypes ds = Map.fromList [ (i,(t,[(c,ct) | ConsDecl c ct <- cs])) | DataDecl i t cs <- ds] - -getDataType :: DataTypes -> Ident -> (Exp,[(Ident,Exp)]) -getDataType ts i = - case Map.lookup i ts of - Just t -> t - Nothing -> error $ "Data type " ++ printTree i ++ " not found." - ++ " Known types: " ++ show (Map.keysSet ts) - --- --- * Utilities --- - -infixl 1 >>> - -(>>>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c -f >>> g = (g =<<) . f - -mapMinusSet :: Ord k => Map k a -> Set k -> Map k a -mapMinusSet m s = m Map.\\ (Map.fromList [(x,()) | x <- Set.toList s]) -- cgit v1.2.3