diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Neil Mitchell 2006-2010.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Neil Mitchell nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Main.hs b/Main.hs
new file mode 100644
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,58 @@
+
+module Main where
+
+import Supercompile
+import Type
+import Simplify
+import Util
+
+import Control.Monad
+import Language.Haskell.Exts
+import System.Environment
+import System.FilePath
+import Data.List
+import System.Cmd
+import System.Directory
+import System.Exit
+import Control.Exception
+import Language.Preprocessor.Cpphs
+import System.IO.Unsafe
+
+
+main = do
+    xs <- getArgs
+    let (opts,files) = partition ("-" `isPrefixOf`) xs
+    forM_ files $ \x -> do
+        let y = dropExtension x <.> "opt.hs"
+        src <- readFile x
+        let res = fleshOut src $ prettyPrint $ toHSE $ supercompile $ env $ simplifyProg $ fromHSE $
+                        fromParseResult $ parseFileContents $ cpphs ["SUPERO"] src
+        when ("--only" `notElem` opts) $ do
+            timer $ writeFile y res
+        when ("--compile" `elem` opts) $ do
+            withDirectory (takeDirectory x) $ do
+                timer $ system_ $ "ghc --make -O2 " ++ takeFileName y ++ " -ddump-simpl > " ++ takeFileName y ++ ".log"
+                system_ $ "ghc --make -O2 " ++ takeFileName x ++ " -ddump-simpl -cpp -DMAIN -DMAIN_GHC > " ++ takeFileName x ++ ".log"
+
+-- not unsafe since no include files
+cpphs :: [String] -> String -> String
+cpphs defs = unsafePerformIO . runCpphs defaultCpphsOptions{defines=map (flip (,) "1") defs} ""
+
+
+withDirectory new act = do
+    old <- getCurrentDirectory
+    bracket_
+        (setCurrentDirectory new)
+        (setCurrentDirectory old)
+        act
+
+
+system_ cmd = do
+    putStrLn cmd
+    res <- system cmd
+    when (res /= ExitSuccess) $ error "system command failed"
+
+
+fleshOut :: String -> String -> String
+fleshOut orig new = "{-# OPTIONS_GHC -O2 #-}\nmodule Main(main) where\n" ++ f "IMPORT_SUPERO" ++ f "MAIN" ++ f "MAIN_SUPERO" ++ new ++ "\n\n"
+    where f x = unlines $ takeWhile (/= "#endif") $ drop 1 $ dropWhile (/= ("#if " ++ x)) $ lines orig
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Simplify.hs b/Simplify.hs
new file mode 100644
--- /dev/null
+++ b/Simplify.hs
@@ -0,0 +1,484 @@
+{-# LANGUAGE PatternGuards #-}
+
+module Simplify(simplify, simplifyProg) where
+
+import Util
+import Type
+import Control.Arrow
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Control.Monad
+import Control.Monad.State
+import Data.Maybe
+import Data.List
+import Data.Generics.Uniplate.Data
+import Debug.Trace
+
+
+simplifyProg :: [(Var,Exp)] -> [(Var,Exp)]
+simplifyProg = inlineVars . map (second $ transform simplify)
+
+
+
+inlineVars :: [(Var,Exp)] -> [(Var,Exp)]
+inlineVars xs = [(v, subst sub e) | (v,e) <- xs]
+    where sub = [(v,e) | (v,x) <- xs, Just e <- [f x]]
+          f (App _ x []) = g x
+          f (Let _ [] x) = g x
+          f _ = Nothing
+          g v = case lookup v xs of
+                    Just x -> f x `mplus` Just v
+                    Nothing -> Just v
+
+
+
+-- We run relabel 3 times:
+-- first time round gives unique names
+-- then we simplify (assuming unique names)
+-- second time round does GC
+-- third time round does variable normalisation
+simplify :: Exp -> Exp
+simplify = fixEq simplify1
+
+simplify1 x = f "v" $ f "_2" $ runFreshExp "_1" x $ skipLam reduce =<< relabel Map.empty x
+    where f s x = runFreshExp s x $ relabel Map.empty x
+
+
+runFreshExp :: String -> Exp -> Fresh a -> a
+runFreshExp v x act = runFresh v $ filterFresh (`notElem` free x) >> act
+
+
+skipLam :: (Exp -> Fresh Exp) -> Exp -> Fresh Exp
+skipLam f (Lam n v x) = fmap (Lam n v) $ skipLam f x
+skipLam f x = f x
+
+
+---------------------------------------------------------------------
+-- RELABEL
+
+-- relabel, normalise the order of let bindings, and do a GC pass over unused let expressions
+relabel :: Map.Map Var Var -> Exp -> Fresh Exp
+relabel ren (Lam n v x) = do
+    v2 <- fresh
+    fmap (Lam n v2) $ relabel (Map.insert v v2 ren) x
+
+-- let does the actual GC and reorder
+relabel ren (Let n xs v) = do
+    xs <- return $ rebind v xs
+    vs2 <- freshN $ length xs
+    ren <- return $ Map.fromList (zip (map fst xs) vs2) `Map.union` ren
+    let v2 = relabelVar ren v
+    xs2 <- mapM (f ren) (zip vs2 $ map snd xs)
+    case xs2 of
+        [(w2,y2)] | w2 == v2 -> return y2
+        _ -> return $ Let n xs2 v2  
+    where
+        f ren (v,x) = fmap ((,) v) $ relabel ren x
+
+relabel ren (Case n v xs) = do
+    fmap (Case n $ relabelVar ren v) $ mapM (f ren) xs
+    where
+        f ren (Con n c vs,b) = do
+            vs2 <- freshN $ length vs
+            ren <- return $ Map.fromList (zip vs vs2) `Map.union` ren
+            fmap ((,) $ Con n c vs2) $ relabel ren b
+        f ren (App n v [],b) = do
+            v2 <- fresh
+            fmap ((,) $ App n v2 []) $ relabel (Map.insert v v2 ren) b
+
+relabel ren (App n v1 v2) = return $ App n (relabelVar ren v1) (map (relabelVar ren) v2)
+relabel ren (Con n c vs) = return $ Con n c $ map (relabelVar ren) vs
+
+relabelVar ren v = Map.findWithDefault v v ren
+
+
+-- put in order, and do a GC
+rebind :: Var -> [(Var,Exp)] -> [(Var,Exp)]
+rebind v xs | v `notElem` map fst xs = []
+            | otherwise = [(a, fromJustNote "rebind" $ lookup a xs) | a <- order [] $ need [v]]
+    where
+        -- (a,b) means a relies on b
+        pairs = [(a,b) | (a,b) <- xs, b <- free b, b `elem` map fst xs]
+
+        need seen = if null next then seen else need (seen++next)
+            where next = [b | (a,b) <- pairs, a `elem` seen, b `notElem` seen]
+
+        order done [] = done
+        order done todo = if null a then error "rebind circle" else order (done++a) b
+            where (a,b) = partition f todo
+                  f x = all (\(a,b) -> a /= x || b `elem` done) pairs
+
+
+---------------------------------------------------------------------
+-- REDUCE
+
+-- reduce, assuming that let variables are sorted by order of use
+-- i.e. will only depend on variables defined after you
+reduce :: Exp -> Fresh Exp
+reduce (Let n xs v) = do
+    xs2 <- f [] xs
+    return $ case lookup v xs2 of
+        Just (App _ v2 []) -> Let n xs2 v2
+        _ -> Let n xs2 v
+    where
+        f :: [(Var,Exp)] -> [(Var,Exp)] -> Fresh [(Var,Exp)]
+        f done ((v,e):odo)
+            | App n v2 [] <- e =
+                let g xs = [(a,subst [(v,v2)] b) | (a,b) <- xs]
+                in f ((v,e) : g done) (g odo) -- FIXME: This stage may not generate a fixed point!!!
+            | Let n xs v2 <- e = f done (reverse xs ++ [(v,App n v2 [])] ++ odo)
+            | App n v1 (v2:vs) <- e, Just e2@Lam{} <- lookup v1 done = do
+                Lam _ v3 e3 <- relabel Map.empty e2
+                v4 <- fresh
+                f done ((v4, subst [(v3,v2)] e3):(v,App n v4 vs):odo)
+            | App _ v1 v2 <- e, Just e2@(Con n c vs) <- lookup v1 done = do
+                f done ((v,Con n c (vs++v2)):odo)
+            | App _ v1 v2 <- e, Just e2@(App n v3 vs) <- lookup v1 done, Just a <- arity v3, a >= length (v2 ++ vs) =
+                f done ((v,App n v3 (vs++v2)):odo)
+            | Case n v2 alts <- e, Just (Con _ c vs) <- lookup v2 done =
+                let pick (Con _ c2 vs2, x) | c == c2 = [subst (zip vs2 vs) x]
+                    pick (App _ vm [], x) | c `notElem` smallCtors = [subst [(vm,v2)] x]
+                    pick _ = []
+                    r = head $ concatMap pick alts ++ error
+                            ("confused, no case match...\n" ++ show n ++ "\n" ++ pretty (Con noname c vs) ++ "\n" ++ pretty e)
+                in f done ((v,r):odo)
+            | otherwise = f ((v,e):done) odo
+        f done [] = return done
+
+
+reduce x = return x
+
+
+
+smallCtors = ["Nothing","Just","True","False","(:)","[]",":"]
+
+
+
+
+{-
+
+removeNestedLet :: Exp -> Exp
+removeNestedLet 
+    
+
+
+
+
+
+data SSimp = SSimp {sFresh :: [Var], sBind :: Map.Map Var (Maybe Var, Maybe Exp)}
+
+simp :: Exp -> Exp
+simp x = flip evalState s0 $ do
+        let FlatExp free bind v = toFlat x
+        let free2 = take (length free) $ freshVars 'w'
+        modify $ \s -> s{sBind = Map.insert [] (Nothing, Just $ Let bind v) $ Map.fromList [([a],(Just b,Nothing)) | (a,b) <- zip free free2]}
+        v2 <- var []
+        bind <- gets fromBind
+        return $ fromFlat $ FlatExp (map snd ws) (sortOn fst [(a,b) | (Just a,Just b) <- Map.elems bind]) v2
+    where
+        s0 = SSimp (freshVars 'v') Map.empty
+
+        -- bind a variable, find out where you put it
+        var :: [Var] -> State SSimp Var
+        var v = do
+            s <- gets sBind
+            case s Map.! v of
+                (Just v2, _) -> return v2
+                (Nothing, Just e) -> do
+                    v2 <- fresh
+                    e2 <- ren resolve e
+                    op <- look
+                    e3 <- return $ fuse look e2
+                    modify $ \s -> s
+
+                    case force of
+
+
+
+
+
+
+
+
+-- rename a variable, calling the function on all unbound
+-- and giving fresh names to all bound
+ren :: FreshState s => (Var -> State s (Maybe Var)) -> Exp -> State s Exp
+ren = undefined
+
+
+
+
+
+
+
+
+
+
+
+
+
+simplify1 = fromNest . second renest . toNest
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+data Nest = Nest [(Var, Nest)] Exp deriving Show
+
+
+
+-- convert to the new representation
+toNest :: Exp -> ([Var], Nest)
+toNest (Lam _ v x) = (v:a,b)
+    where (a,b) = toNest x
+toNest x = ([], f x)
+    where
+        f (Let _ xs y) = Nest (map (second f) xs) (Var noname y)
+        f x = Nest [] x
+
+
+
+-- optimise the nested function
+renest :: Nest -> Nest
+renest x = x
+
+
+
+data SFrom = SFrom {fromFresh :: [Var], fromBind :: Map.Map [Var] (Maybe Var, Maybe Exp)}
+
+instance FreshState SFrom where
+    getFresh = fromFresh
+    setFresh x vs = x{fromFresh=vs}
+
+
+-- convert back, doing the relabelling
+-- should also drop all irrelevant ones
+fromNest :: ([Var], Nest) -> Exp
+fromNest (vs,x) = flip evalState (SFrom (freshVars 'v') Map.empty) $ do
+        let ws = zip vs $ freshVars 'w'
+        modify $ \s -> s{fromBind = Map.fromList [([a], (Just b, Nothing)) | (a,b) <- ws]}
+        populate [] x
+        r2 <- var []
+        bind <- gets fromBind
+        return $ fromFlat $ FlatExp (map snd ws) (sortOn fst [(a,b) | (Just a,Just b) <- Map.elems bind]) r2
+    where
+        populate :: [Var] -> Nest -> State SFrom ()
+        populate v (Nest xs y) = do
+            modify $ \s -> s{fromBind = Map.insert v (Nothing,Just y) $ fromBind s}
+            sequence_ [populate (v++[a]) b | (a,b) <- xs]
+
+
+        -- assign a new variable, or look up existing one
+        var :: [Var] -> State SFrom Var
+        var v = do
+            s <- get
+            let op = resolve (Map.keysSet $ fromBind s) v
+            case Map.findWithDefault (error $ "don't know about variable: " ++ show v) v (fromBind s) of
+                (Just v2, _) -> return v2
+                (_, Just (Var _ v)) -> maybe (return v) var $ op v
+                (_, Just e) -> do
+                    v2 <- fresh
+                    e <- exp op e
+                    modify $ \s -> s{fromBind=Map.insert v (Just v2, Just e) $ fromBind s}
+                    return v2
+
+
+        -- process an expression, given a way to resolve variables
+        exp :: (Var -> Maybe [Var]) -> Exp -> State SFrom Exp
+        exp op = f Map.empty
+            where
+                f :: Map.Map Var Var -> Exp -> State SFrom Exp
+                f _ x | trace (pretty x) False = undefined
+                f ren (Var n v1) = liftM (Var n) (g ren v1)
+                f ren (App n v1 v2) = liftM2 (App n) (g ren v1) (g ren v2)
+                f ren (Con n c vs) = liftM (Con n c) (mapM (g ren) vs)
+                f ren (Case n v1 as) = liftM2 (Case n) (g ren v1) (mapM (h ren) as)
+                f ren (Let n vs v1) = do
+                    vs2 <- freshN $ length vs
+                    let ren2 = Map.fromList (zip (map fst vs) vs2) `Map.union` ren
+                    bs <- sequence [liftM2 (,) (g ren2 a) (f ren2 b) | (a,b) <- vs]
+                    liftM (Let n bs) (g ren v1)
+                f ren (Lam n v x) = do
+                    x2 <- f ren x
+                    liftM (Lam n v) $ return x2
+{-                    v2 <- fresh
+                    res <- liftM (Lam n v2) $ f (Map.insert v v2 ren) x
+                    -- res <- {- liftM (Lam n v2) -} (f ren {- (Map.insert v v2 ren) -} x)
+                    return res -}
+                f ren x = error $ "fromNest.exp: " ++ show x
+
+                h :: Map.Map Var Var -> (Pat, Exp) -> State SFrom (Pat, Exp)
+                h ren (Con n c vs,y) = do
+                    vs2 <- freshN $ length vs
+                    y <- f (Map.fromList (zip vs vs2) `Map.union` ren) y
+                    return (Con n c vs2, y)
+                
+                g :: Map.Map Var Var -> Var -> State SFrom Var
+                g ren v = case (Map.lookup v ren, op v) of
+                    (Just v2, _) -> return v2
+                    (_, Just v2) -> var v2
+                    _ -> return v
+
+
+        -- resolve a variable
+        resolve :: Set.Set [Var] -> [Var] -> Var -> Maybe [Var]
+        resolve set root x = listToMaybe [b | a <- reverse $ inits root, let b = a ++ [x], b `Set.member` set]
+
+-}
+
+
+
+{-
+
+
+---------------------------------------------------------------------
+-- EXPRESSION ROOTS
+
+data ExpRoot = ExpRoot [Var] Var (Map.Map Var Exp)
+
+
+toRoot :: Exp -> ExpRoot
+toRoot = f []
+    where
+        f vs (Lam _ v x) = f (vs++[v]) x
+        f vs (Let _ xs v) = ExpRoot vs v (Map.fromList xs)
+        f vs x = f vs $ Let noname [("_letvar",x)] "_letvar"
+
+
+fromRoot :: ExpRoot -> Exp
+fromRoot (ExpRoot vs v xs) = lams vs $ Let noname (Map.toList xs) v
+
+
+---------------------------------------------------------------------
+-- REDUCE
+
+-- all the bound redexes must be fully simple
+-- none of the expressions may have a root let statement
+
+data SReduce = SReduce {reduceNew :: Map.Map Var Exp}
+
+reduce :: ExpRoot -> ExpRoot
+reduce (ExpRoot free root mp) = flip evalState (SReduce Map.empty) $ do
+    mapM_ var $ Map.keys mp
+    fmap (ExpRoot free root) $ gets reduceNew
+    where
+        simp :: Var -> Exp -> State SReduce Exp
+        simp v x = do
+            x <- redex x
+            modify $ \s -> s{reduceNew = Map.insert v x $ reduceNew s}
+            return x
+
+        var :: Var -> State SReduce Exp
+        var v = do
+            new <- gets reduceNew
+            case (Map.lookup v new, Map.lookup v mp) of
+                (Just y, _) -> return y
+                (_, Nothing) -> return $ Var noname v
+                (_, Just x) -> simp v x
+
+        redex :: Exp -> State SReduce Exp
+        redex (Var _ v) = var v
+        redex (Let _ vs x) = do
+            mapM_ (uncurry simp) vs
+            var x
+        redex o@(App _ v y) = do
+            x <- var v
+            case x of
+                Con n c xs -> return $ Con (incName n) c $ xs ++ [y]
+                _ -> return o
+        redex o@(Case _ v alts) = do
+            x <- var v
+            case x of
+                Con{} -> return $ head $ concatMap (f x) alts
+                _ -> return o
+            where f (Con _ c vs) (Con _ c2 vs2, x) | c == c2 = [Let noname (("_letvar",x): zip vs2 (map (Var noname) vs)) "_letvar"]
+                  f _ (Var{}, x) = [x]
+                  f _ _ = []
+        redex x = return x
+
+
+---------------------------------------------------------------------
+-- RELABEL
+
+-- do a GC, variable normalisation, variable flattening
+
+data SRelabel = SRelabel {relabelOld :: Map.Map Var Var, relabelNew :: Map.Map Var Exp, relabelVars :: [Var]}
+
+relabel :: ExpRoot -> ExpRoot
+relabel (ExpRoot free root mp) = flip evalState s0 $ do
+    root2 <- move root
+    old <- gets relabelOld
+    free2 <- return [Map.findWithDefault "_" x old | x <- free]
+    fmap (ExpRoot free2 root2) $ gets relabelNew
+    where
+        s0 = SRelabel Map.empty Map.empty ['v':show i | i <- [1..]]
+        fresh = do v:vs <- gets relabelVars ; modify $ \s -> s{relabelVars=vs} ; return v
+        freshN n = replicateM n fresh
+
+        rename x y = modify $ \s -> s{relabelOld = Map.insert x y $ relabelOld s}
+        record x y = modify $ \s -> s{relabelNew = Map.insert x y $ relabelNew s}
+
+        move v = do
+            old <- gets relabelOld
+            case (Map.lookup v old, Map.lookup v mp) of
+                (Just y, _) -> return y
+                (_, Nothing) | v `elem` free -> do y <- fresh; rename v y; return y
+                             | otherwise -> return v
+                (_, Just (Var _ y)) -> move y
+                (_, Just x) -> do
+                    y <- fresh
+                    rename v y
+                    x <- f Map.empty x
+                    record y x
+                    return y
+
+        f mp (App n x y) = liftM2 (App n) (var mp x) (var mp y)
+        f mp (Case n x xs) = liftM2 (Case n) (var mp x) (mapM (alt mp) xs)
+        f mp (Con n c xs) = liftM (Con n c) $ mapM (var mp) xs
+        f mp (Var n x) = liftM (Var n) (var mp x)
+        f mp (Let n vxs x) = do
+            let (vs,xs) = unzip vxs
+            vs2 <- replicateM (length vs) fresh
+            xs2 <- mapM (f mp) xs
+            x2 <- var (Map.fromList (zip vs vs2) `Map.union` mp) x
+            return $ Let n (zip vs2 xs2) x2
+
+        alt mp (Con n c vs, x) = do
+            vs2 <- replicateM (length vs) fresh
+            x2 <- f (Map.fromList (zip vs vs2) `Map.union` mp) x
+            return (Con n c vs2, x2)
+        alt mp (v, x) = fmap ((,) v) $ f mp x
+
+        var mp v = case Map.lookup v mp of
+            Nothing -> move v
+            Just y -> return y
+
+-}
diff --git a/Supercompile.hs b/Supercompile.hs
new file mode 100644
--- /dev/null
+++ b/Supercompile.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE PatternGuards #-}
+
+{-
+TODO:
+cheaps are merged multiple times, should do sharing by list of variables, then only reify
+at the end so can merge two cheaps which are then merged.
+-}
+
+module Supercompile(supercompile) where
+
+import Type
+import Simplify
+import Terminate
+import Util
+import Data.List
+import Data.Maybe
+import Control.Arrow
+import Data.Generics.Uniplate.Data hiding (children)
+
+---------------------------------------------------------------------
+-- MANAGER
+
+data Tree = Tree {pre :: Exp, gen :: [Var] -> Exp, children :: [Tree]}
+
+
+supercompile :: Env -> [(Var,Exp)]
+supercompile env = resetTime $ assign $ flatten $ optimise env $ fromJustNote "can't find root" $ env "root"
+
+
+optimise :: Env -> Exp -> Tree
+optimise env = f newHistory
+    where  f t x -- | trace (prettyNames x) False = undefined
+                 -- | progress t "optimse" = undefined
+                 | terminate (<=|) t x = g x (stop t x) t
+                 | otherwise = g x (reduce env x) (x += t)
+           g x ~(gen,cs) t = {- trace (pretty $ gen (repeat "call")) $ -} Tree x gen (map (f t) cs)
+
+
+reduce :: Env -> Exp -> ([Var] -> Exp, [Exp])
+reduce env = f newHistory
+    where f t x -- | progress t "reduce" = undefined
+                | terminate (<|) t x = stop t x
+                | Just x' <- step env x = f (x += t) x'
+                | otherwise = split x
+
+
+flatten :: Tree -> [Tree]
+flatten = nubBy (\x y -> pre x == pre y) . f []
+    where f seen t  =  if pre t `elem` seen then [] else
+                       t : concatMap (f (pre t:seen)) (children t)
+
+
+assign :: [Tree] -> [(Var,Exp)]
+assign ts = -- error $ pretty $ ($ repeat "?") $ fst $ split $
+       --error $ pretty $ fromJust $ lookup "f12" [(b,a) | (a,b) <- names]
+       
+       -- error $ unlines $ [pretty $ simplify x | (x,y) <- names, y `elem` ["f107","f105"]] 
+       
+       [(f t, gen t (map f (children t))) |  t <- ts]
+    where f t = fromJust $ lookup (pre t) names
+          names = zip (map pre ts) freshNames 
+
+
+freshNames = "root" : ["f" ++ show i | i <- [1..]]
+
+
+---------------------------------------------------------------------
+-- STACKS
+
+-- find the variable bound at the top of the stack
+-- only returns Nothing if no bound variables
+stackTop :: FlatExp -> Maybe (Var,Exp)
+stackTop (FlatExp _ bind v) = f Nothing v
+    where f res v = case lookup v bind of
+                         Nothing -> res
+                         Just e | Just w <- fmap fst $ force e -> f (Just (v,e)) w
+                                | otherwise -> Just (v,e)
+
+
+-- ensure the top of the stack is a variable bound to a variable
+-- i.e. stack1 = v (where v does not have a binding)
+-- if at all possible (can't if there is a constructor at the top for example)
+stackVar :: FlatExp -> FlatExp
+stackVar flat@(FlatExp free bind root) = case stackTop flat of
+    Nothing -> FlatExp free [("_fake",App noname root [])] "_fake"
+    Just (v,e) | Just (v2,c2) <- force e -> FlatExp free (("_fake",App noname v2 []):(v,c2 "_fake"):delFst v bind) root
+    _ -> flat
+
+
+force :: Exp -> Maybe (Var, Var -> Exp)
+force (App n x y) = Just (x, \x -> App n x y)
+force (Case n x y) = Just (x, \x -> Case n x y)
+force (Let n x y) = Just (y, Let n x)
+force _ = Nothing
+
+
+---------------------------------------------------------------------
+-- BOXES
+
+debox :: Exp -> ([Var] -> Exp, [Exp])
+debox x | otherwise = (a,b)
+    where (a,b) = deboxName $ deboxFree x
+
+
+-- name and extract the Box components
+deboxName :: Exp -> ([Var] -> Exp, [Exp])
+deboxName x = (regen, boxes)
+    where
+        boxes = nub [y | Box y <- universe x]
+        regen names = transform f x
+            where vs = zip boxes names
+                  f (Box x) = App noname (fromJust $ lookup x vs) []
+                  f x = remAppBox x
+
+
+-- simplify and give sufficient free variables to Box bits
+deboxFree :: Exp -> Exp
+deboxFree o = transform f o
+    where
+        fo = free o
+
+        f (Box x) = appBox (simplify $ lams vs x2) vs
+            where
+                vs = {- sort $ -} fx2 \\ fo
+                x2 = simplify x
+                fx2 = free x2
+        f x = x
+
+
+appBox :: Exp -> [Var] -> Exp
+appBox x vs = Let noname [("_box1",Box x),("_box2",App noname "_box1" vs)] "_box2"
+
+remAppBox :: Exp -> Exp
+remAppBox (Let _ [("_box1",App _ x []),("_box2",App _ "_box1" vs)] "_box2") = App noname x vs
+remAppBox x = x
+
+
+---------------------------------------------------------------------
+-- SHARING
+
+-- given a set of expressions bound to boxes, you may:
+-- * move an expression under a box if it's only used by one
+-- * copy an expression under a box if it's cheap
+-- the test function must pass on every expression under a box
+share :: (Exp -> Bool) -> Exp -> Exp
+share test x = fromFlat $ FlatExp vars bind2 root
+    where
+        FlatExp vars bind root = toFlat x
+        norm = filter (not . isBox . snd) bind
+        keep = nub $ root : concatMap (free . snd) norm
+        boxes = [(v, simplify x) | (v,Box x) <- bind]
+        boxes2 = sharer test keep boxes
+        bind2 = norm ++ map (second Box) boxes2
+
+
+data Sharer = Sharer {rank :: Int, var :: Var, vals :: [Var], val :: Exp, fre :: [Var]}
+
+sharer :: (Exp -> Bool) -> [Var] -> [(Var, Exp)] -> [(Var, Exp)]
+sharer test keep xs = map (\x -> (var x, val x)) $ once $ cheap
+        [mk (length $ filter (== getName b) names) a [a] | (a,b) <- xs]
+    where
+        mk a b c = Sharer a b c d (free d)
+            where d = simplify $ Let noname [(c, fromJust $ lookup c xs) | c <- c] b
+        names = map (getName . snd) xs
+        order = sortBy (\x y -> compare (rank x) (rank y))
+
+        -- move a single variable wherever you can, delete if no longer needed
+        move :: Var -> [Sharer] -> [Sharer]
+        move vv xs = if var v `elem` keep || any (elem (var v) . fre) xs2 then xs2
+                     else filter ((/=) (var v) . var) xs2
+            where
+                v = head $ filter ((==) vv . var) xs
+                xs2 = map f xs
+                f x | var v `elem` fre x, test $ val x2 = x2
+                    | otherwise = x
+                    where x2 = mk (max (rank v) (rank x)) (var x) (vals x `union` vals v)
+
+        -- merge all the cheap ones
+        cheap :: [Sharer] -> [Sharer]
+        cheap xs = foldl (flip move) xs $ map var $ filter (isCheap . val) $ order xs
+
+        -- merge all the ones used once
+        once :: [Sharer] -> [Sharer]
+        once xs = f poss
+            where frees = concatMap fre xs
+                  poss = [x | x <- order xs, var x `notElem` keep && length (filter (== var x) frees) <= 1]
+
+                  f [] = xs
+                  f (p:ps) | length xs2 == length xs = f ps
+                           | otherwise = once xs2
+                       where xs2 = move (var p) xs
+
+
+{-
+
+
+
+simplifyBox = transform f
+    where f (Box x) = Box $ simplify x
+          f x = x
+
+
+-- penalise duplicates as they are more expensive, and usually want splitting
+order :: Exp -> [(Var,Exp)] -> [(Var,Exp)]
+order x ys = sortOn f ys
+    where
+        FlatExp vars bind root = toFlat x
+        names = map (getName . snd) bind
+        f y = length $ filter ((==) $ getName $ fromJust $ lookup (fst y) bind) names
+
+-- each variable is bound at the let, to a box
+-- is used in at most one binding, and not the root
+-- and the binding it is used at is a box
+shareOptions :: Exp -> [(Var, Exp)]
+shareOptions x =
+        [ (v, fromFlat $ FlatExp vars (map inject used ++ delFsts (v:used) bind) root)
+        | (v, Box vx) <- bind, v `notElem` bad, let used = [w | (w,e) <- bind, v `elem` free e], length used <= 1 || cheap vx
+        , let inject w = (w,Box $ simplify $ Let noname [(v,vx),("_share",fromBox $ fromJust $ lookup w bind)] "_share")
+        ]
+    where
+        fromBox (Box x) = x
+        bad = nub $ root : concat [free e | (_,e) <- bind, not $ isBox e]
+        frees = concatMap (free . snd) bind
+
+        FlatExp vars bind root = toFlat x
+-}
+
+isCheap (App _ _ []) = True
+isCheap (App _ x xs) | Just n <- arity x = length xs < n
+isCheap Con{} = True
+isCheap (Let _ bind _) = all (isCheap . snd) bind
+isCheap _ = False
+
+---------------------------------------------------------------------
+-- OPERATIONS
+
+step :: Env -> Exp -> Maybe Exp
+step env x | Just (v,App _ f []) <- stackTop flat, Just e <- env f =
+    Just $ simplify $ fromFlat $ FlatExp free ((v,e):delFst v bind) root
+    where flat@(FlatExp free bind root) = stackVar $ toFlat x
+step env x = Nothing
+
+
+split :: Exp -> ([Var] -> Exp, [Exp])
+split x
+    | Nothing <- s = (const x, [])
+    | Just (vc, Case n v xs) <- s = 
+        let alt (p@(App _ _ []),x) = (p, Box $ Let noname ((vc,x):delFst vc bind) root)
+            alt (p,x) = (p, Box $ Let noname ((v,p):bind) root)
+        in debox $ lams free $ Case noname v $ map alt xs
+    | Just (v, Lam{}) <- s =
+        debox $ share (const True) $ fromFlat $ FlatExp free [(a, if a == v then boxlam b else Box b) | (a,b) <- bind] root
+    | Just (v, _) <- s =
+        debox $ share (const True) $ fromFlat $ FlatExp free [(a, if a == v then b else Box b) | (a,b) <- bind] root
+    where
+        s = stackTop flat
+        flat@(FlatExp free bind root) = toFlat x
+        boxlam (Lam n v x) = Lam n v $ boxlam x
+        boxlam x = Box $ simplify x
+
+
+stop :: History -> Exp -> ([Var] -> Exp, [Exp])
+stop hist x = if time 10000 then
+        error $ "STOP:\n" ++ prettyNames x ++ "\n ==>\n" ++ prettyNames res
+        else debox res
+    where
+        res = share (not . terminate (<=|) hist) $ fromFlat $ FlatExp free (map (second Box) bind) root
+        FlatExp free bind root = toFlat x
diff --git a/Terminate.hs b/Terminate.hs
new file mode 100644
--- /dev/null
+++ b/Terminate.hs
@@ -0,0 +1,51 @@
+
+module Terminate(terminate, (<|), (<=|), newHistory, History, (+=), progress) where
+
+import Type
+import Debug.Trace
+import Data.List
+
+
+data History = History Int [Exp] [Bag]
+type Bag = [Name]
+
+newHistory = History 0 [] []
+
+
+progress :: History -> String -> Bool
+progress (History n _ _) msg = trace (msg ++ " = " ++ show n) False
+
+
+terminate :: (Bag -> Bag -> Bool) -> History -> Exp -> Bool
+terminate (<) (History _ hs bs) x = if not $ all (getBag x <) bs then trace "terminate" True else False
+    where
+        bad = head $ filter (not . (getBag x <) . getBag) hs
+        info = error $ prettyNames bad ++
+               "\n WHEN TRYING TO ADD\n" ++ prettyNames x ++
+               "\n BECAUSE OF\n" ++ show (getBag x \\ getBag bad) ++ "\n" ++
+               show ("<",getBag x < getBag bad,"==",x==bad,"bageq",getBag x == getBag bad,"<|",getBag x <| getBag bad,"<=|",getBag x <=| getBag bad)
+    
+--    where
+--        info = error $ prettyNames (head hist) ++ "\n AGAINST \n" ++ prettyNames x ++ "\n" ++ show (getBag x ,getBag y)
+--        y = head hist
+
+
+(<|), (<=|) :: Bag -> Bag -> Bool
+x <| y = nub x /= nub y || length x < length y
+x <=| y = x <| y || x == y
+
+
+(+=) :: Exp -> History -> History
+(+=) x (History n xs bs) = {- trace (prettyNames x) $ -} History (n+1) (x:xs) (getBag x : bs)
+
+
+
+getBag :: Exp -> [Name]
+getBag x = sort $ map (getName . snd) bind
+    where FlatExp _ bind _ = toFlat x
+
+bagEquality x y = x == y
+
+bagSubset x y = null (x \\ y) && not (null $ y \\ x)
+
+setSupset x y = bagSubset (nub y) (nub x)
diff --git a/Type.hs b/Type.hs
new file mode 100644
--- /dev/null
+++ b/Type.hs
@@ -0,0 +1,297 @@
+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
+
+module Type(
+    Var, Con, Exp(..), Pat, pretty, isBox,
+    vars, free, subst, arity, valid, validId,
+    FlatExp(..), toFlat, fromFlat, lams,
+    Name, noname, prettyNames, getName,
+    Env(..), env,
+    fromHSE, toHSE
+    ) where
+
+
+import Data.Maybe
+import Data.List
+import Data.Data
+import Control.Monad.State
+import Data.Char
+import Language.Haskell.Exts hiding (Exp,Name,Pat,Var,Let,App,Case,Con,name)
+import qualified Language.Haskell.Exts as H
+import Data.Generics.Uniplate.Data
+import qualified Data.Map as Map
+
+---------------------------------------------------------------------
+-- TYPE
+
+type Var = String
+type Con = String
+
+
+data Exp = Con  Name Con [Var]
+         | App  Name Var [Var]
+         | Lam  Name Var Exp
+         | Case Name Var [(Pat,Exp)]
+         | Let  Name [(Var,Exp)] Var
+         | Box  Exp -- to represent <? ?> brackets
+           deriving (Data,Typeable,Show)
+
+instance Eq Exp where
+    x == y = toExp x == toExp y -- ignore names
+
+pretty :: Exp -> String
+pretty = prettyPrint . toExp
+
+isBox Box{} = True ; isBox _ = False
+
+
+type Pat = Exp
+
+
+type Env = Var -> Maybe Exp
+
+arity :: Var -> Maybe Int
+arity x | '\'':xs <- dropWhile (/= '\'') x = Just $ read xs
+        | otherwise = Nothing
+
+
+env :: [(Var,Exp)] -> Env
+env xs = flip Map.lookup mp
+    where mp = Map.fromList xs
+
+
+vars :: Exp -> [Var]
+vars (Con _ _ xs) = xs
+vars (App _ x xs) = x:xs
+vars (Lam _ x y) = x : vars y
+vars (Case _ x y) = x : concat [vars a ++ vars b | (a,b) <- y]
+vars (Let _ x y) = concat [a : vars b | (a,b) <- x] ++ [y]
+vars (Box x) = vars x
+
+
+free :: Exp -> [Var]
+free (Con _ _ xs) = nub xs
+free (App _ x xs) = nub $ x:xs
+free (Lam _ x y) = delete x $ free y
+free (Case _ x y) = nub $ x : concat [free b \\ vars a | (a,b) <- y]
+free (Let _ x y) = nub (concatMap (free . snd) x ++ [y]) \\ map fst x
+free (Box x) = free x
+
+
+subst :: [(Var,Var)] -> Exp -> Exp
+subst [] x = x
+subst ren e = case e of
+    Con n c vs -> Con n c $ map f vs
+    App n x ys -> App n (f x) (map f ys)
+    Lam n x y -> Lam n x (g [x] y)
+    Case n x y -> Case n (f x) [(a, g (vars a) b) | (a,b) <- y]
+    Let n x y -> Let n [(a,g (map fst x) b) | (a,b) <- x] $ if y `elem` map fst x then y else f y
+    Box x -> g [] x
+    where
+        f x = fromMaybe x $ lookup x ren
+        g del x = subst (filter (flip notElem del . fst) ren) x
+
+
+valid :: Exp -> Bool
+valid = all (isJust . arity) . free
+
+validId :: Exp -> Exp
+validId x | valid x = x
+          | otherwise = error $ "Invalid expression:\n" ++ pretty x
+
+---------------------------------------------------------------------
+-- NAMES
+
+data Name = Name Var Int Int deriving (Data,Typeable,Eq,Ord)
+
+noname = Name "<no name>" 0 0
+
+instance Show Name where
+    show x | x == noname = "_"
+    show (Name x y z) = "<"++x++","++show y++","++show z++">"
+
+setNameNumber (Name a b _) c = Name a b c
+
+-- pretty print with names for the interesting bits
+prettyNames :: Exp -> String
+prettyNames x = prettyPrint $ Lambda sl (map (PVar . Ident) free) $ H.Let (BDecls $ map f bind) (H.Var $ UnQual $ Ident root)
+    where
+        FlatExp free bind root = toFlat x
+        f (v,x) = PatBind sl (PVar $ Ident v) Nothing (UnGuardedRhs $ H.App (Lit (String $ show $ getName x)) (toExp x)) (BDecls [])
+
+
+getName :: Exp -> Name
+getName (Con n _ xs) = setNameNumber n $ length xs
+getName (App n _ xs) = setNameNumber n $ length xs
+getName (Lam n _ _) = n
+getName (Case n _ _) = n
+getName (Let n _ _) = n
+getName (Box x) = getName x
+
+setName :: Exp -> Name -> Exp
+setName (Con _ x y) n = Con n x y
+setName (App _ x y) n = App n x y
+setName (Lam _ x y) n = Lam n x y
+setName (Case _ x y) n = Case n x y
+setName (Let _ x y) n = Let n x y
+
+
+---------------------------------------------------------------------
+-- FLAT TYPE
+
+data FlatExp = FlatExp [Var] [(Var,Exp)] Var
+
+toFlat :: Exp -> FlatExp
+toFlat = f []
+    where
+        f vs (Lam _ v x) = f (vs++[v]) x
+        f vs (Let _ xs y) = FlatExp vs xs y
+        f vs x = FlatExp vs [("_flat",x)] "_flat"
+
+
+fromFlat :: FlatExp -> Exp
+fromFlat (FlatExp vs x y) = lams vs $ Let noname x y
+
+lams [] x = x
+lams (l:ls) x = Lam noname l $ lams ls x
+
+
+---------------------------------------------------------------------
+-- FROM HSE
+
+fromHSE :: Module -> [(Var,Exp)]
+fromHSE (Module _ _ _ _ _ _ xs) = assignArities [(f, assignNames f x) | (f,x) <- concatMap fromDecl xs]
+
+
+fromDecl :: Decl -> [(Var,Exp)]
+fromDecl (PatBind _ (PVar f) Nothing (UnGuardedRhs x) (BDecls [])) = [(fromName f, fromExp x)]
+fromDecl (FunBind [Match _ f vars Nothing (UnGuardedRhs x) (BDecls [])]) = [(fromName f, fromExp $ Lambda sl vars x)]
+fromDecl TypeSig{} = []
+fromDecl DataDecl{} = []
+fromDecl TypeDecl{} = []
+fromDecl x = error $ "Unhandled fromDecl: " ++ show x
+
+
+fromExp :: H.Exp -> Exp
+fromExp (Lambda _ [] x) = fromExp x
+fromExp (Lambda _ (PVar (Ident x):vars) bod) = Lam noname x $ fromExp $ Lambda sl vars bod
+fromExp o@(H.App x y) = Let noname [(f1,fromExp x),(f2,fromExp y),(f3,App noname f1 [f2])] f3
+    where f1:f2:f3:_ = freshNames o
+fromExp (H.Var (UnQual x)) = App noname (fromName x) []
+fromExp (H.Con (UnQual x)) = Con noname (fromName x) []
+fromExp (H.Con (Special Cons)) = Con noname ":" []
+fromExp (LeftSection x (QVarOp y)) = fromExp $ H.App (H.Var y) x
+fromExp (Paren x) = fromExp x
+fromExp o@(H.Case x xs) = Let noname [(f1,fromExp x),(f2,Case noname f1 $ map fromAlt xs)] f2
+    where f1:f2:_ = freshNames o
+fromExp (List []) = Con noname "[]" []
+fromExp (List [x]) = fromExp $ InfixApp x (QConOp (Special Cons)) $ List []
+fromExp o@(InfixApp x (QConOp (Special Cons)) y) = Let noname [(f1,fromExp x),(f2,fromExp y),(f3,Con noname ":" [f1,f2])] f3
+    where f1:f2:f3:_ = freshNames o
+fromExp o@(InfixApp a (QVarOp b) c) = fromExp $ H.App (H.App (H.Var b) a) c
+fromExp (Lit x) = Con noname (prettyPrint x) []
+fromExp x@(NegApp _) = Con noname (prettyPrint x) []
+fromExp (If a b c) = fromExp $ H.Case a [f "True" b, f "False" c]
+    where f con x = Alt sl (PApp (UnQual $ Ident con) []) (UnGuardedAlt x) (BDecls [])
+fromExp o@(H.Let (BDecls xs) x) = Let noname ((f1,fromExp x):concatMap fromDecl xs) f1
+    where f1:_ = freshNames o
+fromExp o@(Tuple xs) = Let noname
+    ((f1, Con noname (fromTuple xs) (take (length xs) fs)) : zipWith (\f x -> (f,fromExp x)) fs xs) f1
+    where f1:fs = freshNames o
+fromExp (H.Con (Special (TupleCon _ n))) = Con noname (fromTuple $ replicate n ()) []
+fromExp x = error $ "Unhandled fromExp: " ++ show x
+
+
+fromName :: H.Name -> String
+fromName (Ident x) = x
+fromName (Symbol x) = x
+
+fromAlt :: Alt -> (Pat, Exp)
+fromAlt (Alt _ pat (UnGuardedAlt bod) (BDecls [])) = (fromPat pat, fromExp bod)
+fromAlt x = error $ "Unhandled fromAlt: " ++ show x
+
+fromPat :: H.Pat -> Pat
+fromPat (PParen x) = fromPat x
+fromPat (PList []) = Con noname "[]" []
+fromPat (PApp (Special Cons) xs) = Con noname ":" $ map fromPatVar xs
+fromPat (PInfixApp a b c) = fromPat $ PApp b [a,c]
+fromPat (PApp (UnQual c) xs) = Con noname (fromName c) $ map fromPatVar xs
+fromPat (PTuple xs) = Con noname (fromTuple xs) $ map fromPatVar xs
+fromPat (PApp (Special (TupleCon _ n)) xs) = Con noname (fromTuple xs) $ map fromPatVar xs
+fromPat PWildCard = App noname "_wild" []
+fromPat x = error $ "Unhandled fromPat: " ++ show x
+
+fromTuple xs = "(" ++ replicate (length xs - 1) ',' ++ ")"
+
+fromPatVar :: H.Pat -> String
+fromPatVar (PVar x) = fromName x
+fromPatVar x = error $ "Unhandled fromPatVar: " ++ show x
+
+
+freshNames :: H.Exp -> [String]
+freshNames x  = ['v':show i | i <- [1..]] \\ [y | Ident y <- universeBi x]
+
+
+-- Fixup: Assign names properly
+assignNames :: Var -> Exp -> Exp
+assignNames fun x = evalState (transformM f x) 0
+    where
+        f x = do
+            modify (+1)
+            i <- get
+            return $ setName x $ Name fun i 0
+
+
+-- Fixup: Move arity information
+assignArities :: [(Var,Exp)] -> [(Var,Exp)]
+assignArities xs = checkPrims $ ("root",App noname (fromJust $ lookup "root" ren) []) :
+                                [(fromJust $ lookup a ren, subst ren b) | (a,b) <- xs]
+    where ren = [(a, a ++ "'" ++ show (f b)) | (a,b) <- xs]
+          f (Lam _ _ x) = 1 + f x
+          f _ = 0
+
+
+checkPrims :: [(Var,Exp)] -> [(Var,Exp)]
+checkPrims xs | null bad = xs
+              | otherwise = error $ "checkPrims failed: " ++ show bad
+    where
+        bad = nub [v | (_,x) <- xs, v <- free x, Nothing <- [arity v]]
+
+
+---------------------------------------------------------------------
+-- TO HSE
+
+toHSE :: [(Var,Exp)] -> Module
+toHSE xs = Module sl (ModuleName "") [] Nothing Nothing [] $ map toDecl xs
+
+toDecl :: (Var,Exp) -> Decl
+toDecl (f,x) = PatBind sl (PVar $ Ident f) Nothing (UnGuardedRhs $ toExp x) (BDecls [])
+
+toExp :: Exp -> H.Exp
+toExp (Lam _ x y) = Paren $ lambda [PVar $ Ident x] $ toExp y
+toExp (Let _ xs y) = Paren $ H.Let (BDecls $ map toDecl xs) $ toVar y
+toExp (App _ x y) = Paren $ foldl H.App (toVar x) $ map toVar y
+toExp (Case _ x y) = Paren $ H.Case (toVar x) (map toAlt y)
+toExp (Con _ c vs) = Paren $ foldl H.App (H.Con $ UnQual $ toName c) (map toVar vs)
+toExp (Box x) = BracketExp $ ExpBracket $ toExp x
+
+toAlt :: (Pat, Exp) -> Alt
+toAlt (x,y) = Alt sl (toPat x) (UnGuardedAlt $ toExp y) (BDecls [])
+
+toPat :: Pat -> H.Pat
+toPat (Con _ c vs) = PApp (UnQual $ toName c) (map (PVar . Ident) vs)
+toPat (App _ v []) = PWildCard
+toPat x = error $ "toPat, todo: " ++ show x
+
+toVar :: Var -> H.Exp
+toVar x = H.Var $ UnQual $ toName x
+
+toName :: String -> H.Name
+toName xs@(x:_) | isAlphaNum x || x `elem` "'_(" = Ident xs
+                | otherwise = Symbol xs
+
+sl = SrcLoc "" 0 0
+
+
+lambda v1 (Lambda _ v2 x) = Lambda sl (v1++v2) x
+lambda v1 (Paren x) = lambda v1 x
+lambda v1 x = Lambda sl v1 x
diff --git a/Util.hs b/Util.hs
new file mode 100644
--- /dev/null
+++ b/Util.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE PatternGuards #-}
+
+module Util(module Util, trace) where
+
+import Data.Function
+import Data.List
+import Control.Monad.State
+import Data.IORef
+import Debug.Trace
+import System.IO.Unsafe
+import Data.Time.Clock.POSIX(getPOSIXTime)
+
+
+sortOn :: Ord b => (a -> b) -> [a] -> [a]
+sortOn f = sortBy (compare `on` f)
+
+
+subset x y = null $ x \\ y
+
+fixEq f x = if x == x2 then x else fixEq f x2
+    where x2 = f x
+
+
+getTime :: IO Double
+getTime = (fromRational . toRational) `fmap` getPOSIXTime
+
+timer :: IO () -> IO ()
+timer act = do
+    start <- getTime
+    act
+    end <- getTime
+    print (end - start)
+
+
+
+delFst :: Eq a => a -> [(a,b)] -> [(a,b)]
+delFst x = filter ((/=) x . fst)
+
+delFsts :: Eq a => [a] -> [(a,b)] -> [(a,b)]
+delFsts x = filter (flip notElem x . fst)
+
+
+
+freshVars :: String -> [String]
+freshVars v = [v ++ show i | i <- [1..]]
+
+
+class FreshState a where
+    getFresh :: a -> [String]
+    setFresh :: a -> [String] -> a
+
+
+fresh :: FreshState a => State a String
+fresh = do
+    s <- get
+    let v:vs = getFresh s
+    put $ setFresh s vs
+    return v
+
+
+freshN :: FreshState a => Int -> State a [String]
+freshN n = do
+    s <- get
+    let (v,vs) = splitAt n $ getFresh s
+    put $ setFresh s vs
+    return v
+
+
+filterFresh :: FreshState a => (String -> Bool) -> State a ()
+filterFresh f = modify $ \s -> setFresh s $ filter f $ getFresh s
+
+
+type Fresh a = State SFresh a
+newtype SFresh = SFresh [String]
+
+instance FreshState SFresh where
+    getFresh (SFresh x) = x
+    setFresh _ x = SFresh x
+
+runFresh :: String -> Fresh a -> a
+runFresh v x = evalState x $ SFresh $ freshVars v
+
+
+
+{-# NOINLINE time #-}
+time :: Int -> Bool
+time i = unsafePerformIO $ do
+    n <- readIORef timeRef
+    writeIORef timeRef (n+1)
+    return $ i == n
+
+{-# NOINLINE timeRef #-}
+timeRef :: IORef Int
+timeRef = unsafePerformIO $ newIORef 0
+
+
+{-# NOINLINE resetTime #-}
+resetTime :: a -> a
+resetTime x = unsafePerformIO $ do
+    writeIORef timeRef 0
+    return x
+
+
+fromJustNote msg Nothing = error $ "fromJustNote: " ++ msg
+fromJustNote msg (Just x) = x
+
+
+type Id x = x -> x
diff --git a/supero.cabal b/supero.cabal
new file mode 100644
--- /dev/null
+++ b/supero.cabal
@@ -0,0 +1,27 @@
+cabal-version:      >= 1.6
+build-type:         Simple
+name:               supero
+version:            3.0
+license:            BSD3
+license-file:       LICENSE
+category:           Compiler
+author:             Neil Mitchell <ndmitchell@gmail.com>
+maintainer:         Neil Mitchell <ndmitchell@gmail.com>
+copyright:          Neil Mitchell 2006-2010
+synopsis:           A Supercompiler
+description:
+    A demo supercompiler - not really ready for public use yet.
+homepage:           http://community.haskell.org/~ndm/supero/
+stability:          Beta
+
+executable supero
+    build-depends:      base == 4.*, directory, process, filepath, time, mtl, containers,
+                        haskell-src-exts == 1.9.0, cpphs == 1.11, uniplate == 1.5.*
+    hs-source-dirs:     .
+    main-is:            Main.hs
+    other-modules:
+        Simplify
+        Supercompile
+        Terminate
+        Type
+        Util