-- | 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])