changed names of resource-1.3; added a note on homepage on release

1 files changed, 0 insertions, 766 deletions

diff --git a/src-3.0/Transfer/SyntaxToCore.hs b/src-3.0/Transfer/SyntaxToCore.hs
deleted file mode 100644
index 32796eb50..000000000
--- a/src-3.0/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])