diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2011, Adam Gundry
+
+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 Adam Gundry 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/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,154 @@
+inch
+====
+
+**Inch** is a type-checker for a subset of Haskell (plus some GHC extensions) with the addition of integer constraints. After successfully type-checking a source file, it outputs an operationally equivalent version with the type-level integers erased, so it can be used as a preprocessor in order to compile programs.
+
+This is a very rough and ready prototype. Many Haskell features are missing or poorly implemented.
+
+
+Installation
+------------
+
+    cabal install inch
+
+
+Features
+--------
+
+* A new kind `Integer` for type-level integers, together with a synonym `Nat` for integers constrained to be nonnegative
+
+* Type-level addition, subtraction, multiplication and exponentiation operations (plus a few more)
+
+* Contexts contain numeric equality and inequality constraints
+
+* Π-types (dependent functions from integers) inspired by the SHE preprocessor, which erase to the corresponding non-dependent functions
+
+* Guards can test numeric constraints and make this information available for type-checking (as in `plan` below)
+
+* Powerful type inference using a novel approach to equational unification (though type signatures are needed for GADT pattern matches and polymorphic recursion)
+
+
+Example
+-------
+
+The following program defines a type of vectors (lists indexed by their length) and some functions using them. 
+
+    {-# OPTIONS_GHC -F -pgmF inch #-}
+    {-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables, NPlusKPatterns #-}
+
+    data Vec :: * -> Nat -> * where
+        VNil  :: Vec a 0
+        VCons :: forall a (n :: Nat) . a -> Vec a n -> Vec a (n+1)
+      deriving Show
+
+    vreverse :: forall (n :: Nat) a . Vec a n -> Vec a n
+    vreverse xs = vrevapp xs VNil
+      where
+        vrevapp :: forall (m n :: Nat) a . Vec a m -> Vec a n -> Vec a (m+n)
+        vrevapp VNil         ys = ys
+        vrevapp (VCons x xs) ys = vrevapp xs (VCons x ys)
+
+    vec :: pi (n :: Nat) . a -> Vec a n
+    vec {0}   a = VNil
+    vec {n+1} a = VCons a (vec {n} a)
+
+    vlookup :: forall (n :: Nat) a . pi (m :: Nat) . m < n => Vec a n -> a
+    vlookup {0}   (VCons x _)  = x
+    vlookup {k+1} (VCons _ xs) = vlookup {k} xs
+
+    plan :: pi (n :: Nat) . Vec Integer n
+    plan {0}           = VNil
+    plan {m} | {m > 0} = VCons m (plan {m-1})
+
+After type-checking and preprocecessing with `inch`, the resulting file is as follows.
+
+    {-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables, NPlusKPatterns #-}
+
+    data Vec :: * -> * where
+        VNil  :: Vec a
+        VCons :: a -> Vec a -> Vec a
+      deriving Show
+
+    vreverse :: Vec a -> Vec a
+    vreverse xs = vrevapp xs VNil
+      where
+        vrevapp :: Vec a -> Vec a -> Vec a
+        vrevapp VNil         ys = ys
+        vrevapp (VCons x xs) ys = vrevapp xs (VCons x ys)
+
+    vec :: Integer -> a -> Vec a n
+    vec 0     a = VNil
+    vec (n+1) a = VCons a (vec n a)
+
+    vlookup :: Integer -> Vec a n -> a
+    vlookup 0     (VCons x _)  = x
+    vlookup (k+1) (VCons _ xs) = vlookup k xs
+
+    plan :: Integer -> Vec Integer
+    plan 0         = VNil
+    plan m | m > 0 = VCons m (plan (m-1))
+
+For more examples, look in the [examples directory](https://github.com/adamgundry/inch/tree/master/examples) of the source distribution. These include:
+
+* More fun with vectors
+
+* Merge sort that maintains length and ordering invariants
+
+* Red-black tree insertion and deletion with ordering, colour and black height invariants guaranteed by types
+
+* Time complexity annotations showing that red-black tree insert/delete are linear in the black height, plus a few other examples
+
+* Units of measure with good type inference properties and (morally) no runtime overhead
+
+
+Known limitations
+-----------------
+
+* Lots of Haskell features are unsupported, notably list comprehensions, `do` notation, `if` expressions, newtypes, field labels, ...
+
+* The parser is somewhat idiosyncratic; look at the examples to figure out what syntax it accepts. Data types must be defined in GADT syntax, using a kind signature rather than a list of variables. Parsing of infix operators is almost but not entirely nonexistent, so they must usually be written prefix.
+
+* Modules are poorly supported. A `.inch` file is generated when preprocessing a module, listing the identifiers it defines, and this file is looked up when the module is imported. Because preprocessing happens in reverse dependency order, manual intervention may be required to generate `.inch` files before they are needed (by loading dependencies in GHCi). Qualified names are not supported, so there will be problems if multiple modules bring the same name into scope.
+
+* Type classes are not completely implemented: ambiguity checking and defaulting are lacking, superclasses are not taken into consideration when solving constraints, and the constraint solver is untested.
+
+* No kind inference is performed, so type variables must be annotated with their kind if it is not `*`. This means explicit `forall`-bindings must be used in some type signatures. Type variables in instance declarations cannot be annotated, so they may only have kind `*` (at the moment).
+
+* Only GADTs involving type-level numeric equalities are supported, not more general equations between types.
+
+* Support for higher-rank types is limited.
+
+
+
+Outstanding design issues
+-------------------------
+
+* Metavariables are solved using equational unification in the abelian group of integers with addition, which works well, but a better story about ambiguity is needed.
+
+* Constraint solving is based on normalisation and a solver for Presburger arithmetic, so only linear constraints are guaranteed to be solved. Hard constraints can be dealt with by the user invoking higher-rank functions that add facts to the context. A better characterisation of solvable constraints would be nice.
+
+* Exponentiation by a negative integer is possible but makes no sense.
+
+* At the moment, `Nat` is just `Integer` (with a positivity constraint added when it is used in a type signature). Kind polymorphism and subkinding might allow more precise kinds to be given to arithmetic operations, including a correct kind for exponentiation. 
+
+* `n+k`-patterns provide quite a nice syntax for defining dependent numeric functions, but they have been deprecated and removed from Haskell 2010, so perhaps an alternative should be found.
+
+* Erasure for type classes involving numeric kinds is not yet properly specified.
+
+
+Related work
+------------
+
+Iavor Diatchki is working on [TypeNats](http://hackage.haskell.org/trac/ghc/wiki/TypeNats), an extension to GHC that aims to support type-level natural numbers. He also implemented the [presburger](http://github.com/yav/presburger) package, which `inch` uses for constraint solving.
+
+Conor McBride's [Strathclyde Haskell Enhancement](http://personal.cis.strath.ac.uk/~conor/pub/she/) is a preprocessor that supports Π-types and allows lifting algebraic data types (but not numeric types) to kinds. SHE inspired the braces syntax used in `inch`. These ideas (and more, including kind polymorphism) are being implemented in GHC: see [Giving Haskell a Promotion](http://research.microsoft.com/en-us/people/dimitris/fc-kind-poly.pdf) by Brent Yorgey, Stephanie Weirich, Julien Cretin, Simon Peyton Jones and Dimitrios Vytiniotis. 
+
+Max Bolingbroke has implemented the new [Constraint kind](http://blog.omega-prime.co.uk/?p=127) in GHC. This kind is supported by `inch` but not erased, so it will only work if GHC support is present.
+
+This work is inspired by Hongwei Xi's [Dependent ML](http://www.cs.bu.edu/~hwxi/DML/DML.html) and its successor [ATS](http://www.ats-lang.org/), which support type-level Presburger arithmetic.
+
+
+Contact
+-------
+
+Adam Gundry, adam.gundry@strath.ac.uk
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/data/Prelude.inch b/data/Prelude.inch
new file mode 100644
--- /dev/null
+++ b/data/Prelude.inch
@@ -0,0 +1,311 @@
+data Rational where
+
+class  Eq a  where  
+    (==), (/=) :: a -> a -> Bool  
+
+class  (Eq a) => Ord a  where  
+    compare              :: a -> a -> Ordering  
+    (<), (<=), (>=), (>) :: a -> a -> Bool  
+    max, min             :: a -> a -> a  
+
+class  Enum a  where  
+    succ, pred       :: a -> a  
+    toEnum           :: Int -> a  
+    fromEnum         :: a -> Int  
+    enumFrom         :: a -> [a]             
+    enumFromThen     :: a -> a -> [a]        
+    enumFromTo       :: a -> a -> [a]        
+    enumFromThenTo   :: a -> a -> a -> [a]   
+
+class  Bounded a  where  
+    minBound         :: a  
+    maxBound         :: a
+
+class  (Eq a, Show a) => Num a  where  
+    (+), (-), (*)    :: a -> a -> a  
+    negate           :: a -> a  
+    abs, signum      :: a -> a  
+    fromInteger      :: Integer -> a  
+
+class  (Num a, Ord a) =>  Real a  where  
+    toRational       ::  a -> Rational
+
+class  (Real a, Enum a) => Integral a  where  
+    quot, rem        :: a -> a -> a  
+    div, mod         :: a -> a -> a  
+    quotRem, divMod  :: a -> a -> (a,a)  
+    toInteger        :: a -> Integer  
+
+class  (Num a) => Fractional a  where  
+    (/)              :: a -> a -> a  
+    recip            :: a -> a  
+    fromRational     :: Rational -> a  
+
+class  (Fractional a) => Floating a  where  
+    pi                  :: a  
+    exp, log, sqrt      :: a -> a  
+    (**), logBase       :: a -> a -> a  
+    sin, cos, tan       :: a -> a  
+    asin, acos, atan    :: a -> a  
+    sinh, cosh, tanh    :: a -> a  
+    asinh, acosh, atanh :: a -> a  
+
+class  (Real a, Fractional a) => RealFrac a  where  
+    properFraction   :: forall b . (Integral b) => a -> (b,a)  
+    truncate, round  :: forall b . (Integral b) => a -> b  
+    ceiling, floor   :: forall b . (Integral b) => a -> b  
+
+class  (RealFrac a, Floating a) => RealFloat a  where  
+    floatRadix       :: a -> Integer  
+    floatDigits      :: a -> Int  
+    floatRange       :: a -> (Int,Int)  
+    decodeFloat      :: a -> (Integer,Int)  
+    encodeFloat      :: Integer -> Int -> a  
+    exponent         :: a -> Int  
+    significand      :: a -> a  
+    scaleFloat       :: Int -> a -> a  
+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE  
+                     :: a -> Bool  
+    atan2            :: a -> a -> a  
+
+subtract         :: Num a => a -> a -> a
+even, odd        :: Num a => a -> Bool
+gcd              :: Integral a => a -> a -> a
+lcm              :: Integral a => a -> a -> a
+(^)              :: (Num a, Integral b) => a -> b -> a  
+(^^)             :: (Fractional a, Integral b) => a -> b -> a  
+fromIntegral     :: (Integral a, Num b) => a -> b  
+realToFrac     :: (Real a, Fractional b) => a -> b  
+
+class  Functor (f :: * -> *)  where  
+    fmap              :: (a -> b) -> f a -> f b
+
+class  Monad (m :: * -> *)  where  
+    (>>=)  :: m a -> (a -> m b) -> m b  
+    (>>)   :: m a -> m b -> m b  
+    return :: a -> m a  
+    fail   :: String -> m a  
+
+sequence         :: forall (m :: * -> *) a . [m a] -> m [a]  
+sequence_        :: forall (m :: * -> *) a . [m a] -> m ()
+mapM             :: forall (m :: * -> *) a b . (a -> m b) -> [a] -> m [b]  
+mapM_            :: forall (m :: * -> *) a b . (a -> m b) -> [a] -> m ()  
+(=<<)            :: forall (m :: * -> *) a b . (a -> m b) -> m a -> m b  
+
+-- data () built in
+instance Eq ()
+instance Ord ()
+instance Enum ()
+instance Bounded ()
+
+id               :: a -> a
+const            :: a -> (b -> a)
+(.)              :: (b -> c) -> (a -> b) -> a -> c  
+flip             :: (a -> (b -> c)) -> (b -> (a -> c))
+seq              :: a -> b -> b
+($), ($!)        :: (a -> b) -> a -> b  
+
+data Bool where
+  False :: Bool
+  True :: Bool
+  deriving (Eq, Ord, Enum, Read, Show, Bounded)
+
+(&&)             :: Bool -> Bool -> Bool  
+(||)             :: Bool -> Bool -> Bool  
+not :: Bool -> Bool
+otherwise :: Bool
+
+-- data Char built in
+instance  Eq Char
+instance  Ord Char
+instance  Enum Char 
+instance  Bounded Char
+
+type String = [Char]
+
+data Maybe :: * -> * where
+  Nothing :: Maybe a
+  Just :: a -> Maybe a
+  deriving (Eq, Ord, Read, Show)
+maybe :: b -> ((a -> b) -> (Maybe a -> b))
+instance  Functor Maybe 
+instance  Monad Maybe
+
+data Either :: * -> * -> * where
+  Left :: a -> Either a b
+  Right :: b -> Either a b
+  deriving (Eq, Ord, Read, Show)
+either :: (a -> c) -> ((b -> c) -> (Either a b -> c))
+
+data IO :: * -> * where
+instance Functor IO  
+instance Monad IO
+
+data Ordering where
+  LT :: Ordering
+  EQ :: Ordering
+  GT :: Ordering
+  deriving (Eq, Ord, Enum, Read, Show, Bounded)
+
+data  Int where
+instance  Eq       Int
+instance  Ord      Int
+instance  Num      Int
+instance  Real     Int
+instance  Integral Int
+instance  Enum     Int
+instance  Bounded  Int
+
+-- data  Integer  built in
+instance  Eq       Integer
+instance  Ord      Integer
+instance  Num      Integer
+instance  Real     Integer
+instance  Integral Integer
+instance  Enum     Integer
+
+data  Float where  
+instance  Eq         Float
+instance  Ord        Float
+instance  Num        Float  
+instance  Real       Float  
+instance  Fractional Float  
+instance  Floating   Float  
+instance  RealFrac   Float  
+instance  RealFloat  Float
+
+data  Double where
+instance  Eq         Double  
+instance  Ord        Double  
+instance  Num        Double  
+instance  Real       Double  
+instance  Fractional Double  
+instance  Floating   Double  
+instance  RealFrac   Double  
+instance  RealFloat  Double
+
+instance  Enum Float  
+instance  Enum Double
+
+-- data [] built in
+instance Eq a => Eq [a]
+instance Ord a => Ord [a]
+instance Functor []  
+instance Monad []  
+  
+-- data (,) built in
+instance (Eq a, Eq b) => Eq (a, b)
+instance (Ord a, Ord b) => Ord (a, b)
+instance (Bounded a, Bounded b) => Bounded (a, b)
+
+fst :: (a, b) -> a
+snd :: (a, b) -> b
+curry :: ((a, b) -> c) -> (a -> (b -> c))
+uncurry :: (a -> (b -> c)) -> ((a, b) -> c)
+
+until :: (a -> Bool) -> ((a -> a) -> (a -> a))
+asTypeOf :: a -> (a -> a)
+error :: String -> a
+undefined :: a
+
+map :: (a -> b) -> ([a] -> [b])
+(++) :: [a] -> [a] -> [a]
+filter :: (a -> Bool) -> ([a] -> [a])
+concat :: [[a]] -> [a]
+concatMap :: (a -> [b]) -> ([a] -> [b])
+head :: [a] -> a
+tail :: [a] -> [a]
+last :: [a] -> a
+init :: [a] -> [a]
+null :: [a] -> Bool
+length :: [a] -> Integer
+(!!) :: [a] -> Integer -> a
+foldl :: (a -> (b -> a)) -> (a -> ([b] -> a))
+foldl1 :: (a -> (a -> a)) -> ([a] -> a)
+scanl :: (a -> (b -> a)) -> (a -> ([b] -> [a]))
+scanl1 :: (a -> (a -> a)) -> ([a] -> [a])
+foldr :: (a -> (b -> b)) -> (b -> ([a] -> b))
+foldr1 :: (a -> (a -> a)) -> ([a] -> a)
+scanr             :: (a -> b -> b) -> b -> [a] -> [b]
+scanr1          :: (a -> a -> a) -> [a] -> [a]
+iterate :: (a -> a) -> (a -> [a])
+repeat :: a -> [a]
+replicate :: Integer -> (a -> [a])
+cycle :: [a] -> [a]
+take :: Integer -> ([a] -> [a])
+drop :: Integer -> ([a] -> [a])
+splitAt :: Integer -> ([a] -> ([a], [a]))
+takeWhile :: (a -> Bool) -> ([a] -> [a])
+dropWhile               :: (a -> Bool) -> [a] -> [a]
+span                    :: (a -> Bool) -> [a] -> ([a],[a])
+break                   :: (a -> Bool) -> [a] -> ([a],[a])
+lines            :: String -> [String]
+words            :: String -> [String]
+unlines :: [String] -> String
+unwords :: [String] -> String
+reverse :: [a] -> [a]
+and, or :: [Bool] -> Bool
+any, all :: (a -> Bool) -> ([a] -> Bool)
+elem, notElem :: Eq a => a -> [a] -> Bool
+lookup :: Eq a => a -> [(a, b)] -> Maybe b
+sum, product :: Num a => [a] -> a
+maximum, minimum :: Ord a => [a] -> a
+zip :: [a] -> ([b] -> [(a, b)])
+zipWith :: (a -> (b -> c)) -> ([a] -> ([b] -> [c]))
+zipWith3 :: (a -> (b -> (c -> d))) -> ([a] -> ([b] -> ([c] -> [d])))
+unzip            :: [(a,b)] -> ([a],[b])
+
+class  Read a  where  
+    readsPrec        :: Int -> String -> [(a, String)]  
+    readList         :: String -> [([a], String)]
+
+class  Show a  where  
+    showsPrec        :: Int -> a -> String -> String  
+    show             :: a -> String
+    showList         :: [a] -> String -> String  
+ 
+reads            :: (Read a) => String -> [(a, String)]  
+shows            :: (Show a) => a -> String -> String  
+read             :: (Read a) => String -> a  
+showChar         :: Char -> String -> String  
+showString       :: String -> String -> String  
+showParen        :: Bool -> (String -> String) -> (String -> String)
+readParen        :: Bool -> (String -> [(a, String)]) -> (String -> [(a, String)])
+lex              :: String -> [(String, String)]  
+    
+instance  Show Int  
+instance  Read Int  
+instance  Show Integer  
+instance  Read Integer  
+instance  Show Float  
+instance  Read Float  
+instance  Show Double  
+instance  Read Double  
+instance  Show ()  
+instance Read () where  
+instance  Show Char  
+instance  Read Char  
+instance  (Show a) => Show [a]  
+instance  (Read a) => Read [a]  
+instance  (Show a, Show b) => Show (a,b)  
+instance  (Read a, Read b) => Read (a,b)  
+
+data IOError where
+instance  Show IOError  
+instance  Eq IOError
+
+ioError    ::  IOError -> IO a  
+userError  ::  String -> IOError  
+catch      ::  IO a -> (IOError -> IO a) -> IO a  
+putChar    :: Char -> IO ()  
+putStr     :: String -> IO ()  
+putStrLn   :: String -> IO ()  
+getChar    :: IO Char  
+getLine    :: IO String  
+getContents :: IO String  
+interact    ::  (String -> String) -> IO ()  
+readFile   :: String -> IO String
+writeFile  :: String -> String -> IO ()  
+appendFile :: String -> String -> IO ()  
+readIO :: Read a => String -> IO a
+readLn :: Read a => IO a
diff --git a/examples/Cost.hs b/examples/Cost.hs
new file mode 100644
--- /dev/null
+++ b/examples/Cost.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+{-
+  A library for time complexity analysis, based on
+
+    Nils Anders Danielsson. 2008. Lightweight semiformal time
+    complexity analysis for purely functional data structures.
+
+    In Proceedings of the 35th annual ACM SIGPLAN-SIGACT symposium on
+    Principles of Programming Languages (POPL '08). ACM.
+-}
+
+module Cost (Cost, weaken, force, returnCost, bindCost, weakenBy,
+                 tick, returnW, joinCost, mapCost) where
+
+-- Cost is a monad indexed by the number of time steps required to
+-- deliver a value in WHNF. 
+
+-- Note that the Hide constructor is not exported, so clients cannot
+-- violate the abstraction barrier, though they must still annotate
+-- code appropriately (not misusing force, for example).
+
+data Cost :: Num -> * -> * where
+  Hide :: forall (n :: Nat) a . a -> Cost n a
+
+instance Show a => Show (Cost 0 a) where
+  show (Hide x) = show x
+
+weaken :: forall (m n :: Nat) a . m <= n => Cost m a -> Cost n a
+weaken (Hide a) = Hide a
+
+force :: forall (n :: Nat) a . Cost n a -> a
+force (Hide a) = a
+
+returnCost :: a -> Cost 0 a
+returnCost = Hide
+
+bindCost :: forall (m n :: Nat) a b . Cost m a ->
+                (a -> Cost n b) -> Cost (m+n) b
+bindCost x f = weaken (f (force x))
+
+
+-- Given the above primitives, we define some useful derived combinators:
+
+weakenBy :: forall (n :: Nat) a . pi (m :: Nat) . Cost n a -> Cost (m + n) a
+weakenBy {m} = weaken
+
+tick :: forall (n :: Nat) a . Cost n a -> Cost (n + 1) a
+tick = weakenBy {1}
+
+returnW :: forall (n :: Nat) a . a -> Cost n a
+returnW x = weaken (returnCost x)
+
+joinCost :: forall (m n :: Nat) a . Cost m (Cost n a) -> Cost (m + n) a
+joinCost x = bindCost x id
+
+mapCost :: forall (n :: Nat) a b . (a -> b) -> Cost n a -> Cost n b
+mapCost f x = bindCost x (\ x -> returnW (f x))
diff --git a/examples/MergeSort.hs b/examples/MergeSort.hs
new file mode 100644
--- /dev/null
+++ b/examples/MergeSort.hs
@@ -0,0 +1,73 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+module MergeSort where
+
+import Vectors
+
+comp f g x = f (g x)
+
+data DTree :: * -> Integer -> * where
+    Empty  :: DTree a 0
+    Leaf   :: a -> DTree a 1
+    Even   :: forall a (n :: Integer) . 1 <= n =>
+                 DTree a n -> DTree a n -> DTree a (2*n)
+    Odd    :: forall a (n :: Integer) . 1 <= n =>
+                 DTree a (n+1) -> DTree a n -> DTree a (2*n+1)
+  deriving Show
+
+insert :: forall a (n :: Integer) . a -> DTree a n -> DTree a (n+1)
+insert i Empty       = Leaf i
+insert i (Leaf j)    = Even (Leaf i) (Leaf j)
+insert i (Even l r)  = Odd (insert i l) r
+insert i (Odd l r)   = Even l (insert i r)
+
+merge :: forall (m n :: Integer) .
+             Vec Integer m -> Vec Integer n -> Vec Integer (m+n)
+merge VNil ys = ys
+merge xs VNil = xs
+merge (VCons x xs) (VCons y ys) | (<=) x y   = VCons x (merge xs (VCons y ys))
+                                | otherwise  = VCons y (merge (VCons x xs) ys)
+
+build = vifold Empty insert
+
+flatten :: forall (n :: Integer) . DTree Integer n -> Vec Integer n
+flatten Empty      = VNil
+flatten (Leaf i)   = VCons i VNil
+flatten (Even l r) = merge (flatten l) (flatten r)
+flatten (Odd l r)  = merge (flatten l) (flatten r)
+
+sort = comp flatten build
+
+
+data OVec :: Integer -> Integer -> Integer -> * where
+  ONil :: forall (l u :: Integer) . l <= u => OVec 0 l u
+  OCons :: forall (n l u :: Integer) . pi (x :: Integer) . l <= x =>
+               OVec n x u -> OVec (n+1) l u
+  deriving Show
+
+
+ltCompare :: forall a. pi (x y :: Integer) . (x <= y => a) -> (x > y => a) -> a
+ltCompare {x} {y} l g | {x <= y} = l
+ltCompare {x} {y} l g | {x  > y} = g
+
+omerge :: forall (m n l u :: Integer) . OVec m l u -> OVec n l u -> OVec (m+n) l u
+omerge ONil ys = ys
+omerge xs ONil = xs
+omerge (OCons {x} xs) (OCons {y} ys)
+    = ltCompare {x} {y} (OCons {x} (omerge xs (OCons {y} ys)))
+                        (OCons {y} (omerge (OCons {x} xs) ys))
+
+
+data In :: Integer -> Integer -> * where
+    In :: forall (l u :: Integer) . pi (x :: Integer) . (l <= x, x <= u) => In l u
+  deriving Show
+
+oflatten :: forall (n l u :: Integer) . l <= u => DTree (In l u) n -> OVec n l u
+oflatten Empty      = ONil
+oflatten (Leaf (In {i}))   = OCons {i} ONil
+oflatten (Even l r) = omerge (oflatten l) (oflatten r)
+oflatten (Odd l r)  = omerge (oflatten l) (oflatten r)
+
+osort = comp oflatten build
diff --git a/examples/NonlinearCost.hs b/examples/NonlinearCost.hs
new file mode 100644
--- /dev/null
+++ b/examples/NonlinearCost.hs
@@ -0,0 +1,41 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+
+{-# LANGUAGE GADTs, RankNTypes, KindSignatures, ScopedTypeVariables, NPlusKPatterns #-}
+
+module NonlinearCost where
+
+import Cost
+
+
+data Proxy :: Num -> * where
+  Proxy :: forall (n :: Num) . Proxy n
+
+
+-- This should be implemented as the identity function, but we need
+-- some way to pacify the type-checker. Even better, it should notice
+-- that multiplication of naturals yields a natural number.
+
+lemmaMulPos :: forall a (m n :: Nat) . Proxy m -> Proxy n -> (0 <= m * n => a) -> a
+lemmaMulPos pm pn = lemmaMulPos pm pn
+
+
+data BList :: * -> Num -> * where
+  Nil  :: forall a (k :: Nat) . BList a k
+  Cons :: forall a (k :: Nat) . a -> BList a k -> BList a (k+1)
+
+wkBList :: forall a (m n :: Num) . m <= n => BList a m -> BList a n
+wkBList Nil          = Nil
+wkBList (Cons x xs)  = Cons x (wkBList xs)
+
+filterB :: forall a (n :: Num) . (a -> Bool) -> BList a n -> Cost (n+1) (BList a n) 
+filterB p Nil                       = tick (returnW Nil)
+filterB p (Cons x xs)  | p x        = tick (mapCost (Cons x) (filterB p xs))
+                       | otherwise  = tick (mapCost wkBList (filterB p xs))
+
+nubByB :: forall a (n :: Num) . (a -> a -> Bool) -> BList a n ->
+              Cost (n * (n + 3) + 1) (BList a n)
+nubByB eq Nil          = lemmaMulPos (Proxy :: Proxy n) (Proxy :: Proxy n)
+                           (tick (returnW Nil))
+nubByB eq (Cons x xs)  = lemmaMulPos (Proxy :: Proxy (n-1)) (Proxy :: Proxy (n-1))
+                           (tick (weaken (bindCost (filterB (\ y -> not (eq x y)) xs)
+                             (\ xs' -> tick (mapCost (Cons x) (nubByB eq xs'))))))
diff --git a/examples/Queue.hs b/examples/Queue.hs
new file mode 100644
--- /dev/null
+++ b/examples/Queue.hs
@@ -0,0 +1,71 @@
+{-
+  Purely Functional Queue with Amortised Linear Cost
+
+  Based on section 3 of 
+
+    Christoph Herrmann, Edwin Brady and Kevin Hammond. 2011.
+    Dependently-typed Programming by Composition from Functional
+    Building Blocks.
+
+    In Draft Proceedings of the 12th International Symposium on Trends
+    in Functional Programming (TFP 2011). Tech. Rep. SIC-07/11,
+    Dept. Computer Systems and Computing, Universidad Complutense de
+    Madrid.
+-}
+
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+module Queue where
+
+data Vec :: * -> Num -> * where
+    Nil   :: forall a . Vec a 0
+    Cons  :: forall (n :: Nat) a . a -> Vec a n -> Vec a (n+1)
+  deriving Show
+
+
+data Queue :: * -> Num -> * where
+    Q :: forall elem . pi (a b c :: Nat) .
+             Vec elem a -> Vec elem b -> Queue elem (c + 3*a + b)
+  deriving Show
+
+initQueue = Q {0} {0} {0} Nil Nil
+
+enqueue :: forall elem (paid :: Nat) .
+               elem -> Queue elem paid -> Queue elem (paid + 4)
+enqueue x (Q {a} {b} {c} sA sB) = Q {a+1} {b} {c+1} (Cons x sA) sB
+
+reverseS :: forall elem (paid :: Nat) .
+                Queue elem paid -> Queue elem paid
+reverseS (Q {0}   {b} {c} Nil         sB) = Q {0} {b} {c} Nil sB
+reverseS (Q {a+1} {b} {c} (Cons x sA) sB) = reverseS (Q {a} {b+1} {c+2} sA (Cons x sB))
+
+dequeue :: forall elem (paid :: Nat) .
+               Queue elem paid -> (elem, Queue elem paid)
+dequeue (Q {a} {b+1} {c} sA (Cons x sB)) = (x, Q {a} {b} {c+1} sA sB)
+dequeue (Q {a+1} {0} {c} sA Nil)         = dequeue (reverseS (Q {a+1} {0} {c} sA Nil))
+
+
+
+data Queue2 :: * -> Num -> * where
+    Q2 :: forall elem (a b c :: Nat) .
+              Vec elem a -> Vec elem b -> Queue2 elem (c + 3*a + b)
+  deriving Show
+
+initQueue2 :: forall elem . Queue2 elem 0
+initQueue2 = Q2 Nil Nil
+
+enqueue2 :: forall elem (paid :: Nat) .
+                elem -> Queue2 elem paid -> Queue2 elem (paid + 4)
+enqueue2 x (Q2 sA sB) = Q2 (Cons x sA) sB
+
+reverseS2 :: forall elem (paid :: Nat) .
+                 Queue2 elem paid -> Queue2 elem paid
+reverseS2 (Q2 Nil         sB) = Q2 Nil sB
+reverseS2 (Q2 (Cons x sA) sB) = reverseS2 (Q2 sA (Cons x sB))
+
+dequeue2 :: forall elem (paid :: Nat) .
+                Queue2 elem paid -> (elem, Queue2 elem paid)
+dequeue2 (Q2 sA (Cons x sB)) = (x, Q2 sA sB)
+dequeue2 (Q2 sA Nil)         = dequeue2 (reverseS2 (Q2 sA Nil))
diff --git a/examples/RedBlack.hs b/examples/RedBlack.hs
new file mode 100644
--- /dev/null
+++ b/examples/RedBlack.hs
@@ -0,0 +1,273 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+{-
+  An implementation of red-black tree insertion and deletion using an
+  indexed zipper. The type indices guarantee that the ordering, colour
+  and height invariants are preserved. 
+-}
+
+module RedBlack where
+
+-- We can't (yet) lift types to kinds automatically, but we can
+-- represent finite enumerations using numbers. Here we use 0 for
+-- black and 1 for red, and use a singleton type to fake pi-types for
+-- colours. Proper lifting of algebraic data types to kinds would be
+-- better.
+
+type Black = 0
+type Red   = 1
+
+data Colour :: Integer -> * where
+    Black  :: Colour Black
+    Red    :: Colour Red
+  deriving Show
+
+data Tree :: Integer -> Integer -> Integer -> Nat -> * where
+    E   ::  forall (lo hi :: Integer) . lo < hi => Tree lo hi Black 0
+    TR  ::  forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) .
+                Tree lo x Black n -> Tree x hi Black n -> Tree lo hi Red n
+    TB  ::  forall (lo hi cl cr :: Integer)(n :: Nat) . pi (x :: Integer) .
+                Tree lo x cl n -> Tree x hi cr n -> Tree lo hi Black (n+1)
+  deriving Show
+
+data RBT :: Integer -> Integer -> * where
+    RBT :: forall (lo hi :: Integer)(n :: Nat) . Tree lo hi Black n -> RBT lo hi
+  deriving Show
+
+empty = RBT E
+
+data TreeZip ::  Integer -> Integer -> Integer -> Nat ->
+                 Integer -> Integer -> Integer -> Nat -> * where
+    Root  :: forall (lo hi c :: Integer)(n :: Nat) . TreeZip lo hi c n lo hi c n
+    ZRL   :: forall (rlo rhi lo hi rc :: Integer)(rn n :: Nat) . pi (x :: Integer) .
+                 TreeZip rlo rhi rc rn lo hi Red n -> Tree x hi Black n ->
+                     TreeZip rlo rhi rc rn lo x Black n
+    ZRR   :: forall (rlo rhi lo hi rc :: Integer)(rn n :: Nat) . pi (x :: Integer) .
+                 Tree lo x Black n -> TreeZip rlo rhi rc rn lo hi Red n  ->
+                     TreeZip rlo rhi rc rn x hi Black n
+    ZBL   :: forall (rlo rhi lo hi rc c hc :: Integer)(rn n  :: Nat) . pi (x :: Integer) . 
+                 TreeZip rlo rhi rc rn lo hi Black (n+1)  -> Tree x hi c n ->
+                     TreeZip rlo rhi rc rn lo x hc n
+    ZBR   :: forall (rlo rhi lo hi rc c hc :: Integer)(rn n  :: Nat) . pi (x :: Integer) .
+                 Tree lo x c n -> TreeZip rlo rhi rc rn lo hi Black (n+1) ->
+                     TreeZip rlo rhi rc rn x hi hc n
+  deriving Show
+
+plug ::  forall (rlo rhi lo hi rc rn c n :: Integer) . Tree lo hi c n ->
+             TreeZip rlo rhi rc rn lo hi c n -> Tree rlo rhi rc rn
+plug t Root           = t
+plug t (ZRL {x} z r)  = plug (TR {x} t r) z
+plug t (ZRR {x} l z)  = plug (TR {x} l t) z
+plug t (ZBL {x} z r)  = plug (TB {x} t r) z
+plug t (ZBR {x} l z)  = plug (TB {x} l t) z
+
+plugBR :: forall (rlo rhi lo hi n rn :: Integer) . Tree lo hi Black n ->
+              TreeZip rlo rhi Black rn lo hi Red n -> Tree rlo rhi Black rn
+plugBR t (ZBL {x} z r) = plug t (ZBL {x} z r)
+plugBR t (ZBR {x} l z) = plug t (ZBR {x} l z)
+
+data SearchResult :: Integer -> Integer -> Integer -> Integer -> * where
+  Nope  ::  forall (x rlo rhi lo hi :: Integer)(rn :: Nat) . (lo < x, x < hi) =>
+                TreeZip rlo rhi Black rn lo hi Black 0 -> SearchResult x rlo rhi rn
+  Yep   ::  forall (x rlo rhi lo hi c :: Integer)(rn n :: Nat) .
+                TreeZip rlo rhi Black rn lo hi c n -> Tree lo hi c n ->
+                    SearchResult x rlo rhi rn
+
+search ::  forall (rlo rhi :: Integer)(rn :: Nat) .
+               pi (x :: Integer) . (rlo < x, x < rhi) =>
+                    Tree rlo rhi Black rn -> SearchResult x rlo rhi rn
+search {x} = help Root
+  where
+    help ::  forall (lo hi c :: Integer)(n :: Nat) . (lo < x, x < hi) =>
+                 TreeZip rlo rhi Black rn lo hi c n -> Tree lo hi c n ->
+                     SearchResult x rlo rhi rn
+    help z E                       = Nope z
+    help z (TR {y} l r) | {x < y}  = help (ZRL {y} z r) l
+    help z (TR {y} l r) | {x ~ y}  = Yep z (TR {y} l r)
+    help z (TR {y} l r) | {x > y}  = help (ZRR {y} l z) r
+    help z (TB {y} l r) | {x < y}  = help (ZBL {y} z r) l
+    help z (TB {y} l r) | {x ~ y}  = Yep z (TB {y} l r)
+    help z (TB {y} l r) | {x > y}  = help (ZBR {y} l z) r
+
+member ::  forall (lo hi :: Integer) . pi (x :: Integer) . (lo < x, x < hi) =>
+               RBT lo hi -> Bool
+member {x} (RBT t) = case search {x} t of
+                       Nope _   -> False
+                       Yep _ _  -> True
+
+
+data InsProb :: Integer -> Integer -> Integer -> Integer -> * where
+  Level    ::  forall (lo hi c ci :: Integer)( n :: Nat) .
+                   Colour ci -> Tree lo hi ci n -> InsProb lo hi c n
+  PanicRB  ::  forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) .
+                   Tree lo x Red n -> Tree x hi Black n -> InsProb lo hi Red n
+  PanicBR  ::  forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) .
+                   Tree lo x Black n -> Tree x hi Red n -> InsProb lo hi Red n
+
+solveIns ::  forall (rlo rhi lo hi c rc :: Integer)(rn n :: Nat) . 
+                InsProb lo hi c n -> TreeZip rlo rhi rc rn lo hi c n ->
+                    RBT rlo rhi
+solveIns (Level c t)      Root           = rbt c t
+
+solveIns (Level Red t)    (ZRL {x} z r)  = solveIns (PanicRB {x} t r) z
+solveIns (Level Red t)    (ZRR {x} l z)  = solveIns (PanicBR {x} l t) z
+solveIns (Level Black t)  (ZRL {x} z r)  = solveIns (Level Red (TR {x} t r)) z
+solveIns (Level Black t)  (ZRR {x} l z)  = solveIns (Level Red (TR {x} l t)) z
+solveIns (Level col t)    (ZBL {x} z r)  = solveIns (Level Black (TB {x} t r)) z
+solveIns (Level col t)    (ZBR {x} l z)  = solveIns (Level Black (TB {x} l t)) z
+
+solveIns (PanicRB {xi} (TR {xil} lil ril) ri)  (ZBL {x} z r)  =
+    solveIns (Level Red (TR {xi} (TB {xil} lil ril) (TB {x} ri r))) z
+solveIns (PanicBR {xi} li (TR {xir} lir rir))  (ZBL {x} z r)  =
+    solveIns (Level Red (TR {xir} (TB {xi} li lir) (TB {x} rir r))) z
+
+solveIns (PanicRB {xi} (TR {xil} lil ril) ri)  (ZBR {x} l z)  =
+    solveIns (Level Red (TR {xil} (TB {x} l lil) (TB {xi} ril ri))) z
+solveIns (PanicBR {xi} li (TR {xir} lir rir))  (ZBR {x} l z)  =
+    solveIns (Level Red (TR {xi} (TB {x} l li) (TB {xir} lir rir))) z
+
+insert ::  forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) . (lo < x, x < hi) =>
+               Tree lo hi Black n -> RBT lo hi
+insert {x} t = case search {x} t :: SearchResult x lo hi n of
+    Nope z   -> solveIns (Level Red (TR {x} E E)) z
+    Yep _ _  -> RBT t
+
+
+r2b :: forall (lo hi n :: Integer) . Tree lo hi Red n -> Tree lo hi Black (n+1)
+r2b (TR {x} l r) = TB {x} l r
+
+rbt :: forall (lo hi c :: Integer)(n :: Nat) . Colour c -> Tree lo hi c n -> RBT lo hi
+rbt Black  t = RBT t
+rbt Red    t = RBT (r2b t)
+
+
+solveDel ::  forall (rlo rhi lo hi :: Integer)(rn n :: Nat) . Tree lo hi Black n ->
+                 TreeZip rlo rhi Black rn lo hi Black (n+1) -> RBT rlo rhi
+solveDel t Root = RBT t
+
+solveDel t (ZRL {x} z (TB {y} (TR {lx} ll lr) r)) = RBT (plug (TR {lx} (TB {x} t ll) (TB {y} lr r)) z)
+solveDel t (ZRL {x} z (TB {y} l (TR {rx} rl rr))) = RBT (plug (TR {y} (TB {x} t l) (TB {rx} rl rr)) z)
+
+-- Arrgh: these are one line in Agda because we can pattern match on the colours being black
+solveDel t (ZRL {x} z (TB {y} E E))              = RBT (plugBR (TB {x} t (TR {y} E E)) z)
+solveDel t (ZRL {x} z (TB {y} (TB {lx} ll lr) (TB {rx} rl rr)))  = RBT (plugBR (TB {x} t (TR {y} (TB {lx} ll lr) (TB {rx} rl rr))) z)
+
+
+solveDel t (ZRR {x} (TB {y} (TR {lx} ll lr) r) z)  = RBT (plug (TR {y} (TB {lx} ll lr) (TB {x} r t)) z)
+solveDel t (ZRR {x} (TB {y} l (TR {rx} rl rr)) z)  = RBT (plug (TR {rx} (TB {y} l rl) (TB {x} rr t)) z)
+
+-- Arrgh
+solveDel t (ZRR {x} (TB {y} E E) z)              = RBT (plugBR (TB {y} E (TR {x} E t)) z)
+solveDel t (ZRR {x} (TB {y} (TB {lx} ll lr) (TB {rx} rl rr)) z)  = RBT (plugBR (TB {y} (TB {lx} ll lr) (TR {x} (TB {rx} rl rr) t)) z)
+
+
+-- Arrgh
+solveDel t (ZBL {x} z (TR {y} (TB {lx} E lr) r))  = RBT (plug (TB {y} (TB {lx} (TR {x} t E) lr) r) z)
+solveDel t (ZBL {x} z (TR {y} (TB {lx} (TB {llx} lll llr) lr) r))  = RBT (plug (TB {y} (TB {lx} (TR {x} t (TB {llx} lll llr)) lr) r) z)
+
+solveDel t (ZBL {x} z (TR {y} (TB {lx} (TR {llx} lll llr) lr) r))  = RBT (plug (TB {llx} (TB {x} t lll) (TR {y} (TB {lx} llr lr) r)) z)
+
+-- Arrgh
+solveDel t (ZBL {x} z (TB {y} E r)) = solveDel (TB {y} (TR {x} t E) r) z
+solveDel t (ZBL {x} z (TB {y} (TB {lx} ll lr) r))  = solveDel (TB {y} (TR {x} t (TB {lx} ll lr)) r) z
+
+-- Arrgh
+solveDel t (ZBL {x} z (TB {y} (TR {lx} ll lr) E))  = solveDel (TB {lx} (TR {x} t ll) (TR {y} lr E)) z
+solveDel t (ZBL {x} z (TB {y} (TR {lx} ll lr) (TB {rx} rl rr)))  = solveDel (TB {lx} (TR {x} t ll) (TR {y} lr (TB {rx} rl rr))) z
+
+solveDel t (ZBL {x} z (TB {y} (TR {lx} ll lr) (TR {rx} rl rr))) = RBT (plug (TB {lx} (TB {x} t ll) (TB {y} lr (TR {rx} rl rr))) z)
+
+
+-- Arrgh
+solveDel t (ZBR {x} (TR {y} l (TB {rx} rl E)) z) = RBT (plug (TB {y} l (TB {rx} rl (TR {x} E t))) z)
+solveDel t (ZBR {x} (TR {y} l (TB {rx} rl (TB {rrx} rrl rrr))) z)  = RBT (plug (TB {y} l (TB {rx} rl (TR {x} (TB {rrx} rrl rrr) t))) z)
+
+solveDel t (ZBR {x} (TR {y} l (TB {rx} rl (TR {rrx} rrl rrr))) z)  = RBT (plug (TB {rrx} (TR {y} l (TB {rx} rl rrl)) (TB {x} rrr t)) z)
+
+-- Arrgh
+solveDel t (ZBR {x} (TB {y} l E) z)  = solveDel (TB {y} l (TR {x} E t)) z
+solveDel t (ZBR {x} (TB {y} l (TB {lx} ll lr)) z)  = solveDel (TB {y} l (TR {x} (TB {lx} ll lr) t)) z
+
+-- Arrgh
+solveDel t (ZBR {x} (TB {y} E (TR {rx} rl rr)) z)  = solveDel (TB {rx} (TR {y} E rl) (TR {x} rr t)) z
+solveDel t (ZBR {x} (TB {y} (TB {lx} ll lr) (TR {rx} rl rr)) z)  = solveDel (TB {rx} (TR {y} (TB {lx} ll lr) rl) (TR {x} rr t)) z
+
+solveDel t (ZBR {x} (TB {y} (TR {lx} ll lr) (TR {rx} rl rr)) z) = RBT (plug (TB {y} (TB {lx} ll lr) (TB {rx} rl (TR {x} rr t))) z)
+
+
+findMin ::  forall (rlo rhi lo hi c :: Integer)(rn n :: Nat) . Tree lo hi c (n+1) ->
+                (pi (k :: Integer) . lo < k => TreeZip rlo rhi Black rn k hi c (n+1)) ->
+                    RBT rlo rhi
+findMin (TR {x} (TB {y} E E) r)                    f = solveDel E (ZRL {x} (f {y}) r)
+findMin (TR {x} (TB {y} E (TR {lx} ll lr)) r)      f = RBT (plug (TB {lx} ll lr) (ZRL {x} (f {y}) r))
+
+findMin (TR {x} (TB {y} (TR {k} E E) lr) r)        f = RBT (plug E (ZBL {y} (ZRL {x} (f {k}) r) lr))
+
+findMin (TB {x} (TR {y} E E) r)                    f = RBT (plug E (ZBL {x} (f {y}) r))
+findMin (TB {x} E (TR {lx} ll lr))                 f = RBT (plug (TB {lx} ll lr) (f {x}))
+findMin (TB {x} E E)                               f = solveDel E (f {x})
+
+findMin (TR {x} (TB {y} (TB {llx} lll llr) lr) r)  f = findMin (TB {llx} lll llr) (\ {k} -> ZBL {y} (ZRL {x} (f {k}) r) lr)
+findMin (TB {x} (TB {lx} ll lr) r)                 f = findMin (TB {lx} ll lr)  (\ {k} -> ZBL {x} (f {k}) r)
+
+wkTree ::  forall (lo hi ha c n :: Integer) . hi < ha => Tree lo hi c n -> Tree lo ha c n
+wkTree E             = E
+wkTree (TR {x} l r)  = TR {x} l (wkTree r)
+wkTree (TB {x} l r)  = TB {x} l (wkTree r)
+
+delFocus ::  forall (rlo rhi lo hi c :: Integer)(rn n :: Nat) . Tree lo hi c n ->
+                 TreeZip rlo rhi Black rn lo hi c n -> RBT rlo rhi
+delFocus E                                   z = RBT (plug E z)
+delFocus (TR {x} E E)                        z = RBT (plugBR E z)
+delFocus (TR {x} l (TB {rx} rl rr))          z = findMin (TB {rx} rl rr) (\ {k} -> ZRR {k} (wkTree l) z)
+delFocus (TB {x} E E)                        z = solveDel E z
+delFocus (TB {x} (TR {y} E E) E)             z = RBT (plug (TB {y} E E) z)
+delFocus (TB {x} E (TR {y} E E))             z = RBT (plug (TB {y} E E) z)
+delFocus (TB {x} (TR {k} E E) (TR {y} E E))  z = RBT (plug (TB {k} E (TR {y} E E)) z)
+delFocus (TB {x} l (TB {rx} rl rr))          z = findMin (TB {rx} rl rr) (\ {k} -> ZBR {k} (wkTree l) z)
+delFocus (TB {x} (TB {lx} ll lr)  r)         z = findMin r (\ {k} -> ZBR {k} (wkTree (TB {lx} ll lr)) z)
+
+ 
+delete ::  forall (lo hi :: Integer) . pi (x :: Integer) . (lo < x, x < hi) =>
+               RBT lo hi -> RBT lo hi
+delete {x} (RBT t) = f (search {x} t)
+  where
+    f :: forall (n :: Nat) . SearchResult x lo hi n -> RBT lo hi
+    f (Nope _)   = RBT t
+    f (Yep z t)  = delFocus t z
+
+
+
+-- Suppose we want to hide the bounds from the user of our red-black
+-- tree library. In a dependently typed language, we could add top and
+-- bottom elements to the order, but we can't do so here for the
+-- integers. Instead, here's a solution that weakens the bounds on the
+-- tree as necessary. Note that wkTree2 could safely be implemented
+-- using unsafeCoerce. 
+
+data T where
+    T :: forall (n :: Nat)(lo hi :: Num) . Tree lo hi Black n -> T
+  deriving Show
+
+emptyT = T E
+
+rbtToT :: forall (lo hi :: Num) . RBT lo hi -> T
+rbtToT (RBT t) = T t
+
+insertT :: pi (x :: Num) . T -> T
+insertT {x} (T t) = rbtToT (insert {x} (weakling {x} t))
+
+deleteT :: pi (x :: Num) . T -> T
+deleteT {x} (T t) = rbtToT (delete {x} (RBT (weakling {x} t)))
+
+weakling :: forall (lo hi c n :: Num) . pi (x :: Num) . Tree lo hi c n ->
+              Tree (min lo (x-1)) (max hi (x+1)) c n
+weakling {x} t = wkTree2 t
+
+wkTree2 :: forall (lo lo' hi hi' c n :: Num) . (lo' <= lo, hi <= hi') =>
+               Tree lo hi c n -> Tree lo' hi' c n
+wkTree2 E            = E
+wkTree2 (TB {x} l r) = TB {x} (wkTree2 l) (wkTree2 r)
+wkTree2 (TR {x} l r) = TR {x} (wkTree2 l) (wkTree2 r)
diff --git a/examples/RedBlackCost.hs b/examples/RedBlackCost.hs
new file mode 100644
--- /dev/null
+++ b/examples/RedBlackCost.hs
@@ -0,0 +1,272 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+{-
+  An implementation of red-black tree insertion and deletion that uses
+  Nils Anders Danielsson's technique for semiformal time complexity
+  analysis to show that these operations are linear in black
+  height. See the RedBlack module for an implementation of the tree
+  operations without time complexity annotations, and the Cost module
+  for the definitions of the library primitives used in the analysis.
+-}
+
+module RedBlackCost where
+
+import Cost
+
+type Black = 0
+type Red   = 1
+
+data Colour :: Integer -> * where
+    Black  :: Colour Black
+    Red    :: Colour Red
+  deriving Show
+
+data Tree :: Integer -> Integer -> Integer -> Nat -> * where
+    E   :: forall (lo hi :: Integer) . lo < hi => Tree lo hi Black 0
+    TR  :: forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) .
+                   Tree lo x Black n -> Tree x hi Black n -> Tree lo hi Red n
+    TB  :: forall (lo hi cl cr :: Integer)(n :: Nat) . pi (x :: Integer) .
+               Tree lo x cl n -> Tree x hi cr n -> Tree lo hi Black (n+1)
+  deriving Show
+
+data RBT :: Integer -> Integer -> * where
+    RBT :: forall (lo hi :: Integer)(n :: Nat) . Tree lo hi Black n -> RBT lo hi
+  deriving Show
+
+empty = RBT E
+
+data TreeZip ::  Integer -> Integer -> Integer -> Nat ->
+                 Integer -> Integer -> Integer -> Nat -> 
+                 Nat -> * where
+    Root  :: forall (lo hi c :: Integer)(n :: Nat) . TreeZip lo hi c n lo hi c n 0
+    ZRL   :: forall (rlo rhi lo hi rc :: Integer)(rn n d :: Nat) . pi (x :: Integer) .
+                 TreeZip rlo rhi rc rn lo hi Red n d -> Tree x hi Black n ->
+                     TreeZip rlo rhi rc rn lo x Black n (d + 1)
+    ZRR   :: forall (rlo rhi lo hi rc :: Integer)(rn n d :: Nat) . pi (x :: Integer) .
+                 Tree lo x Black n -> TreeZip rlo rhi rc rn lo hi Red n d ->
+                     TreeZip rlo rhi rc rn x hi Black n (d + 1)
+    ZBL   :: forall (rlo rhi lo hi rc c hc :: Integer)(rn n d :: Nat) . pi (x :: Integer) . 
+                 TreeZip rlo rhi rc rn lo hi Black (n+1) d -> Tree x hi c n ->
+                     TreeZip rlo rhi rc rn lo x hc n (d + 1)
+    ZBR   :: forall (rlo rhi lo hi rc c hc :: Integer)(rn n d :: Nat) . pi (x :: Integer) .
+                 Tree lo x c n -> TreeZip rlo rhi rc rn lo hi Black (n+1) d ->
+                     TreeZip rlo rhi rc rn x hi hc n (d + 1)
+  deriving Show
+
+
+plug ::  forall (rlo rhi lo hi rc rn c n d :: Integer) . Tree lo hi c n ->
+             TreeZip rlo rhi rc rn lo hi c n d -> Cost (d + 1) (Tree rlo rhi rc rn)
+plug t Root           = tick (returnCost t)
+plug t (ZRL {x} z r)  = tick (plug (TR {x} t r) z)
+plug t (ZRR {x} l z)  = tick (plug (TR {x} l t) z)
+plug t (ZBL {x} z r)  = tick (plug (TB {x} t r) z)
+plug t (ZBR {x} l z)  = tick (plug (TB {x} l t) z)
+
+plugBR :: forall (rlo rhi lo hi n rn d :: Integer) . Tree lo hi Black n ->
+              TreeZip rlo rhi Black rn lo hi Red n d -> Cost (d + 1) (Tree rlo rhi Black rn)
+plugBR t (ZBL {x} z r) = plug t (ZBL {x} z r)
+plugBR t (ZBR {x} l z) = plug t (ZBR {x} l z)
+
+
+
+
+data SearchResult :: Integer -> Integer -> Integer -> Integer -> * where
+  Nope  :: forall (x rlo rhi lo hi :: Integer)(rn d :: Nat) .
+               (d <= (2 * rn), lo < x, x < hi) =>
+                   TreeZip rlo rhi Black rn lo hi Black 0 d -> SearchResult x rlo rhi rn
+  Yep   :: forall (x rlo rhi lo hi c :: Integer)(rn n d :: Nat) .
+               ((2 * n) + d) <= (2 * rn) =>
+                   TreeZip rlo rhi Black rn lo hi c n d -> Tree lo hi c n ->
+                       SearchResult x rlo rhi rn
+
+search ::  forall (rlo rhi :: Integer)(rn :: Nat) .
+               pi (x :: Integer) . (rlo < x, x < rhi) =>
+                   Tree rlo rhi Black rn -> Cost (2 * rn + 1) (SearchResult x rlo rhi rn)
+search {x} = helpB Root
+  where
+    help :: forall (lo hi c :: Integer)(n d :: Nat) .
+                ((1 + (2 * n) + d) <= (2 * rn), lo < x, x < hi) =>
+                    TreeZip rlo rhi Black rn lo hi c n d -> Tree lo hi c n ->
+                        Cost (2 + 2 * n) (SearchResult x rlo rhi rn)
+    help z E                      = tick (returnW (Nope z))
+    help z (TR {y} l r) | {x < y} = tick (helpB (ZRL {y} z r) l)
+    help z (TR {y} l r) | {x ~ y} = tick (returnW (Yep z (TR {y} l r)))
+    help z (TR {y} l r) | {x > y} = tick (helpB (ZRR {y} l z) r)
+    help z (TB {y} l r) | {x < y} = tick (weakenBy {1} (help (ZBL {y} z r) l))
+    help z (TB {y} l r) | {x ~ y} = tick (returnW (Yep z (TB {y} l r)))
+    help z (TB {y} l r) | {x > y} = tick (weakenBy {1} (help (ZBR {y} l z) r))
+
+    helpB :: forall (lo hi :: Integer)(n d :: Nat) .
+                 (((2 * n) + d) <= (2 * rn), lo < x, x < hi) =>
+                     TreeZip rlo rhi Black rn lo hi Black n d -> Tree lo hi Black n ->
+                         Cost (2 * n + 1) (SearchResult x rlo rhi rn)
+    helpB z E                      = tick (returnW (Nope z))
+    helpB z (TB {y} l r) | {x < y} = tick (help (ZBL {y} z r) l)
+    helpB z (TB {y} l r) | {x ~ y} = tick (returnW (Yep z (TB {y} l r)))
+    helpB z (TB {y} l r) | {x > y} = tick (help (ZBR {y} l z) r)
+
+
+member ::  forall (lo hi :: Integer)(n :: Nat) .
+               pi (x :: Integer) . (lo < x, x < hi) =>
+                   Tree lo hi Black n -> Cost (2 * n + 3) Bool
+member {x} t = tick (bindCost (search {x} t) f)
+  where
+    f :: SearchResult x lo hi n -> Cost 1 Bool
+    f (Nope _)   = tick (returnCost False)
+    f (Yep _ _)  = tick (returnCost True)
+
+
+data InsProb :: Integer -> Integer -> Integer -> Integer -> * where
+    Level    ::  forall (lo hi c ci :: Integer)( n :: Nat) .
+                    Colour ci -> Tree lo hi ci n -> InsProb lo hi c n
+    PanicRB  ::  forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) .
+                    Tree lo x Red n -> Tree x hi Black n -> InsProb lo hi Red n
+    PanicBR  ::  forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) .
+                    Tree lo x Black n -> Tree x hi Red n -> InsProb lo hi Red n
+  deriving Show
+
+solveIns :: forall (rlo rhi lo hi c rc :: Integer)(rn n d :: Nat) . 
+                InsProb lo hi c n -> TreeZip rlo rhi rc rn lo hi c n d ->
+                    Cost (d + 1) (RBT rlo rhi)
+solveIns (Level c t)      Root         = tick (returnCost (rbt c t))
+
+solveIns (Level Red t)    (ZRL {x} z r)  = tick (solveIns (PanicRB {x} t r) z)
+solveIns (Level Red t)    (ZRR {x} l z)  = tick (solveIns (PanicBR {x} l t) z)
+solveIns (Level Black t)  (ZRL {x} z r)  = tick (solveIns (Level Red (TR {x} t r)) z)
+solveIns (Level Black t)  (ZRR {x} l z)  = tick (solveIns (Level Red (TR {x} l t)) z)
+solveIns (Level col t)    (ZBL {x} z r)  = tick (solveIns (Level Black (TB {x} t r)) z)
+solveIns (Level col t)    (ZBR {x} l z)  = tick (solveIns (Level Black (TB {x} l t)) z)
+
+solveIns (PanicRB {xi} (TR {xil} lil ril) ri)  (ZBL {x} z r)  =
+    tick (solveIns (Level Red (TR {xi} (TB {xil} lil ril) (TB {x} ri r))) z)
+solveIns (PanicBR {xi} li (TR {xir} lir rir))  (ZBL {x} z r)  =
+    tick (solveIns (Level Red (TR {xir} (TB {xi} li lir) (TB {x} rir r))) z)
+
+solveIns (PanicRB {xi} (TR {xil} lil ril) ri)  (ZBR {x} l z)  =
+    tick (solveIns (Level Red (TR {xil} (TB {x} l lil) (TB {xi} ril ri))) z)
+solveIns (PanicBR {xi} li (TR {xir} lir rir))  (ZBR {x} l z)  =
+    tick (solveIns (Level Red (TR {xi} (TB {x} l li) (TB {xir} lir rir))) z)
+
+
+
+
+insert ::  forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) . (lo < x, x < hi) =>
+               Tree lo hi Black n -> Cost (4 * n + 6) (RBT lo hi)
+insert {x} t = tick (bindCost (search {x} t) f)
+  where
+    f :: SearchResult x lo hi n -> Cost (2 * n + 4) (RBT lo hi)
+    f (Nope z)   = tick (weaken (solveIns (Level Red (TR {x} E E)) z))
+    f (Yep _ _)  = tick (returnW (RBT t))
+
+
+r2b :: forall (lo hi n :: Integer) . Tree lo hi Red n -> Tree lo hi Black (n+1)
+r2b (TR {x} l r) = TB {x} l r
+
+rbt :: forall (lo hi c :: Integer)(n :: Nat) . Colour c -> Tree lo hi c n -> RBT lo hi
+rbt Black  t = RBT t
+rbt Red    t = RBT (r2b t)
+
+
+
+
+
+solveDel :: forall (rlo rhi lo hi :: Integer)(rn n d :: Nat) . Tree lo hi Black n ->
+                TreeZip rlo rhi Black rn lo hi Black (n+1) d ->
+                    Cost (d + 1) (RBT rlo rhi)
+solveDel t Root = tick (returnW (RBT t))
+
+solveDel t (ZRL {x} z (TB {y} (TR {lx} ll lr) r)) = tick (mapCost RBT (plug (TR {lx} (TB {x} t ll) (TB {y} lr r)) z))
+solveDel t (ZRL {x} z (TB {y} l (TR {rx} rl rr))) = tick (mapCost RBT (plug (TR {y} (TB {x} t l) (TB {rx} rl rr)) z))
+
+-- Arrgh: these are one line in Agda because we can pattern match on the colours being black
+solveDel t (ZRL {x} z (TB {y} E E))                = tick (mapCost RBT (plugBR (TB {x} t (TR {y} E E)) z))
+solveDel t (ZRL {x} z (TB {y} (TB {lx} ll lr) (TB {rx} rl rr)))  = tick (mapCost RBT (plugBR (TB {x} t (TR {y} (TB {lx} ll lr) (TB {rx} rl rr))) z))
+
+
+solveDel t (ZRR {x} (TB {y} (TR {lx} ll lr) r) z)  = tick (mapCost RBT (plug (TR {y} (TB {lx} ll lr) (TB {x} r t)) z))
+solveDel t (ZRR {x} (TB {y} l (TR {rx} rl rr)) z)  = tick (mapCost RBT (plug (TR {rx} (TB {y} l rl) (TB {x} rr t)) z))
+
+-- Arrgh
+solveDel t (ZRR {x} (TB {y} E E) z)              = tick (mapCost RBT (plugBR (TB {y} E (TR {x} E t)) z))
+solveDel t (ZRR {x} (TB {y} (TB {lx} ll lr) (TB {rx} rl rr)) z)  = tick (mapCost RBT (plugBR (TB {y} (TB {lx} ll lr) (TR {x} (TB {rx} rl rr) t)) z))
+
+
+-- Arrgh
+solveDel t (ZBL {x} z (TR {y} (TB {lx} E lr) r))  = tick (mapCost RBT (plug (TB {y} (TB {lx} (TR {x} t E) lr) r) z))
+solveDel t (ZBL {x} z (TR {y} (TB {lx} (TB {llx} lll llr) lr) r))  = tick (mapCost RBT (plug (TB {y} (TB {lx} (TR {x} t (TB {llx} lll llr)) lr) r) z))
+
+solveDel t (ZBL {x} z (TR {y} (TB {lx} (TR {llx} lll llr) lr) r))  = tick (mapCost RBT (plug (TB {llx} (TB {x} t lll) (TR {y} (TB {lx} llr lr) r)) z))
+
+-- Arrgh
+solveDel t (ZBL {x} z (TB {y} E r)) = tick (solveDel (TB {y} (TR {x} t E) r) z)
+solveDel t (ZBL {x} z (TB {y} (TB {lx} ll lr) r))  = tick (solveDel (TB {y} (TR {x} t (TB {lx} ll lr)) r) z)
+
+-- Arrgh
+solveDel t (ZBL {x} z (TB {y} (TR {lx} ll lr) E))  = tick (solveDel (TB {lx} (TR {x} t ll) (TR {y} lr E)) z)
+solveDel t (ZBL {x} z (TB {y} (TR {lx} ll lr) (TB {rx} rl rr)))  = tick (solveDel (TB {lx} (TR {x} t ll) (TR {y} lr (TB {rx} rl rr))) z)
+
+solveDel t (ZBL {x} z (TB {y} (TR {lx} ll lr) (TR {rx} rl rr))) = tick (mapCost RBT (plug (TB {lx} (TB {x} t ll) (TB {y} lr (TR {rx} rl rr))) z))
+
+
+-- Arrgh
+solveDel t (ZBR {x} (TR {y} l (TB {rx} rl E)) z) = tick (mapCost RBT (plug (TB {y} l (TB {rx} rl (TR {x} E t))) z))
+solveDel t (ZBR {x} (TR {y} l (TB {rx} rl (TB {rrx} rrl rrr))) z)  = tick (mapCost RBT (plug (TB {y} l (TB {rx} rl (TR {x} (TB {rrx} rrl rrr) t))) z))
+
+solveDel t (ZBR {x} (TR {y} l (TB {rx} rl (TR {rrx} rrl rrr))) z)  = tick (mapCost RBT (plug (TB {rrx} (TR {y} l (TB {rx} rl rrl)) (TB {x} rrr t)) z))
+
+-- Arrgh
+solveDel t (ZBR {x} (TB {y} l E) z)  = tick (solveDel (TB {y} l (TR {x} E t)) z)
+solveDel t (ZBR {x} (TB {y} l (TB {lx} ll lr)) z)  = tick (solveDel (TB {y} l (TR {x} (TB {lx} ll lr) t)) z)
+
+-- Arrgh
+solveDel t (ZBR {x} (TB {y} E (TR {rx} rl rr)) z)  = tick (solveDel (TB {rx} (TR {y} E rl) (TR {x} rr t)) z)
+solveDel t (ZBR {x} (TB {y} (TB {lx} ll lr) (TR {rx} rl rr)) z)  = tick (solveDel (TB {rx} (TR {y} (TB {lx} ll lr) rl) (TR {x} rr t)) z)
+
+solveDel t (ZBR {x} (TB {y} (TR {lx} ll lr) (TR {rx} rl rr)) z) = tick (mapCost RBT (plug (TB {y} (TB {lx} ll lr) (TB {rx} rl (TR {x} rr t))) z))
+
+
+findMin :: forall (rlo rhi lo hi c :: Integer)(rn n d :: Nat) . Tree lo hi c (n+1) ->
+               (pi (k :: Integer) . lo < k => TreeZip rlo rhi Black rn k hi c (n+1) d) ->
+                   Cost (3 * n + d + 4) (RBT rlo rhi)
+findMin (TR {x} (TB {y} E E) r)                    f = tick (weaken (solveDel E (ZRL {x} (f {y}) r)))
+findMin (TR {x} (TB {y} E (TR {lx} ll lr)) r)      f = tick (weaken (mapCost RBT (plug (TB {lx} ll lr) (ZRL {x} (f {y}) r))))
+
+findMin (TR {x} (TB {y} (TR {k} E E) lr) r)        f = tick (weaken (mapCost RBT (plug E (ZBL {y} (ZRL {x} (f {k}) r) lr))))
+
+findMin (TB {x} (TR {y} E E) r)                    f = tick (weaken (mapCost RBT (plug E (ZBL {x} (f {y}) r))))
+findMin (TB {x} E (TR {lx} ll lr))                 f = tick (weaken (mapCost RBT (plug (TB {lx} ll lr) (f {x}))))
+findMin (TB {x} E E)                               f = tick (weaken (solveDel E (f {x})))
+
+findMin (TR {x} (TB {y} (TB {llx} lll llr) lr) r)  f = tick (findMin (TB {llx} lll llr) (\ {k} -> ZBL {y} (ZRL {x} (f {k}) r) lr))
+findMin (TB {x} (TB {lx} ll lr) r)                 f = tick (weakenBy {1} (findMin (TB {lx} ll lr)  (\ {k} -> ZBL {x} (f {k}) r)))
+
+
+
+wkTree :: forall (lo hi ha c n :: Integer) . hi < ha => Tree lo hi c n -> Tree lo ha c n
+wkTree E            = E
+wkTree (TR {x} l r) = TR {x} l (wkTree r)
+wkTree (TB {x} l r) = TB {x} l (wkTree r)
+
+delFocus :: forall (rlo rhi lo hi c :: Integer)(rn n d :: Nat) . Tree lo hi c n ->
+                TreeZip rlo rhi Black rn lo hi c n d ->
+                    Cost (3 * n + d + 3) (RBT rlo rhi)
+delFocus (TR {x} E E)                        z = tick (weakenBy {1} (mapCost RBT (plugBR E z)))
+delFocus (TR {x} l (TB {rx} rl rr))          z = tick (findMin (TB {rx} rl rr) (\ {k} -> ZRR {k} (wkTree l) z))
+delFocus E                                   z = tick (weaken (mapCost RBT (plug E z)))
+delFocus (TB {x} E E)                        z = tick (weaken (solveDel E z))
+delFocus (TB {x} (TR {y} E E) E)             z = tick (weaken (mapCost RBT (plug (TB {y} E E) z)))
+delFocus (TB {x} E (TR {y} E E))             z = tick (weaken (mapCost RBT (plug (TB {y} E E) z)))
+delFocus (TB {x} (TR {k} E E) (TR {y} E E))  z = tick (weaken (mapCost RBT (plug (TB {k} E (TR {y} E E)) z)))
+delFocus (TB {x} l (TB {rx} rl rr))          z = tick (weakenBy {3} (findMin (TB {rx} rl rr) (\ {k} -> ZBR {k} (wkTree l) z)))
+delFocus (TB {x} (TB {lx} ll lr)  r)         z = tick (weakenBy {3} (findMin r (\ {k} -> ZBR {k} (wkTree (TB {lx} ll lr)) z)))
+
+
+delete :: forall (lo hi :: Integer)(n :: Nat) . pi (x :: Integer) . (lo < x, x < hi) =>
+           Tree lo hi Black n -> Cost (5 * n + 6) (RBT lo hi)
+delete {x} t = tick (bindCost (search {x} t) f)
+  where
+    f :: SearchResult x lo hi n -> Cost (3 * n + 4) (RBT lo hi)
+    f (Nope _)   = tick (returnW (RBT t))
+    f (Yep z t)  = tick (weaken (delFocus t z))
diff --git a/examples/Units.hs b/examples/Units.hs
new file mode 100644
--- /dev/null
+++ b/examples/Units.hs
@@ -0,0 +1,139 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+{-
+  An example of the need for type-level *integers* as well as natural
+  numbers: representing units of measure. Quantites can only be added
+  if the units match, and multiplication and division change the units
+  appropriately. There is no runtime representation of units, and
+  hence no runtime cost (at least there wouldn't be if Quantity was a
+  newtype).
+
+  See Bjorn Buckwalter's dimensional package
+  (http://dimensional.googlecode.com/) for a more comprehensive
+  implementation of this idea, using existing features of GHC Haskell.
+-}
+
+module Units (Quantity, dimensionless, metres, seconds, kilograms,
+                 minutes, hours, plus, minus, inv, times, over, scale,
+                 kilo, centi, units) where
+
+
+-- Unit collects indices for the powers of metres, seconds and grams
+-- (other units are omitted for simplicity). Quantity has a phantom
+-- type parameter which will usually be instantiated with some units,
+-- but this allows us to write functions that are completely
+-- polymorphic in the units very easily. Note that the Q constructor
+-- should not be exported!
+
+data Unit :: Integer -> Integer -> Integer -> * where
+
+data Quantity :: * -> * -> * where
+    Q :: forall a u . a -> Quantity u a
+  deriving Show
+
+
+type Dimensionless     = Unit 0 0 0
+type Metres            = Unit 1 0 0
+type Seconds           = Unit 0 1 0
+type Kilograms         = Unit 0 0 1
+type MetresPerSecond   = Unit 1 (-1) 0
+type Newtons           = Unit 1 (-2) 1
+
+
+-- Define some basic constructors
+
+dimensionless :: a -> Quantity Dimensionless a
+dimensionless = Q
+
+metres :: a -> Quantity Metres a
+metres = Q
+
+seconds :: a -> Quantity Seconds a
+seconds = Q
+
+kilograms :: a -> Quantity Kilograms a
+kilograms = Q
+
+minutes = (.) (scale 60) seconds
+hours   = (.) (scale 60) minutes
+
+
+-- Arithmetic of units
+
+plus :: Num a => Quantity u a -> Quantity u a -> Quantity u a
+plus (Q x) (Q y) = Q (x + y)
+
+minus :: Num a => Quantity u a -> Quantity u a -> Quantity u a
+minus (Q x) (Q y) = Q (x - y)
+
+inv :: forall (m s g :: Integer) a . Fractional a => 
+           Quantity (Unit m s g) a -> Quantity (Unit (-m) (-s) (-g)) a
+inv (Q x) = Q (recip x)
+
+times :: forall (m s g m' s' g' :: Integer) a . Num a => 
+             Quantity (Unit m s g) a -> Quantity (Unit m' s' g') a ->
+                 Quantity (Unit (m + m') (s + s') (g + g')) a
+times (Q x) (Q y) = Q (x * y)
+
+over x y = times x (inv y)
+
+scale :: Num a => a -> Quantity u a -> Quantity u a
+scale x (Q y) = Q (x * y)
+
+pow :: forall (m s g :: Integer) a . Fractional a =>
+           pi (k :: Nat) . Quantity (Unit m s g) a ->
+               Quantity (Unit (k * m) (k * s) (k * g)) a
+pow {k} (Q x) = Q ((^^) x k)
+
+sqr = pow {2}
+
+
+-- We can write unit prefixes as transformers of the constructors...
+
+type Prefix u a = (a -> Quantity u a) -> a -> Quantity u a
+
+prefix :: Num a => a -> Prefix u a
+prefix n f x = scale n (f x)
+
+kilo = prefix 1000
+centi = prefix (recip 100)
+milli = prefix (recip 1000)
+
+-- ...allowing things like this:
+
+km  = kilo metres
+cm  = centi metres
+mm  = milli metres
+g   = milli kilograms
+
+
+-- With a special name for flipped application, we can write
+--     units 3 cm                                    for  0.03 m
+--     units 15 (kilo metres) `over` units 3 hours   for  1.39 m/s
+
+units :: a -> (a -> Quantity u b) -> Quantity u b
+units x f = f x
+
+
+
+-- distanceTravelled :: (Num a, Fractional a) => Quantity Seconds a -> Quantity Metres a
+-- or we can just omit the type annotations, and get good inference behaviour
+distanceTravelled t = plus (times vel t) (times accel (sqr t))
+  where
+    vel    = over (units 2 metres) (units 1 seconds)
+    accel  = over (units 36 metres) (sqr (units 10 seconds))
+
+
+-- This is Kennedy's example of a function whose type cannot be
+-- inferred by the units-of-measure type system in F#, because of
+-- difficulties with generalisation (see Kennedy, Types for
+-- Units-of-Measure: Theory and Practice, 2009, section 3.10).
+
+nastyExample = \ x -> let d = div x
+                      in (d mass, d time)
+  where
+    div = over
+    mass = units 5 kilograms
+    time = units 3 seconds
diff --git a/examples/Vectors.hs b/examples/Vectors.hs
new file mode 100644
--- /dev/null
+++ b/examples/Vectors.hs
@@ -0,0 +1,118 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+module Vectors where
+
+data Vec :: * -> Nat -> * where
+  VNil  :: Vec a 0
+  VCons :: forall a (n :: Nat) . a -> Vec a n -> Vec a (n+1)
+  deriving Show
+
+vhead :: forall (n :: Nat) a. Vec a (n+1) -> a
+vhead (VCons x _) = x
+
+vtail :: forall (n :: Nat) a. Vec a (n+1) -> Vec a n
+vtail (VCons _ xs) = xs
+
+vappend :: forall (m n :: Nat) a .
+                Vec a m -> Vec a n -> Vec a (m+n)
+vappend VNil         ys = ys
+vappend (VCons x xs) ys = VCons x (vappend xs ys)
+
+vreverse :: forall (n :: Nat) a . Vec a n -> Vec a n
+vreverse xs = vrevapp xs VNil
+  where
+    vrevapp :: forall (m n :: Nat) a . Vec a m -> Vec a n -> Vec a (m+n)
+    vrevapp VNil         ys = ys
+    vrevapp (VCons x xs) ys = vrevapp xs (VCons x ys)
+
+vec :: pi (n :: Nat) . a -> Vec a n
+vec {0}   a = VNil
+vec {n+1} a = VCons a (vec {n} a)
+
+vmap :: forall (n :: Nat) a b . (a -> b) -> Vec a n -> Vec b n
+vmap f VNil         = VNil
+vmap f (VCons x xs) = VCons (f x) (vmap f xs)
+
+vzipWith :: forall (n :: Nat) a b c .
+                (a -> b -> c) -> Vec a n -> Vec b n -> Vec c n
+vzipWith f VNil VNil = VNil
+vzipWith f (VCons x xs) (VCons y ys) = VCons (f x y) (vzipWith f xs ys)
+
+vzip = vzipWith (,)
+
+vapp = vzipWith ($)
+
+vifold :: forall (n :: Nat) a (f :: Nat -> *) .
+           f 0 -> (forall (m :: Nat) . a -> f m -> f (m + 1)) ->
+             Vec a n -> f n
+vifold n c VNil         = n
+vifold n c (VCons x xs) = c x (vifold n c xs)
+
+vid = vifold VNil VCons
+
+
+data K :: * -> Integer -> * where
+  K :: forall a (n :: Integer) . a -> K a n
+  deriving Show
+
+unK (K a) = a
+
+vfold :: forall (n :: Nat) a b . b -> (a -> b -> b) -> Vec a n -> b
+vfold n c xs = unK (vifold (K n) (\ x ky -> K (c x (unK ky))) xs)
+
+vsum      = vfold 0 (+)
+vec2list  = vfold [] (:)
+
+
+plan :: pi (n :: Nat) . Vec Integer n
+plan {0}           = VNil
+plan {m} | {m > 0} = VCons m (plan {m-1})
+
+vlookup :: forall (n :: Nat) a . pi (m :: Nat) . m < n => Vec a n -> a
+vlookup {0}   (VCons x _)  = x
+vlookup {k+1} (VCons _ xs) = vlookup {k} xs
+
+vsplit :: forall (n :: Nat) a . pi (m :: Nat) . Vec a (m + n) -> (Vec a m, Vec a n)
+vsplit {0}   xs           = (VNil, xs)
+vsplit {m+1} (VCons x xs) = case vsplit {m} xs of
+                                (ys, zs) -> (VCons x ys, zs)
+
+vjoin :: forall a (m :: Nat) . Vec (Vec a m) m -> Vec a m
+vjoin VNil                     = VNil
+vjoin (VCons (VCons x xs) xss) = VCons x (vjoin (vmap vtail xss))
+
+vsnoc :: forall a (n :: Nat) . Vec a n -> a -> Vec a (n+1)
+vsnoc VNil          a = VCons a VNil
+vsnoc (VCons x xs)  a = VCons x (vsnoc xs a)
+
+
+type Matrix a (m :: Nat) (n :: Nat) = Vec (Vec a n) m
+
+mid :: forall a . Num a => pi (n :: Nat) . Matrix a n n
+mid {0}   = VNil
+mid {n+1} = VCons (VCons 1 (vec {n} 0))
+                  (vmap (VCons 0) (mid {n}))
+
+mfill :: pi (m n :: Nat) . a -> Matrix a m n
+mfill {m} {n} x = vec {m} (vec {n} x)
+
+mmult :: forall a (i j k :: Nat) . Num a => Matrix a i j -> Matrix a j k -> Matrix a i k
+mmult xij yjk = vmap (\ xj -> colSum (vzipWith ((.) vmap (*)) xj yjk)) xij
+  where
+    colSum :: forall a (m n :: Nat) . Num a => Vec (Vec a n) m -> Vec a n
+    colSum (VCons xs VNil) = xs
+    colSum (VCons xs xss) = vzipWith (+) xs (colSum xss)
+
+mshow :: forall a (m n :: Nat) . Show a => Matrix a m n -> String
+mshow VNil = ""
+mshow (VCons xs xss) = (++) (vshow xs) ('\n' : mshow xss) 
+  where
+    vshow :: forall (i :: Nat) . Vec a i -> String
+    vshow VNil = ""
+    vshow (VCons y ys) = (++) (show y) ('\t' : vshow ys) 
+
+m1234 :: Matrix Integer 2 2
+m1234 = VCons (VCons 1 (VCons 2 VNil))
+          (VCons (VCons 3 (VCons 4 VNil)) VNil) 
diff --git a/examples/Wires.hs b/examples/Wires.hs
new file mode 100644
--- /dev/null
+++ b/examples/Wires.hs
@@ -0,0 +1,212 @@
+{-# OPTIONS_GHC -F -pgmF inch #-}
+{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables,
+             NPlusKPatterns #-}
+
+module Wires where
+
+import Vectors
+
+
+-- A value of type Wire m a n b represents a process that consumes m
+-- inputs of type a and delivers n outputs of type b.
+
+data Wire :: Nat -> * -> Nat -> * -> * where
+  Stop  :: Wire 0 a 0 b
+  Say   :: forall (m n :: Nat) a b .
+               b -> Wire m a n b -> Wire m a (n+1) b
+  Ask   :: forall (m n :: Nat) a b .
+               (a -> Wire m a n b) -> Wire (m+1) a n b
+
+
+-- Given a vector of inputs, we can run it to produce a vector of outputs
+
+run :: forall (m n :: Nat) a b . Wire m a n b -> Vec a m -> Vec b n
+run Stop       VNil          = VNil
+run (Say a p)  xs            = VCons a (run p xs)
+run (Ask f)    (VCons x xs)  = run (f x) xs
+
+
+-- "Horizontal" composition of wires
+
+sequ :: forall (m n i j :: Nat) a b .
+            Wire m a i b -> Wire n a j b -> Wire (m + n) a (i + j) b
+sequ Stop       q = q
+sequ (Say b p)  q = Say b (sequ p q)
+sequ (Ask f)    q = Ask (\ x -> sequ (f x) q)
+
+
+-- "Vertical" composition of wires
+
+pipe :: forall (m n i :: Nat) a b c .
+            Wire m a n b -> Wire n b i c -> Wire m a i c
+pipe Stop       Stop       = Stop
+pipe (Ask f)    Stop       = Ask (\ x -> pipe (f x) Stop)
+pipe p          (Say b q)  = Say b (pipe p q)
+pipe (Say x p)  (Ask g)    = pipe p (g x)
+pipe (Ask f)    (Ask g)    = Ask (\ x -> pipe (f x) (Ask g))
+
+
+-- Some basic combinators and logic gates
+
+always p = Ask (\ zzz -> p)
+
+askB t f = Ask (bool t f)
+  where
+    bool t f True   = t
+    bool t f False  = f
+
+wire     = Ask (\ a -> Say a Stop)
+notGate  = Ask (\ b -> Say (not b) Stop)
+andGate  = askB wire (always (Say False Stop))
+split    = Ask (\ a -> Say a (Say a Stop))
+cross    = Ask (\ a -> Ask (\ b -> Say b (Say a Stop)))
+
+mkGate tt tf ft ff = askB (askB (Say tt Stop) (Say tf Stop))
+                          (askB (Say ft Stop) (Say ff Stop))
+
+orGate    = mkGate True True True False
+nandGate  = pipe andGate notGate
+norGate   = pipe orGate notGate
+xorGate   = askB notGate wire
+
+wires :: forall a. pi (n :: Nat) . Wire n a n a
+wires {0}   = Stop
+wires {n+1} = sequ wire (wires {n})
+
+manyWires = wires {1000}
+sillyWires {n} = wires {1000000*n}
+
+bind :: forall (m n j :: Nat) a . (0 < n, 0 < j) =>
+            Wire m a 1 a -> (a -> Wire n a j a) -> Wire (m + n) a j a 
+bind (Say a p) g = sequ p (g a)
+bind (Ask f)   g = Ask (\ x -> bind (f x) g)
+
+
+-- Half and full adders
+
+hadd :: Wire 2 Bool 2 Bool
+hadd = pipe (sequ split split)
+      (pipe (sequ wire (sequ cross wire))
+            (sequ andGate xorGate))
+
+fadd :: Wire 3 Bool 2 Bool
+fadd = pipe (sequ hadd wire)
+      (pipe (sequ wire hadd)
+            (sequ orGate wire))
+
+
+-- Converting from multiple wires to vectors and vice versa
+
+askVec :: forall a . pi (m :: Nat) . Wire m a 1 (Vec a m)
+askVec = help VNil
+  where
+    help :: forall a (k :: Nat) . Vec a k -> (pi (m :: Nat) . Wire m a 1 (Vec a (m+k)))
+    help xs {0}   = Say xs Stop
+    help xs {m+1} = Ask (\ x -> help (VCons x xs) {m})
+
+sayVec :: forall a b (k :: Nat) . Vec b k -> Wire 0 a k b
+sayVec VNil          = Stop
+sayVec (VCons x xs)  = Say x (sayVec xs)
+
+bundle :: forall a. pi (m :: Nat) . Wire (2*m) a 2 (Vec a m)
+bundle {m} = sequ (askVec {m}) (askVec {m})
+
+unbundle :: forall a . pi (m :: Nat) . Wire 2 (Vec a m) (2*m) a
+unbundle {m} = Ask (\ xs -> Ask (\ ys ->
+                   sequ (sayVec (vreverse xs)) (sayVec (vreverse ys))))
+
+
+-- Various bits and pieces to build a ripple-carry adder recursively
+
+crosses :: forall a . pi (k :: Nat) . Wire (4 * k) a (4 * k) a
+crosses {k} = pipe (sequ (bundle {k}) (bundle {k}))
+                  (pipe (sequ wire (sequ cross wire))
+                        (sequ (unbundle {k}) (unbundle {k})))
+
+ripple :: forall a . pi (m :: Nat) .
+              Wire (2 * 2 ^ m + 1) a (1 + 2 ^ m) a ->
+                  Wire (2 * 2 ^ (m+1) + 1) a (1 + 2 ^ (m+1)) a
+ripple {m} add | {0 <= 2 ^ m} = pipe (sequ (crosses {2 ^ m}) wire)
+                                   (pipe (sequ (wires {2 ^ (m+1)}) add)
+                                         (sequ add (wires {2 ^ m})))
+
+adder :: pi (m :: Nat) . Wire (2 * 2 ^ m + 1) Bool (1 + 2 ^ m) Bool
+adder {0}    = fadd
+adder {m+1}  = ripple {m} (adder {m})
+
+
+-- We don't have type-level div/mod (yet?) but can fake it thus
+
+divvy :: forall a. pi (n d :: Nat) . 1 <= d =>
+             (pi (m r :: Nat) . (n ~ d * m + r, r < d) => a) -> a
+divvy {n}    {d} f | {n < d} = f {0} {n}
+divvy {n}    {d} f | {n >= d} =
+                     let g :: pi (m r :: Nat) . (n - d ~ d * m + r, r < d) => a
+                         g {m} {r} = f {m+1} {r}
+                     in divvy {n-d} {d} g
+
+half :: forall a. pi (n :: Nat) . (pi (m r :: Nat) . (n ~ 2 * m + r, r <= 1) => a) -> a
+half {n} = divvy {n} {2}
+
+
+-- integerToBin {m} {n} is the m-bit unsigned binary representation of
+-- the number n; the type guarantees that n is in the range [0..2^m-1]
+
+integerToBin :: pi (m n :: Nat) . n < 2^m => Vec Bool m
+integerToBin {m} {n} = vreverse (toBin {m} {n})
+  where
+    toBin :: pi (m n :: Nat) . n < 2^m => Vec Bool m
+    toBin {0}   {n} = VNil
+    toBin {m+1} {n} = half {n} (\ {k} {r} -> VCons (odd r) (toBin {m} {k}))
+
+
+-- binToInteger converts an n-bit unsigned binary number (represented as a
+-- vector of booleans) to the corresponding integer
+
+binToInteger :: forall (n :: Nat) . Vec Bool n -> Integer
+binToInteger xs = fromBin (vreverse xs)
+  where
+    fromBin :: forall (n :: Nat) . Vec Bool n -> Integer
+    fromBin VNil = 0
+    fromBin (VCons True xs) = 1 + (2 * (fromBin xs))
+    fromBin (VCons False xs) = 2 * (fromBin xs)
+
+
+-- binToString converts a vector of booleans to a string
+-- representation of the corresponding binary number
+
+binToString xs = map btoc (vec2list xs)
+  where
+    btoc True   = '1'
+    btoc False  = '0'
+
+-- test :: forall (n :: Nat) . pi (m :: Nat) . Wire m Bool n Bool ->
+--             (pi (k :: Nat) . k < 2 ^ m => [Char])
+test  {m} p {k} = binToString  (run p (integerToBin {m} {k}))
+test' {m} p {k} = binToInteger (run p (integerToBin {m} {k}))
+
+
+-- Calculate 01 + 11 + 0 = 100 (note that 01110bin = 13dec)
+calc1 = test {5} (adder {1}) {13}
+
+-- Calculate 0101 + 1100 + 1 = 10010 (note that 010111001bin = 185dec)
+calc2 = test {9} (adder {2}) {185}
+
+
+
+-- "Horizontal" k-fold repetition of wires requires multiplication. At
+-- the moment we have to supply a lemma (operationally the identity
+-- function) that proves that a product of positive numbers is
+-- positive. A proxy is used as a substitute for type application.
+
+data Proxy :: Integer -> * where
+  Proxy :: forall (n :: Integer) . Proxy n
+
+nsequ :: forall (m n :: Nat) a b .
+           (forall (x y :: Nat) t . Proxy x -> Proxy y ->
+                                        (0 <= x * y => t) -> t) ->
+             (pi (k :: Nat) . Wire m a n b -> Wire (m * k) a (n * k) b)
+nsequ lem {0}    p = Stop
+nsequ lem {k+1}  p = lem (Proxy :: Proxy m) (Proxy :: Proxy k)
+                    (lem (Proxy :: Proxy n) (Proxy :: Proxy k)
+                        (sequ p (nsequ lem {k} p)))
diff --git a/inch.cabal b/inch.cabal
new file mode 100644
--- /dev/null
+++ b/inch.cabal
@@ -0,0 +1,84 @@
+Name:                inch
+Version:             0.1.0
+Synopsis:            A type-checker for Haskell with integer constraints
+Description:         
+    Inch is a type-checker for a subset of Haskell (plus some GHC
+    extensions) with the addition of integer constraints. After
+    successfully type-checking a source file, it outputs an
+    operationally equivalent version with the type-level integers
+    erased, so it can be used as a preprocessor in order to compile
+    programs.
+
+Homepage:            https://github.com/adamgundry/inch/
+bug-reports:         https://github.com/adamgundry/inch/issues
+License:             BSD3
+License-file:        LICENSE
+Author:              Adam Gundry <adam.gundry@strath.ac.uk>
+Maintainer:          Adam Gundry <adam.gundry@strath.ac.uk>
+Copyright:           Copyright (c) 2011 Adam Gundry
+Category:            Language
+Build-type:          Simple
+Extra-source-files:  README.md
+                     examples/Cost.hs
+                     examples/MergeSort.hs
+                     examples/NonlinearCost.hs
+                     examples/Queue.hs
+                     examples/RedBlack.hs
+                     examples/RedBlackCost.hs
+                     examples/Units.hs
+                     examples/Vectors.hs
+                     examples/Wires.hs
+data-dir:            data
+data-files:          *.inch
+
+Cabal-version:       >=1.8
+
+Executable inch
+  ghc-options:       -Wall -rtsopts
+  hs-source-dirs:    src
+  Main-is:           Language/Inch/Main.lhs
+  Build-depends:     base == 4.*,
+                         IndentParser == 0.2.*,
+                         parsec == 3.1.*,
+                         presburger == 0.4.*,
+                         pretty == 1.*,
+                         mtl == 2.0.*,
+                         containers == 0.4.*,
+                         filepath == 1.2.*
+  Other-modules:     Language.Inch.BwdFwd,
+                         Language.Inch.Check,
+                         Language.Inch.Context
+                         Language.Inch.Erase
+                         Language.Inch.Error
+                         Language.Inch.File
+                         Language.Inch.KindCheck
+                         Language.Inch.Kind
+                         Language.Inch.Kit
+                         Language.Inch.ModuleSyntax
+                         Language.Inch.Parser
+                         Language.Inch.PrettyPrinter
+                         Language.Inch.ProgramCheck
+                         Language.Inch.Solver
+                         Language.Inch.Syntax
+                         Language.Inch.TyNum
+                         Language.Inch.TypeCheck
+                         Language.Inch.Type
+                         Language.Inch.Unify         
+  
+Test-Suite test-inch
+    type:            exitcode-stdio-1.0
+    hs-source-dirs:  src tests
+    main-is:         Main.lhs
+    build-depends:   base == 4.*,
+                         IndentParser == 0.2.*,
+                         parsec == 3.1.*,
+                         presburger == 0.4.*,
+                         pretty == 1.*,
+                         mtl == 2.0.*,
+                         containers == 0.4.*,
+                         filepath == 1.2.*,
+                         directory == 1.1.*
+
+source-repository head
+  type:     git
+  location: git://github.com/adamgundry/inch.git
diff --git a/src/Language/Inch/BwdFwd.lhs b/src/Language/Inch/BwdFwd.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/BwdFwd.lhs
@@ -0,0 +1,40 @@
+> {-# LANGUAGE DeriveFunctor, DeriveFoldable #-}
+
+> module Language.Inch.BwdFwd where
+
+> import Data.Foldable
+> import Data.Monoid
+
+> data Fwd a = F0 | a :> Fwd a
+>     deriving (Eq, Show, Functor, Foldable)
+
+> data Bwd a = B0 | Bwd a :< a
+>     deriving (Eq, Show, Functor, Foldable)
+
+> infixr 8 :>
+> infixl 8 :<
+
+> instance Monoid (Fwd a) where
+>     mempty = F0
+>     F0         `mappend` ys = ys
+>     (x :> xs)  `mappend` ys = x :> (xs `mappend` ys)
+
+> (<>>) :: Bwd a -> Fwd a -> Fwd a
+> infixl 8 <>>
+> B0 <>> ys         = ys
+> (xs :< x) <>> ys  = xs <>> (x :> ys)
+
+> trail :: Bwd a -> [a]
+> trail B0 = []
+> trail (xs :< x) = trail xs ++ [x]
+
+
+> (<><<) :: Bwd a -> [a] -> Bwd a
+> as <><< [] = as
+> as <><< (b:bs) = (as :< b) <><< bs
+
+> fwdLength :: Fwd a -> Int
+> fwdLength = help 0
+>   where
+>     help i F0 = i
+>     help i (_ :> fs) = help (i+1) fs
diff --git a/src/Language/Inch/Check.lhs b/src/Language/Inch/Check.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Check.lhs
@@ -0,0 +1,94 @@
+> {-# LANGUAGE FlexibleContexts #-}
+
+> module Language.Inch.Check where
+
+> import Prelude hiding (all)
+> import Control.Applicative
+> import Control.Monad
+> import Data.Monoid
+> import Data.Foldable
+> import Control.Monad.State
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Context
+> import Language.Inch.Error
+> import Language.Inch.Kit
+> import Language.Inch.Kind hiding (All)
+> import Language.Inch.Type
+> import Language.Inch.PrettyPrinter
+> import Language.Inch.Syntax
+
+
+Set this to True in order to verify the context regularly:
+
+> paranoid :: Bool
+> paranoid = False
+
+> traceContext :: MonadState ZipState m => String -> m ()
+> traceContext s = getContext >>= \ g -> mtrace (s ++ "\n" ++ renderMe g)
+
+> defines :: Context -> Var () k -> Bool
+> defines B0                 _            = False
+> defines (_ :< A (b := _))  a | a =?= b  = True
+> defines (g :< _)           a            = defines g a
+
+> goodCx :: Context -> Bool
+> goodCx B0 = True
+> goodCx (g :< e) = goodEntry g e && goodCx g
+
+> goodEntry :: Context -> Entry -> Bool
+> goodEntry g (A (a := d))      = not (g `defines` a) && goodTyDef g d
+> goodEntry g (Constraint _ p)  = goodTy g p
+> goodEntry g (Layer l _)       = goodLayer g l
+
+> goodTyDef :: Context -> TyDef k -> Bool
+> goodTyDef g (Some t)  = goodTy g t
+> goodTyDef _ Hole      = True
+> goodTyDef _ Fixed     = True
+> goodTyDef _ Exists    = True
+
+> goodFV :: FV t () => Context -> t -> Bool
+> goodFV g = getAll . fvFoldMap (All . defines g)
+
+> goodLayer :: Context -> TmLayer -> Bool
+> goodLayer g (PatternTop (_ ::: s))  = goodTy g s
+> goodLayer _ CaseTop                 = True
+> goodLayer _ FunTop                  = True
+> goodLayer _ GenMark                 = True
+> goodLayer _ GuardTop                = True
+> goodLayer g (LamBody (_ ::: t))     = goodTy g t
+> goodLayer g (LetBindings bs)        = goodBindings g bs
+> goodLayer g (LetBody bs)            = goodBindings g bs
+
+> goodBindings :: Context -> Bindings -> Bool
+> goodBindings g = all (maybe True (goodTy g) . fst)
+
+
+> goodTy :: Context -> Type k -> Bool
+> goodTy = goodFV
+
+> goodDecl :: Context -> Declaration () -> Bool
+> goodDecl g (SigDecl _ t)        = goodTy g t
+> goodDecl _ (FunDecl _ _)        = True
+
+
+> verifyContext :: Bool -> String -> Contextual ()
+> verifyContext before s | paranoid = do
+>     g <- getContext
+>     unless (goodCx g) $ do
+>         traceContext $ "verifyContext: failed " ++ (if before then "before " else "after ") ++ s
+>         erk "Game over."
+>     return ()
+> verifyContext _ _ = return ()
+
+> wrapVerify :: String -> Contextual t -> Contextual t
+> wrapVerify s m = verifyContext True s *> m <* verifyContext False s
+
+
+
+> assertContextEmpty :: Contextual ()
+> assertContextEmpty = do
+>     g <- getContext
+>     case g of
+>         B0  -> return ()
+>         _   -> traceContext "assertContextEmpty" >> erk "Error: context is not empty"
diff --git a/src/Language/Inch/Context.lhs b/src/Language/Inch/Context.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Context.lhs
@@ -0,0 +1,551 @@
+> {-# LANGUAGE DeriveFunctor, DeriveFoldable, TypeOperators, FlexibleContexts,
+>              GADTs, RankNTypes, TypeSynonymInstances,
+>              MultiParamTypeClasses, FlexibleInstances #-}
+
+> module Language.Inch.Context where
+
+> import Control.Applicative
+> import Control.Monad.Error
+> import Control.Monad.State
+> import Control.Monad.Writer hiding (All)
+> import qualified Data.Map as Map
+> import Data.Map (Map)
+> import Data.Foldable
+> import Text.PrettyPrint.HughesPJ
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.Syntax hiding (Alternative)
+> import Language.Inch.ModuleSyntax
+> import Language.Inch.PrettyPrinter
+> import Language.Inch.Kit
+> import Language.Inch.Error
+
+> type Bindings = Map TmName (Maybe Sigma, Bool)
+
+> data TmLayer  =  PatternTop  (TmName ::: Sigma)
+>               |  CaseTop
+>               |  FunTop
+>               |  GenMark
+>               |  GuardTop
+>               |  LamBody (TmName ::: Tau)
+>               |  LetBindings {letBindings :: Bindings}
+>               |  LetBody {letBindings :: Bindings}
+
+> instance Show TmLayer where
+>   show (PatternTop (x ::: _))  = "PatternTop " ++ x
+>   show CaseTop                 = "CaseTop"
+>   show FunTop                  = "FunTop"
+>   show GenMark                 = "GenMark"
+>   show GuardTop                = "GuardTop"
+>   show (LamBody (x ::: _))     = "LamBody " ++ x
+>   show (LetBindings _)         = "LetBindings"
+>   show (LetBody _)             = "LetBody"
+
+> instance FV TmLayer () where
+>     fvFoldMap f (PatternTop (_ ::: s))  = fvFoldMap f s
+>     fvFoldMap _ CaseTop                 = mempty
+>     fvFoldMap _ FunTop                  = mempty
+>     fvFoldMap _ GenMark                 = mempty
+>     fvFoldMap _ GuardTop                = mempty
+>     fvFoldMap f (LamBody (_ ::: t))     = fvFoldMap f t
+>     fvFoldMap f (LetBindings bs)        = foldMap (foldMap (fvFoldMap f)) (map fst . Map.elems $ bs)
+>     fvFoldMap f (LetBody bs)            = foldMap (foldMap (fvFoldMap f)) (map fst . Map.elems $ bs)
+
+> instance Pretty TmLayer where
+>   pretty l = const $ text $ show l
+
+> matchLayer :: TmLayer -> TmLayer -> Bool
+> matchLayer (PatternTop (x ::: _))  (PatternTop (y ::: _))  = x == y
+> matchLayer CaseTop                 CaseTop                 = True
+> matchLayer FunTop                  FunTop                  = True
+> matchLayer GenMark                 GenMark                 = True
+> matchLayer GuardTop                GuardTop                = True
+> matchLayer (LamBody (x ::: _))     (LamBody (y ::: _))     = x == y
+> matchLayer (LetBindings _)         (LetBindings _)         = True
+> matchLayer (LetBody _)             (LetBody _)             = True
+> matchLayer _                       _                       = False
+
+
+The |withLayerExtract| function takes two boolean parameters: |stop|
+indicates whether the layer should stop numeric unification
+constraints, and |forget| indicates whether hypotheses should be dropped
+when the layer is extracted.
+
+> withLayerExtract :: Bool -> Bool -> TmLayer -> (TmLayer -> a) -> Contextual t -> Contextual (t, a)
+> withLayerExtract stop forget l f m = do
+>     modifyContext (:< Layer l stop)
+>     t <- m
+>     (g, a) <- extract <$> getContext
+>     putContext g
+>     return (t, a)
+>   where
+>     extract (g :< Layer l' z) | matchLayer l l'  = (g, f l')
+>                               | otherwise        = error $ "withLayerExtract: wrong layer in " ++ renderMe (g :< Layer l' z) ++ " (looking for " ++ renderMe l ++ ")"
+>     extract (g :< Constraint Given _) | forget = extract g
+>     extract (g :< e)                         = (g' :< e, a)
+>       where (g', a) = extract g
+>     extract B0 = error $ "withLayerExtract: ran out of context"
+
+> withLayer :: Bool -> Bool -> TmLayer -> Contextual t -> Contextual t
+> withLayer stop forget l m = fst <$> withLayerExtract stop forget l (const ()) m
+
+
+
+> data CStatus = Given | Wanted
+>   deriving Show
+
+
+> data TyDef k = Hole | Some (Type k) | Fixed | Exists
+>   deriving Show
+
+> instance FV (TyDef k) () where
+>     fvFoldMap f (Some t)  = fvFoldMap f t
+>     fvFoldMap _ _         = mempty
+
+> instance Pretty (TyDef k) where
+>   pretty Hole      _ = text "?"
+>   pretty Fixed     _ = text "!"
+>   pretty Exists    _ = text "Ex"
+>   pretty (Some t)  l = pretty (fogSysTy t) l
+
+
+> type TyEntry k = Var () k := TyDef k
+
+> instance FV (TyEntry k) () where
+>     fvFoldMap f (b := d) = fvFoldMap f b <.> fvFoldMap f d
+
+> instance Pretty (TyEntry k) where
+>     pretty (a := d) _ = prettySysVar a <+> text ":="
+>       <+> prettyHigh d <+> text ":" <+> prettyHigh (fogKind (varKind a))
+
+> replaceTyEntry :: Var () k -> Type k -> Entry -> Entry
+> replaceTyEntry a t (A (b := Some d)) = A (b := Some (replaceTy a t d))
+> replaceTyEntry _ _ (A a) = A a
+> replaceTyEntry a@(FVar _ KNum) t (Constraint s p) = Constraint s (replaceTy a t p)
+> replaceTyEntry _ _ x = x
+
+> data AnyTyEntry where
+>     TE :: TyEntry k -> AnyTyEntry
+
+> instance Show AnyTyEntry where
+>     show (TE t) = show t
+
+> instance FV AnyTyEntry () where
+>     fvFoldMap f (TE t) = fvFoldMap f t
+
+
+
+
+> data Entry where
+>     A           :: TyEntry k -> Entry
+>     Layer       :: TmLayer -> Bool -> Entry
+>     Constraint  :: CStatus -> Type KConstraint -> Entry
+
+> instance FV Entry () where
+>     fvFoldMap f (A t)             = fvFoldMap f t
+>     fvFoldMap f (Layer l _)       = fvFoldMap f l
+>     fvFoldMap f (Constraint _ c)  = fvFoldMap f c
+
+> instance Pretty Entry where
+>   pretty (A a)                  _ = prettyHigh a
+>   pretty (Layer l _)            _ = prettyHigh l
+>   pretty (Constraint Given p)   _ =
+>       braces (prettyHigh $ fogSysTy p) <> text "!!"
+>   pretty (Constraint Wanted p)  _ =
+>       braces (prettyHigh $ fogSysTy p) <> text "??"
+
+
+
+> defToMaybe :: TyDef k -> Maybe (Type k)
+> defToMaybe (Some t)  = Just t
+> defToMaybe _         = Nothing
+
+> type Context  = Bwd Entry
+> type Suffix   = Fwd AnyTyEntry
+
+> (<><) :: Context -> Suffix -> Context
+> _Gamma <>< F0                   = _Gamma
+> _Gamma <>< (TE e :> _Xi)  = _Gamma :< A e <>< _Xi
+> infixl 8 <><
+
+> data ZipState = St  {  nextFreshInt  :: Int
+>                     ,  context       :: Context
+>                     ,  tyCons        :: Map TyConName (Ex Kind)
+>                     ,  tmCons        :: Map TmConName Sigma
+>                     ,  tySyns        :: Map TyConName (Ex (TySyn ()))
+>                     ,  bindings      :: Bindings
+>                     ,  classes       :: Map ClassName ClassDeclaration
+>                     ,  instances     :: Map ClassName [Type KConstraint]
+>                     }
+
+
+Initial state
+
+> tyInteger, tyBool, tyOrdering, tyUnit, tyChar, tyString, tyIntLit :: Ty a KSet
+> tyInteger     = TyCon "Integer" KSet
+> tyBool        = TyCon "Bool" KSet
+> tyOrdering    = TyCon "Ordering" KSet
+> tyUnit        = TyCon unitTypeName KSet
+> tyChar        = TyCon "Char" KSet
+> tyString      = tyList tyChar
+
+> tyIntLit      = Bind All "a" KSet
+>                     $ Qual (TyCon "Num" (KSet :-> KConstraint) `TyApp` TyVar (BVar Top))
+>                            (TyVar (BVar Top))
+
+> tyMaybe, tyList :: Ty a KSet -> Ty a KSet
+> tyMaybe       = TyApp (TyCon "Maybe" (KSet :-> KSet))
+> tyList        = TyApp (TyCon listTypeName (KSet :-> KSet))
+
+> tyEither, tyTuple :: Ty a KSet -> Ty a KSet -> Ty a KSet
+> tyEither a b  = TyApp (TyApp (TyCon "Either" (KSet :-> KSet :-> KSet)) a) b
+> tyTuple       = TyApp . TyApp (TyCon tupleTypeName (KSet :-> KSet :-> KSet))
+
+> tyTrivial :: Ty a KConstraint
+> tyTrivial = TyCon "Trivial" KConstraint
+
+> isTrivial :: Ty a KConstraint -> Bool
+> isTrivial (TyCon "Trivial" KConstraint)  = True
+> isTrivial _                              = False
+
+
+> initialState :: ZipState
+> initialState = St { nextFreshInt = 0
+>                   , context = B0
+>                   , tyCons = initTyCons
+>                   , tmCons = initTmCons
+>                   , tySyns = Map.empty
+>                   , bindings = initBindings
+>                   , classes = Map.empty
+>                   , instances = Map.empty
+>                   }
+>   where
+>     initTyCons = Map.fromList $
+>       ("Char",        Ex KSet) :
+>       ("Integer",     Ex KSet) :
+>       (listTypeName,  Ex (KSet :-> KSet)) :
+>       (unitTypeName,  Ex KSet) :
+>       (tupleTypeName, Ex (KSet :-> KSet :-> KSet)) :
+>       ("Trivial",     Ex KConstraint) :
+>       []
+>     initTmCons = Map.fromList $
+>       (listNilName,   Bind All "a" KSet (tyList (TyVar (BVar Top)))) :
+>       (listConsName,  Bind All "a" KSet (TyVar (BVar Top) --> tyList (TyVar (BVar Top)) --> tyList (TyVar (BVar Top)))) :
+>       (unitConsName,  tyUnit) :
+>       (tupleConsName, Bind All "a" KSet (Bind All "b" KSet (TyVar (BVar (Pop Top)) --> TyVar (BVar Top) --> tyTuple (TyVar (BVar (Pop Top))) (TyVar (BVar Top))))) :
+>       []
+>     initBindings = Map.fromList $
+>       []
+
+
+
+
+> type Contextual a          = StateT ZipState (Either ErrorData) a
+> type ContextualWriter w a  = WriterT w (StateT ZipState (Either ErrorData)) a
+
+
+Fresh names
+
+> freshVar :: MonadState ZipState m =>
+>                 VarState -> String -> Kind k -> m (Var () k)
+> freshVar vs s k = do
+>     st <- get
+>     let beta = nextFreshInt st
+>     put st{nextFreshInt = succ beta}
+>     return $ FVar (N s beta vs) k
+
+> fresh :: MonadState ZipState m =>
+>              VarState -> String -> Kind k -> TyDef k -> m (Var () k)
+> fresh vs s k d = do
+>     v <- freshVar vs s k
+>     modifyContext (:< A (v := d))
+>     return v
+
+> unknownTyVar :: (Functor m, MonadState ZipState m) =>
+>                     String -> Kind k -> m (Type k)
+> unknownTyVar s k = TyVar <$> fresh SysVar s k Hole
+
+> tyVarNamesInScope :: (Functor m, MonadState ZipState m) => m [String]
+> tyVarNamesInScope = help <$> getContext
+>   where
+>     help :: Context -> [String]
+>     help B0                 = []
+>     help (g :< A (v := _))  = nameToString (varName v) : help g
+>     help (g :< _)           = help g
+
+
+Context
+
+> getContext :: MonadState ZipState m => m Context
+> getContext = gets context
+>
+> putContext :: MonadState ZipState m => Context -> m ()
+> putContext _Gamma = modify $ \ st -> st{context = _Gamma}
+>
+> modifyContext :: MonadState ZipState m => (Context -> Context) -> m ()
+> modifyContext f = getContext >>= putContext . f
+
+
+Type constructors
+
+> insertTyCon :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                    TyConName -> Ex Kind -> m ()
+> insertTyCon x k = do
+>     st <- get
+>     when (Map.member x (tyCons st)) $ errDuplicateTyCon x
+>     put st{tyCons = Map.insert x k (tyCons st)}
+
+> lookupTyCon :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                    TyConName -> m (Ex Kind)
+> lookupTyCon x = do
+>     tcs <- gets tyCons
+>     case Map.lookup x tcs of
+>         Just k   -> return k
+>         Nothing  -> missingTyCon x
+
+
+Data constructors
+
+> insertTmCon :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                    TmConName -> Sigma -> m ()
+> insertTmCon x ty = do
+>     st <- get
+>     when (Map.member x (tmCons st)) $ errDuplicateTmCon x
+>     put st{tmCons = Map.insert x ty (tmCons st)}
+
+> lookupTmCon :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                     TmConName -> m Sigma
+> lookupTmCon x = do
+>     tcs <- gets tmCons
+>     case Map.lookup x tcs of
+>         Just ty  -> return ty
+>         Nothing  -> missingTmCon x
+
+
+
+Bindings
+
+> lookupBindingIn :: (MonadError ErrorData m) =>
+>                    TmName -> Bindings -> m (Term () ::: Sigma, Bool)
+> lookupBindingIn x bs = case Map.lookup x bs of
+>     Just (Just ty, u)  -> return (TmVar x ::: ty, u)
+>     Just (Nothing, _)  -> erk "Mutual recursion requires explicit signatures"
+>     Nothing            -> missingTmVar x
+
+> insertBindingIn :: MonadError ErrorData m =>
+>                    String -> a -> Map.Map String a -> m (Map.Map String a)
+> insertBindingIn x ty bs = do
+>     when (Map.member x bs) $ errDuplicateTmVar x
+>     return $ Map.insert x ty bs
+
+> lookupTopBinding :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                    TmName -> m (Term () ::: Sigma, Bool)
+> lookupTopBinding x = lookupBindingIn x =<< gets bindings 
+
+> modifyTopBindings :: MonadState ZipState m => (Bindings -> m Bindings) -> m ()
+> modifyTopBindings f = do
+>     st <- get
+>     bs <- f (bindings st)
+>     put st{bindings = bs}
+
+> insertTopBinding :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                      TmName -> (Maybe Sigma, Bool) -> m ()
+> insertTopBinding x ty = modifyTopBindings $ insertBindingIn x ty
+
+> updateTopBinding :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                      TmName -> (Maybe Sigma, Bool) -> m ()
+> updateTopBinding x ty = modifyTopBindings (return . Map.insert x ty)
+
+
+> lookupBinding :: (MonadError ErrorData m, MonadState ZipState m, Alternative m) =>
+>                      TmName -> m (Term () ::: Sigma, Bool)
+> lookupBinding x = help =<< getContext
+>   where
+>     help B0                               = lookupTopBinding x
+>     help (_ :< Layer (LetBindings bs) _)  = lookupBindingIn x bs
+>     help (g :< _)                         = help g
+
+> modifyBindings :: (Bindings -> Contextual Bindings) -> Contextual ()
+> modifyBindings f = flip help [] =<< getContext
+>   where
+>     help :: Context -> [Entry] -> Contextual ()
+>     help B0 _ = modifyTopBindings f
+>     help (g :< Layer (LetBindings bs) z) h = do
+>         bs' <- f bs
+>         putContext $ (g :< Layer (LetBindings bs') z) <><< h
+>     help (g :< e) h = help g (e:h)
+
+> insertBinding, updateBinding :: TmName -> (Maybe Sigma, Bool) -> Contextual ()
+> insertBinding x ty = modifyBindings $ insertBindingIn x ty
+> updateBinding x ty = modifyBindings $ return . Map.insert x ty
+
+
+
+> {-
+> seekTy :: Context -> TyName -> Ex Type
+> seekTy (g :< A (b := d ::: k))  a | a == b  = case d of  Some t  -> t
+>                                                          _       -> TyVar (FVar b k)
+> seekTy (g :< _)                 a           = seekTy g a
+> seekTy B0                       a           = error "seekTy: missing!"
+> -}
+
+> {-
+
+> expandContext :: Context -> Context
+> expandContext B0 = B0
+> expandContext (g :< A (a := Some t))  = expandContext g
+> expandContext (g :< a@(A _))          = expandContext g :< a
+> expandContext (g :< Constraint s p)   =
+>     expandContext g :< Constraint s (fmap (substTy (expandTyVar g)) p)
+> expandContext (g :< Layer l) =
+>     expandContext g :< Layer (bindLayerTypes (expandTyVar g) l)
+
+
+> expandTyVar :: Context -> Var () k -> Type k
+> expandTyVar g a = case seek g a of
+>     Some d  -> expandType g d
+>     _       -> TyVar a
+>   where
+>     seek (g :< A (b := d))  a = hetEq a b d (seek g a)
+>     seek (g :< _)           a           = seek g a
+>     seek B0                 a           = error "expandTyVar: erk"
+
+> expandType :: Context -> Type k -> Type k
+> expandType g = substTy (expandTyVar g)
+    
+> expandPred :: Context -> Predicate -> Predicate
+> expandPred g = fmap (expandType g)
+
+> niceType :: Type KSet -> Contextual (Type KSet)
+> niceType t = (\ g -> simplifyTy (expandType g t)) <$> getContext
+
+> nicePred :: Predicate -> Contextual Predicate
+> nicePred p = (\ g -> simplifyPred (expandPred g p)) <$> getContext
+
+> -}
+
+
+
+> lookupTyVar :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                    Binder -> Bwd (Ex (Var ())) -> String -> m (Ex (Var ()))
+> lookupTyVar b (g :< Ex a) x
+>     | varNameEq a x  = checkBinder b a >> return (Ex a)
+>     | otherwise      = lookupTyVar b g x
+> lookupTyVar b B0 x = getContext >>= seek
+>   where
+>     seek B0 = missingTyVar x
+>     seek (_ :< A (a := _)) | varNameEq a x = checkBinder b a >> return (Ex a)
+>     seek (g :< _) = seek g
+
+> checkBinder :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                    Binder -> Var () k -> m ()
+> checkBinder All  _  = return ()
+> checkBinder Pi   a  = case (varKind a, varBinder a) of
+>                         (KNum, Just Pi)  -> return ()
+>                         (KNum, _)        -> errBadBindingLevel a
+>                         _                -> errNonNumericVar a
+
+
+> lookupTmVar :: (Alternative m, MonadState ZipState m, MonadError ErrorData m) =>
+>                    TmName -> m (Term () ::: Sigma)
+> lookupTmVar x = getContext >>= seek
+>   where
+>     seek B0 = fst <$> lookupTopBinding x
+>     seek (_ :< Layer (LamBody (y ::: ty)) _)
+>         | x == y = return $ TmVar y ::: ty
+>     seek (g :< Layer (LetBody bs) _)   = (fst <$> lookupBindingIn x bs) <|> seek g
+>     seek (g :< Layer (LetBindings bs) _)  = (fst <$> lookupBindingIn x bs) <|> seek g
+>     seek (g :< Layer (PatternTop (y ::: ty)) _)
+>         | x == y     = return $ TmVar y ::: ty
+>         | otherwise  = seek g
+>     seek (g :< _) = seek g
+
+
+
+Type synonyms
+
+
+> insertTySyn :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                        TyConName -> TypeSyn k -> m ()
+> insertTySyn x t = do
+>     st <- get
+>     when (Map.member x (tyCons st)) $ erk $ "Duplicate type constructor and type synonym " ++ x
+>     when (Map.member x (tySyns st)) $ erk $ "Duplicate type synonym " ++ x
+>     put st{tySyns = Map.insert x (Ex t) (tySyns st)}
+
+
+> lookupTySyn ::  (MonadState ZipState m, MonadError ErrorData m) =>
+>                        TyConName -> m (Ex (TySyn (())))
+> lookupTySyn x = do
+>     ts <- gets tySyns
+>     case Map.lookup x ts of
+>         Just t   -> return t
+>         Nothing  -> erk $ "Missing type synonym " ++ x
+
+
+
+> data Args a k l where
+>     A0    :: Args a k k
+>     (:$)  :: Ty a j -> Args a k l -> Args a (j :-> k) l
+
+> ($:$) :: Ty a k -> Args a k l -> Ty a l
+> t $:$ A0 = t
+> t $:$ (a :$ as) = (t `TyApp` a) $:$ as
+
+
+> expandTySyns :: Ty a k -> Contextual (Ty a k)
+> expandTySyns u = help u A0
+>   where
+>     help :: Ty a k -> Args a k l -> Contextual (Ty a l)
+>     help (TySyn _ ts) as = expandTySyns =<< appTySyn ts as
+>     help (TyApp f a) as = do
+>         a' <- expandTySyns a
+>         help f (a' :$ as)
+>     help (Bind b x k t) A0 = Bind b x k <$> expandTySyns t
+>     help (Bind _ _ _ _) _  = error "expandTySyns: bad bind"
+>     help (Qual p t) A0 = Qual <$> expandTySyns p <*> expandTySyns t
+>     help (Qual _ _) _  = error "expandTySyns: bad qual"
+>     help t as = return (t $:$ as)
+
+>     appTySyn :: TySyn a k -> Args a k l -> Contextual (Ty a l)
+>     appTySyn (SynTy t) as = return (t $:$ as)
+>     appTySyn (SynAll _ _ t) (a :$ as) = appTySyn (instTySyn a t) as
+>     appTySyn (SynAll _ _ _) A0 = erk "underapplied type synonym"
+
+
+
+Classes
+
+
+> insertClassDecl :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                        ClassName -> ClassDeclaration -> m ()
+> insertClassDecl x d = do
+>     st <- get
+>     when (Map.member x (classes st)) $ erk $ "Duplicate class " ++ x
+>     put st{classes = Map.insert x d (classes st)}
+
+
+> lookupClassDecl ::  (MonadState ZipState m, MonadError ErrorData m) =>
+>                        ClassName -> m ClassDeclaration
+> lookupClassDecl x = do
+>     cs <- gets classes
+>     case Map.lookup x cs of
+>         Just d   -> return d
+>         Nothing  -> erk $ "Missing class " ++ x
+
+
+
+Instances
+
+> insertInstDecl :: (MonadState ZipState m, MonadError ErrorData m) =>
+>                        ClassName -> Type KConstraint -> m ()
+> insertInstDecl x t = modify addInst
+>   where
+>     addInst st = st{instances = Map.alter f x (instances st)}
+>     f mds = Just (t : maybe [] id mds)
+
+> lookupInstances :: (Functor m, MonadState ZipState m, MonadError ErrorData m) =>
+>                        ClassName -> m [Type KConstraint]
+> lookupInstances x = Map.findWithDefault [] x <$> gets instances
diff --git a/src/Language/Inch/Erase.lhs b/src/Language/Inch/Erase.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Erase.lhs
@@ -0,0 +1,241 @@
+> {-# LANGUAGE TypeOperators, MultiParamTypeClasses, TypeSynonymInstances,
+>              GADTs, TypeFamilies, UndecidableInstances, ImpredicativeTypes,
+>              TupleSections #-}
+
+> module Language.Inch.Erase where
+
+> import Control.Applicative hiding (Alternative)
+> import Data.Traversable
+> import Text.PrettyPrint.HughesPJ
+
+> import Language.Inch.Error
+> import Language.Inch.Kit
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.Syntax
+> import Language.Inch.ModuleSyntax
+> import Language.Inch.Context
+> import Language.Inch.PrettyPrinter
+
+
+> eraseKind :: Kind k -> Maybe (Ex Kind)
+> eraseKind KSet         = Just $ Ex KSet
+> eraseKind KNum         = Nothing
+> eraseKind KConstraint  = Just $ Ex KConstraint
+> eraseKind (k :-> l)    =
+>     case (eraseKind k, eraseKind l) of
+>         (_,             Nothing)       -> Nothing
+>         (Nothing,       Just (Ex l'))  -> Just $ Ex l'
+>         (Just (Ex k'),  Just (Ex l'))  -> Just $ Ex $ k' :-> l'
+
+
+> willErase :: Kind k -> Bool
+> willErase KSet         = False
+> willErase KNum         = True
+> willErase KConstraint  = False
+> willErase (_ :-> l)    = willErase l
+
+> eraseType :: Type k -> Contextual (Maybe TyKind)
+> eraseType (TyVar (FVar a k))  = return (eraseKind k >>= \ (Ex l) ->
+>                                                  Just (TK (TyVar (FVar a l)) l))
+> eraseType (TyVar (BVar b))    = impossibleBVar b
+> eraseType (TyCon c k)         = return (eraseKind k >>= \ (Ex l) ->
+>                                                  Just (TK (TyCon c l) l))
+> eraseType (TySyn x t) = do
+>     mt <- eraseTypeSyn t
+>     case mt of
+>         Nothing       -> return Nothing
+>         Just (Ex t')  -> return . Just $ TK (TySyn x t') (getTySynKind t')
+> eraseType (TyApp f s)  = do
+>         k :-> _ <- return $ getTyKind f
+>         mtk <- eraseType f
+>         if willErase k
+>             then return mtk
+>             else case mtk of
+>                 Just (TK f' (k'' :-> l'')) -> do
+>                     Just (TK s' ks) <- eraseType s
+>                     hetEq k'' ks (return (Just (TK (TyApp f' s') l'')))
+>                                  (erk "Kind mismatch")
+>                 _ -> return Nothing
+> eraseType Arr = return . Just $ TK Arr (KSet :-> KSet :-> KSet)
+> eraseType (Bind Pi x KNum t)   = do
+>     Just (TK t' KSet) <- eraseType $ unbindTy (FVar (N x (error "eraseType: erk") (UserVar Pi)) KNum) t
+>     return . Just $ TK (insertNumArrow t') KSet
+>   where
+>     insertNumArrow :: Ty a KSet -> Ty a KSet
+>     insertNumArrow (Bind All y k t') = Bind All y k (insertNumArrow t')
+>     insertNumArrow t' = tyInteger --> t'
+> eraseType (Bind All x k t)        = 
+>     case eraseKind k of
+>         Just (Ex k') -> do
+>             an <- fresh SysVar x k Hole
+>             Just (TK t' l) <- eraseType (unbindTy an t)
+>             return . Just $ TK (Bind All x k' (bindTy (FVar (varName an) k') t')) l
+>         Nothing -> eraseType $ unbindTy (FVar (N x (error "eraseType: erk") (UserVar All)) k) t
+> eraseType (Qual q t) = do
+>     q'   <- eraseTo KConstraint q
+>     mtk  <- eraseType t
+>     return $ (\ (TK t' k') -> TK (qual q' t') k') <$> mtk
+>   where
+>     qual :: Type KConstraint -> Type k -> Type k
+>     qual p u | isTrivial p  = u
+>              | otherwise    = Qual p u
+
+> eraseType (TyComp _) = return . Just $ TK tyTrivial KConstraint
+
+> eraseType _ = return Nothing
+
+
+
+> eraseTypeSyn :: TypeSyn l -> Contextual (Maybe (Ex (TySyn ())))
+> eraseTypeSyn (SynTy t) = do
+>     mtk <- eraseType t
+>     case mtk of
+>        Nothing         -> return Nothing
+>        Just (TK t' _)  -> return (Just (Ex (SynTy t')))
+> eraseTypeSyn (SynAll x k t) = case eraseKind k of
+>     Nothing -> eraseTypeSyn $ unbindTySyn (FVar (N x (error "eraseTypeSyn: erk") (UserVar All)) k) t
+>     Just (Ex k') -> do
+>         a <- fresh SysVar x k Hole
+>         Just (Ex t') <- eraseTypeSyn (unbindTySyn a t)
+>         return . Just . Ex $ SynAll x k' (bindTySyn (FVar (varName a) k') t')
+
+
+
+> eraseTo :: Kind l -> Type k -> Contextual (Type l)
+> eraseTo l t = inLocation (text "when erasing" <+> prettyHigh (fogTy t)
+>                               <+> text "to" <+> prettyHigh (fogKind l)) $ do
+>     Just (TK t' k') <- eraseType t
+>     hetEq k' l (return t')
+>                (errKindMismatch (fogTy t' ::: fogKind k') (fogKind l))
+
+
+> eraseTm :: Term () -> Contextual (Term ())
+> eraseTm (TmVar x)    = pure $ TmVar x
+> eraseTm (TmCon c)    = pure $ TmCon c
+> eraseTm (TmInt k)    = pure $ TmInt k
+> eraseTm (CharLit c)  = pure $ CharLit c
+> eraseTm (StrLit s)   = pure $ StrLit s
+> eraseTm (TmApp f s)  = TmApp <$> eraseTm f <*> eraseTm s
+> eraseTm (TmBrace n)  = pure $ numToTm n
+> eraseTm (Lam x b)    = Lam x <$> eraseTm b
+> eraseTm (NumLam n b)  = do
+>     a <- fresh (UserVar Pi) n KNum Hole
+>     Lam n <$> eraseTm (unbindTm a b)
+> eraseTm (Let ds t)   = Let <$> traverse eraseDecl ds <*> eraseTm t
+> eraseTm (Case t as)  = Case <$> eraseTm t <*> traverse eraseCaseAlt as
+> eraseTm (t :? ty)    = do
+>     t' <- eraseTm t
+>     ty' <- eraseTo KSet ty
+>     return $ t' :? ty'
+
+> numToTm :: Type KNum -> Term ()
+> numToTm (TyVar x)  = TmVar . fogVar $ x
+> numToTm (TyInt i)  = TmInt i
+> numToTm (TyApp (UnOp o) m) = tmUnOp o (numToTm m)
+> numToTm (TyApp (TyApp (BinOp o) m) n) = tmBinOp o (numToTm m) (numToTm n)
+> numToTm t = error $ "numToTm: illegal type " ++ show t
+
+
+> eraseCon :: Constructor -> Contextual Constructor
+> eraseCon (c ::: t) = (c :::) <$> eraseTo KSet t
+
+> eraseAlt :: Alternative () -> Contextual (Alternative ())
+> eraseAlt (Alt ps gt) = do
+>     (ps', f)  <- erasePatList ps
+>     gt'       <- eraseGuardTerms (renameTypes1 f gt)
+>     return $ Alt ps' gt'
+
+> eraseCaseAlt :: CaseAlternative () -> Contextual (CaseAlternative ())
+> eraseCaseAlt (CaseAlt p gt) = do
+>     (p', f)  <- erasePat p
+>     gt'      <- eraseGuardTerms (renameTypes1 f gt)
+>     return $ CaseAlt p' gt'
+
+> eraseGuardTerms :: GuardTerms () -> Contextual (GuardTerms ())
+> eraseGuardTerms (Unguarded e ds) = Unguarded <$> eraseTm e
+>                                    <*> traverse eraseDecl ds
+> eraseGuardTerms (Guarded gts ds) = Guarded <$> traverse er gts
+>                                    <*> traverse eraseDecl ds
+>   where er (g :*: t) = (eraseGuard g :*:) <$> eraseTm t
+
+> eraseGuard :: Guard () -> Guard ()
+> eraseGuard (NumGuard ps)  = ExpGuard (map toTm ps)
+>   where
+>     toTm (P c m n) = tmComp c (numToTm m) (numToTm n)
+>     toTm (_ :=> _) = error "eraseGuard.toTm: implications are not allowed!"
+> eraseGuard g              = g
+
+> erasePat :: Pattern a b -> Contextual (Pattern () (), forall k . Var b k -> Var a k)
+> erasePat (PatVar v)      = return (PatVar v, id)
+> erasePat (PatCon c ps)   = do
+>     (ps', f) <- erasePatList ps
+>     return (PatCon c ps', f)
+> erasePat PatIgnore       = return (PatIgnore, id)
+> erasePat (PatBrace a 0)  = do
+>     x <- fresh (UserVar Pi) a KNum Hole
+>     return (PatVar a, unbindVar (wkClosedVar x))
+> erasePat (PatBrace a k)  = do
+>     x <- fresh (UserVar Pi) a KNum Hole
+>     return (PatNPlusK a k, unbindVar (wkClosedVar x))
+
+> erasePat (PatBraceK k)   = return (PatIntLit k, id)
+> erasePat (PatIntLit i)   = return (PatIntLit i, id)
+> erasePat (PatCharLit c)  = return (PatCharLit c, id)
+> erasePat (PatStrLit s)   = return (PatStrLit s, id)
+> erasePat (PatNPlusK n k) = return (PatNPlusK n k, id)
+
+> erasePatList :: PatternList a b -> Contextual (PatternList () (), forall k . Var b k -> Var a k)
+> erasePatList P0         = return (P0, id)
+> erasePatList (p :! ps)  = do
+>     (p',   f) <- erasePat p
+>     (ps',  g) <- erasePatList ps
+>     return (p' :! ps', f . g)
+
+> eraseTopDecl :: TopDeclaration -> Contextual TopDeclaration
+> eraseTopDecl (DataDecl s k cs ds) =
+>     case eraseKind k of
+>         Just (Ex k') -> do
+>             cs' <- traverse eraseCon cs
+>             return $ DataDecl s k' cs' ds
+>         Nothing -> error $ "eraseTopDecl: failed to erase kind " ++ show k
+> eraseTopDecl (TypeDecl x t) = do
+>     mt <- eraseTypeSyn t
+>     case mt of
+>         Nothing       -> return $ TypeDecl x (SynTy tyUnit)
+>         Just (Ex t')  -> return $ TypeDecl x t'
+> eraseTopDecl (CDecl x d)  = CDecl x <$> eraseClassDecl d
+> eraseTopDecl (IDecl x d)  = IDecl x <$> eraseInstDecl d
+> eraseTopDecl (Decl d)     = Decl <$> eraseDecl d
+
+> eraseClassDecl :: ClassDeclaration -> Contextual ClassDeclaration
+> eraseClassDecl (ClassDecl vs ss ms) = do
+>     let vs' = filter (\ (VK _ k) -> not (willErase k)) vs
+>     ss' <- traverse (eraseTo KConstraint) ss
+>     ms' <- traverse (\ (mn ::: ty) -> (mn :::) <$> eraseTo KSet ty) ms
+>     return $ ClassDecl vs' ss' ms'
+
+> eraseInstDecl :: InstDeclaration -> Contextual InstDeclaration
+> eraseInstDecl (InstDecl ts cs zs) = do
+>     ts' <- eraseInstTypes ts
+>     cs' <- filter (not . isTrivial) <$> traverse (eraseTo KConstraint) cs
+>     zs' <- traverse (\ (n, as) -> (n,) <$> traverse eraseAlt as) zs
+>     return $ InstDecl ts' cs' zs'
+>   where
+>     eraseInstTypes :: [Ex (Ty ())] -> Contextual [Ex (Ty ())]
+>     eraseInstTypes [] = return []
+>     eraseInstTypes (Ex t:us) = do
+>         mtk <- eraseType t
+>         us' <- eraseInstTypes us
+>         case mtk of
+>             Nothing         -> return us'
+>             Just (TK t' _)  -> return (Ex t' : us')
+
+
+> eraseDecl :: Declaration () -> Contextual (Declaration ())
+> eraseDecl (FunDecl x ps) =
+>     FunDecl x <$> traverse eraseAlt ps
+> eraseDecl (SigDecl x ty) = SigDecl x <$> eraseTo KSet ty
+
+> eraseModule :: Module -> Contextual Module
+> eraseModule (Mod mh is ds) = Mod mh is <$> traverse eraseTopDecl ds
diff --git a/src/Language/Inch/Error.lhs b/src/Language/Inch/Error.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Error.lhs
@@ -0,0 +1,156 @@
+> {-# LANGUAGE TypeSynonymInstances, FlexibleContexts, GADTs, TypeOperators,
+>              NoMonomorphismRestriction, FlexibleInstances #-}
+
+> module Language.Inch.Error where
+
+> import Data.List
+> import qualified Control.Monad.Error as E
+> import Text.PrettyPrint.HughesPJ
+
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.Kit
+> import Language.Inch.PrettyPrinter
+
+> data Err where
+>     MissingTyVar       :: String -> Err
+>     MissingNumVar      :: String -> Err
+>     MissingTyCon       :: String -> Err
+>     MissingTmVar       :: String -> Err
+>     MissingTmCon       :: String -> Err
+>     KindTarget         :: SKind -> Err
+>     KindNot            :: SKind -> String -> Err
+>     KindMismatch       :: SType ::: SKind -> SKind -> Err
+>     ConstructorTarget  :: SType -> Err
+>     ConUnderapplied    :: TmConName -> Int -> Int -> Err
+>     DuplicateTyCon     :: TyConName -> Err
+>     DuplicateTmCon     :: TmConName -> Err
+>     DuplicateTmVar     :: TmName -> Err
+>     NonNumericVar      :: Ex (Var ()) -> Err
+>     CannotUnify        :: SType -> SType -> Err
+>     UnifyFixed         :: Ex (Var ()) -> Ex (Ty ()) -> Err
+>     UnifyNumFixed      :: Var () KNum -> Ty () KNum -> Err
+>     CannotDeduce       :: [Type KConstraint] -> [Type KConstraint] -> Err
+>     BadExistential     :: Ex (Var ()) -> Ex (Ty ()) -> Err
+>     Impossible         :: Type KConstraint -> Err
+>     BadBindingLevel    :: Var () KNum -> Err
+>     Fail               :: String -> Err
+
+> instance Pretty Err where
+>     pretty (MissingTyVar a)   _ = text $ "Missing type variable " ++ a
+>     pretty (MissingNumVar a)  _ = text $ "Missing numeric type variable " ++ a
+>     pretty (MissingTyCon a)   _ = text $ "Missing type constructor " ++ a
+>     pretty (MissingTmVar a)   _ = text $ "Missing term variable " ++ a
+>     pretty (MissingTmCon a)   _ = text $ "Missing data constructor " ++ a
+>     pretty (KindTarget k)     _ = text "Kind" <+> prettyHigh k <+> text "doesn't target *"
+>     pretty (KindNot k s)      _ = text "Kind" <+> prettyHigh k <+> text "is not" <+> text s
+>     pretty (KindMismatch (t ::: k) l)  _ = text "Kind" <+> prettyHigh k <+> text "of" <+> prettyHigh t <+> text "is not" <+> prettyHigh l
+>     pretty (ConstructorTarget t)       _ = text "Type" <+> prettyHigh t <+> text "doesn't target data type"
+>     pretty (ConUnderapplied c n m)     _ = text $ "Constructor " ++ c ++ " should have " ++ show n ++ " arguments, but has been given " ++ show m
+>     pretty (DuplicateTyCon t)          _ = text $ "Duplicate type constructor " ++ t
+>     pretty (DuplicateTmCon t)          _ = text $ "Duplicate data constructor " ++ t
+>     pretty (DuplicateTmVar t)          _ = text $ "Duplicate term variable " ++ t
+>     pretty (NonNumericVar (Ex a))      _ = text "Type variable" <+> prettySysVar a <+> text "is not numeric"
+>     pretty (CannotUnify t u)           _ = sep  [  text "Cannot unify"
+>                                                 ,  nest 2 (prettyHigh t)
+>                                                 ,  text "with"
+>                                                 ,  nest 2 (prettyHigh u)
+>                                                 ]
+>     pretty (UnifyFixed (Ex a) (Ex t))  _ = text "Cannot unify fixed variable" <+> prettySysVar a <+> text "with" <+> prettyHigh (fogSysTy t)
+>     pretty (UnifyNumFixed a n)         _ = text "Cannot modify fixed variable" <+> prettySysVar a <+> text "to unify" <+> prettyHigh (fogSysTy n) <+> text "with 0"
+>     pretty (CannotDeduce [] qs)        _ = sep  [  text "Could not deduce"
+>                                                 ,  nest 2 (fsepPretty $ map fogSysTy $ nub $ map simplifyPred qs)
+>                                                 ,  text "in empty context"
+>                                                 ]
+>     pretty (CannotDeduce hs qs)        _ = sep  [  text "Could not deduce"
+>                                                 ,  nest 2 (fsepPretty $ map fogSysTy $ nub $ map simplifyPred qs)
+>                                                 ,  text "from hypotheses"
+>                                                 ,  nest 2 (fsepPretty $ map fogSysTy $ nub $ map simplifyPred hs)
+>                                                 ]
+>     pretty (BadExistential (Ex a) (Ex t))  _ = sep  [  text "Illegal existential"
+>                                                        <+> prettySysVar a
+>                                                 ,  text "when generalising type"
+>                                                 ,  nest 2 (prettyHigh $ fogSysTy t)
+>                                                 ]
+>     pretty (Impossible p) _ = text "Impossible constraint" <+> prettyHigh (fogSysTy p)
+>     pretty (BadBindingLevel a) _ = text "Forall-bound variable"
+>                                        <+> prettyVar a
+>                                        <+> text "used where pi-bound variable required"
+>     pretty (Fail s)           _ = text s
+
+> throw :: (E.MonadError ErrorData m) => Err -> m a
+> throw e = E.throwError (e, [] :: [Doc])
+
+> missingTyVar, missingNumVar, missingTyCon, missingTmVar, missingTmCon
+>     :: E.MonadError ErrorData m => String -> m a
+> errKindTarget, errKindNotSet, errKindNotArrow
+>     :: E.MonadError ErrorData m => SKind -> m a
+> errKindMismatch
+>     :: E.MonadError ErrorData m => SType ::: SKind -> SKind -> m a
+> errConstructorTarget
+>     :: E.MonadError ErrorData m => SType -> m a
+> errConUnderapplied
+>     :: E.MonadError ErrorData m => TmConName -> Int -> Int -> m a
+> errDuplicateTyCon, errDuplicateTmCon, errDuplicateTmVar
+>      :: E.MonadError ErrorData m => String -> m a
+> errNonNumericVar
+>     :: E.MonadError ErrorData m => Var () k -> m a
+> errCannotUnify
+>     :: E.MonadError ErrorData m => SType -> SType -> m a
+> errUnifyFixed
+>     :: E.MonadError ErrorData m => Var () k -> Type l -> m a
+> errUnifyNumFixed
+>     :: E.MonadError ErrorData m => Var () KNum -> Type KNum -> m a
+> errCannotDeduce
+>     :: E.MonadError ErrorData m => [Type KConstraint] -> [Type KConstraint] -> m a
+> errBadExistential
+>     :: E.MonadError ErrorData m => Var () k -> Type l -> m a
+> errImpossible
+>     :: E.MonadError ErrorData m => Type KConstraint -> m a
+> errBadBindingLevel
+>     :: E.MonadError ErrorData m => Var () KNum -> m a
+
+> missingTyVar a            = throw (MissingTyVar a)
+> missingNumVar a           = throw (MissingNumVar a)
+> missingTyCon a            = throw (MissingTyCon a)
+> missingTmVar a            = throw (MissingTmVar a)
+> missingTmCon a            = throw (MissingTmCon a)
+> errKindTarget k           = throw (KindTarget k)
+> errKindNotSet k           = throw (KindNot k "*")
+> errKindNotArrow k         = throw (KindNot k "an arrow")
+> errKindMismatch tk l      = throw (KindMismatch tk l)
+> errConstructorTarget t    = throw (ConstructorTarget t)
+> errConUnderapplied c n m  = throw (ConUnderapplied c n m)
+> errDuplicateTyCon t       = throw (DuplicateTyCon t)
+> errDuplicateTmCon t       = throw (DuplicateTmCon t)
+> errDuplicateTmVar t       = throw (DuplicateTmVar t)
+> errNonNumericVar a        = throw (NonNumericVar (Ex a))
+> errCannotUnify t u        = throw (CannotUnify t u)
+> errUnifyFixed a t         = throw (UnifyFixed (Ex a) (Ex t))
+> errUnifyNumFixed a n      = throw (UnifyNumFixed a n)
+> errCannotDeduce hs qs     = throw (CannotDeduce hs qs)
+> errBadExistential a t     = throw (BadExistential (Ex a) (Ex t))
+> errImpossible p           = throw (Impossible p)
+> errBadBindingLevel a      = throw (BadBindingLevel a)                            
+
+
+> type ErrorData = (Err, [Doc])
+
+> instance E.Error ErrorData where
+>     noMsg     = (Fail "Unknown error", [])
+>     strMsg s  = (Fail s, [])
+
+> instance Pretty ErrorData where
+>     pretty (e, ss) _ = hang (prettyHigh e) 4 (vcat $ reverse ss)
+
+
+
+> inLocation :: (E.MonadError ErrorData m) => Doc -> m a -> m a
+> inLocation s m = m `E.catchError` (\ (e, ss) -> E.throwError (e, s:ss))
+
+> inLoc :: (E.MonadError ErrorData m) => m a -> m Doc -> m a
+> inLoc m ms = m `E.catchError` (\ (e, ss) -> ms >>= \ s -> E.throwError (e, s:ss))
+
+
+> erk :: (E.MonadError ErrorData m) => String -> m a
+> erk s = E.throwError (Fail s, [])
diff --git a/src/Language/Inch/File.lhs b/src/Language/Inch/File.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/File.lhs
@@ -0,0 +1,72 @@
+> {-# LANGUAGE ScopedTypeVariables #-}
+
+> module Language.Inch.File where
+
+> import Prelude hiding (catch)
+> import Control.Exception
+> import Control.Monad.State
+> import System.Exit
+> import System.FilePath
+> import System.IO
+
+> import Paths_inch (getDataFileName)
+
+> import Language.Inch.Context
+> import Language.Inch.Syntax
+> import Language.Inch.ModuleSyntax
+> import Language.Inch.Parser
+> import Language.Inch.PrettyPrinter
+> import Language.Inch.ProgramCheck
+> import Language.Inch.Erase
+
+> checkFile :: FilePath -> String -> IO (Module, ZipState)
+> checkFile original s = do
+>     md <- parseModuleIO
+>     ds <- readImports (fst (splitFileName original)) (modImports md)
+>     checkModuleIO md ds
+>   where
+>     parseModuleIO = case parseModule original s of
+>         Right md  -> return md
+>         Left err  -> putStrLn ("parse error:\n" ++ show err) >> exitFailure
+>
+>     checkModuleIO md ds = case runStateT (checkModule md ds) initialState of
+>         Right x   -> return x
+>         Left err  -> putStrLn ("type-checking failed:\n" ++ renderMe err) >> exitFailure
+
+
+> eraseWrite :: FilePath -> Module -> ZipState -> IO ()
+> eraseWrite output md st = case evalStateT (eraseModule md) st of
+>     Right md'  -> writeFile output (renderMe (fog md'))
+>     Left err   -> putStrLn ("erase error:\n" ++ renderMe err) >> exitFailure
+
+> getInterface :: Module -> String
+> getInterface = renderMe . map fog . filter interfaceDecl . modDecls
+>   where
+>     interfaceDecl (DataDecl _ _ _ _)    = True
+>     interfaceDecl (TypeDecl _ _)        = True
+>     interfaceDecl (CDecl _ _)           = True
+>     interfaceDecl (IDecl _ _)           = True
+>     interfaceDecl (Decl (SigDecl _ _))  = True
+>     interfaceDecl (Decl (FunDecl _ _))  = False
+
+
+> readImport :: FilePath -> Import -> IO [STopDeclaration]
+> readImport dir im = do
+>     s <- catch (readFile (combine dir inchFile)) $ \ (_ :: IOException) ->
+>              catch (readFile =<< getDataFileName inchFile) $ \ (_ :: IOException) ->
+>                  hPutStrLn stderr ("Could not load " ++ inchFile) >> return ""
+>     case parseInterface inchFile s of
+>         Right ds  -> return $ filter (included . topDeclName) ds
+>         Left err  -> putStrLn ("interface parse error:\n" ++ show err) >> exitFailure
+>   where
+>     inchFile = importName im ++ ".inch"
+>     included x = case impSpec im of
+>         ImpAll        -> True
+>         Imp ys        -> x `elem` ys
+>         ImpHiding ys  -> x `notElem` ys
+
+> readImports :: FilePath -> [Import] -> IO [STopDeclaration]
+> readImports dir is = fmap join (mapM (readImport dir) is')
+>   where
+>     is' = if any (("Prelude" ==) . importName) is then is
+>             else Import False "Prelude" Nothing ImpAll : is
diff --git a/src/Language/Inch/Kind.lhs b/src/Language/Inch/Kind.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Kind.lhs
@@ -0,0 +1,348 @@
+> {-# LANGUAGE GADTs, TypeOperators, TypeFamilies, RankNTypes,
+>              FlexibleInstances, StandaloneDeriving, MultiParamTypeClasses,
+>              FlexibleContexts, EmptyDataDecls #-}
+
+> module Language.Inch.Kind where
+
+> import Data.Foldable
+> import Data.Map (Map)
+> import qualified Data.Map as Map
+> import Data.Monoid
+> import Prelude hiding (any, elem)
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Kit
+
+
+
+> type TmName           = String
+> type TyConName        = String
+> type TmConName        = String
+> type ClassName        = String
+
+
+> data Binder where
+>     Pi   :: Binder
+>     All  :: Binder
+>   deriving (Eq, Ord, Show)
+
+> data VarState where
+>     UserVar  :: Binder -> VarState
+>     SysVar   :: VarState
+>   deriving (Eq, Ord, Show)
+
+> data TyName where
+>     N :: String -> Int -> VarState -> TyName
+>   deriving (Eq, Ord, Show)
+
+> nameToString :: TyName -> String
+> nameToString (N s _ _) = s
+
+> nameToSysString :: TyName -> String
+> nameToSysString (N s i _) = s ++ "_" ++ show i
+
+> nameEq :: TyName -> String -> Bool
+> nameEq (N x _ (UserVar _)) y  = x == y
+> nameEq (N _ _ SysVar)  _  = False
+
+> nameBinder :: TyName -> Maybe Binder
+> nameBinder (N _ _ (UserVar b))  = Just b
+> nameBinder _                    = Nothing
+
+> data KSet
+> data KNum
+> data KConstraint
+> data k :-> l
+
+> data Kind k where
+>     KSet   :: Kind KSet
+>     KNum   :: Kind KNum
+>     KConstraint :: Kind KConstraint
+>     (:->)  :: Kind k -> Kind l -> Kind (k :-> l)
+> infixr 5 :->
+
+> deriving instance Show (Kind k)
+
+> instance HetEq Kind where
+>     hetEq KSet KSet yes _ = yes
+>     hetEq KNum KNum yes _ = yes
+>     hetEq KConstraint KConstraint yes _ = yes
+>     hetEq (k :-> k') (l :-> l') yes no = hetEq k l (hetEq k' l' yes no) no
+>     hetEq _ _ _ no = no
+
+> instance HetOrd Kind where
+>     KSet         <?=  _           = True
+>     _            <?=  KSet        = False
+>     KNum         <?=  _           = True
+>     _            <?=  KNum        = False
+>     KConstraint  <?= _            = True
+>     _            <?= KConstraint  = False
+>     (k :-> k')   <?= (l :-> l')   | k =?= k' =  l <?= l'
+>                                   | otherwise = k <?= k'
+
+> class KindI t where
+>     kind :: Kind t
+
+> instance KindI KSet where
+>     kind = KSet
+
+> instance KindI KNum where
+>     kind = KNum
+
+> instance (KindI k, KindI l) => KindI (k :-> l) where
+>     kind = kind :-> kind
+
+> data SKind where
+>     SKSet   :: SKind
+>     SKNum   :: SKind
+>     SKNat   :: SKind
+>     SKConstraint :: SKind
+>     (:-->)  :: SKind -> SKind -> SKind
+>   deriving (Eq, Show)
+> infixr 5 :-->
+
+
+> targetsSet :: Kind k -> Bool
+> targetsSet KSet       = True
+> targetsSet KNum       = False
+> targetsSet KConstraint = False
+> targetsSet (_ :-> k)  = targetsSet k 
+
+> fogKind :: Kind k -> SKind
+> fogKind KSet       = SKSet
+> fogKind KNum       = SKNum
+> fogKind KConstraint = SKConstraint
+> fogKind (k :-> l)  = fogKind k :--> fogKind l
+
+> kindKind :: SKind -> Ex Kind
+> kindKind SKSet       = Ex KSet
+> kindKind SKNum       = Ex KNum
+> kindKind SKNat       = Ex KNum
+> kindKind SKConstraint = Ex KConstraint
+> kindKind (k :--> l)  = case (kindKind k, kindKind l) of
+>                            (Ex k', Ex l') -> Ex (k' :-> l')
+
+> kindCod :: Kind (k :-> l) -> Kind l
+> kindCod (_ :-> l) = l
+
+
+
+
+
+
+
+> data BVar a k where
+>     Top  :: BVar (a, k) k
+>     Pop  :: BVar a k -> BVar (a, l) k
+
+> instance Show (BVar a k) where
+>     show x = '!' : show (bvarToInt x)
+
+> instance HetEq (BVar a) where
+>     hetEq Top      Top      yes _  = yes
+>     hetEq (Pop x)  (Pop y)  yes no = hetEq x y yes no
+>     hetEq _        _        _   no = no
+
+> instance Eq (BVar a k) where
+>     (==) = (=?=)
+
+> instance HetOrd (BVar a) where
+>     Top    <?= _      = True
+>     Pop x  <?= Pop y  = x <?= y
+>     Pop _  <?= Top    = False
+
+> instance Ord (BVar a k) where
+>     (<=) = (<?=)
+
+
+
+> bvarToInt :: BVar a k -> Int
+> bvarToInt Top      = 0
+> bvarToInt (Pop x)  = succ (bvarToInt x)
+
+
+
+> data Var a k where
+>     BVar :: BVar a k          -> Var a k
+>     FVar :: TyName -> Kind k  -> Var a k
+>  deriving Show
+
+> instance HetEq (Var a) where
+>     hetEq (FVar a k)  (FVar b l)  yes _ | a == b =
+>         hetEq k l yes (error "eqVar: kinding error")
+>     hetEq (BVar x)    (BVar y)    yes no = hetEq x y yes no
+>     hetEq _           _           _   no = no
+
+> instance Eq (Var a k) where
+>     (==) = (=?=)
+
+> instance HetOrd (Var a) where
+>     BVar x    <?= BVar y    = x <?= y
+>     BVar _    <?= FVar _ _  = True
+>     FVar a _  <?= FVar b _  = a <= b
+>     FVar _ _  <?= BVar _    = False
+
+> instance Ord (Var a k) where
+>     (<=) = (<?=)
+
+
+> impossibleBVar :: BVar () k -> a
+> impossibleBVar b = error $ "impossible BVar: " ++ show b
+
+> varName :: Var () k -> TyName
+> varName (FVar a _)  = a
+> varName (BVar b)    = impossibleBVar b
+
+> varKind :: Var () k -> Kind k
+> varKind (FVar _ k)  = k
+> varKind (BVar b)    = impossibleBVar b
+
+> varBinder :: Var () k -> Maybe Binder
+> varBinder (FVar a _)  = nameBinder a
+> varBinder (BVar b)    = impossibleBVar b
+
+> fogVar :: Var () k -> String
+> fogVar = fogVar' nameToString []
+
+> fogSysVar :: Var () k -> String
+> fogSysVar = fogVar' nameToSysString []
+
+> fogVar' :: (TyName -> String) -> [String] -> Var a k -> String
+> fogVar' g _  (FVar a _)  = g a
+> fogVar' _ bs (BVar x)    = bs !! bvarToInt x
+
+> varNameEq :: Var a k -> String -> Bool
+> varNameEq (FVar nom _)  y = nameEq nom y
+> varNameEq (BVar _)      _ = False
+
+> wkF :: (forall k . Var a k -> t) -> t -> Var (a, l) k' -> t
+> wkF f _ (FVar a k)      = f (FVar a k)
+> wkF _ t (BVar Top)      = t
+> wkF f _ (BVar (Pop y))  = f (BVar y)
+
+
+> withBVar :: (BVar a k -> BVar b k) -> Var a k -> Var b k
+> withBVar _ (FVar a k)  = FVar a k
+> withBVar f (BVar x)    = BVar (f x)
+
+> wkVar :: Var a k -> Var (a, l) k
+> wkVar = withBVar Pop
+
+> wkRenaming :: (Var a k -> Var b k) -> Var (a, l) k -> Var (b, l) k
+> wkRenaming g (FVar a k)      = wkVar . g $ FVar a k
+> wkRenaming _ (BVar Top)      = BVar Top
+> wkRenaming g (BVar (Pop x))  = wkVar . g $ BVar x
+
+> bindVar :: Var a k -> Var a l -> Var (a, k) l
+> bindVar v w = hetEq v w (BVar Top) (wkVar w)
+
+> unbindVar :: Var a k -> Var (a, k) l -> Var a l 
+> unbindVar v (BVar Top)      = v
+> unbindVar _ (BVar (Pop x))  = BVar x
+> unbindVar _ (FVar a k)      = FVar a k
+
+> wkClosedVar :: Var () k -> Var a k
+> wkClosedVar (FVar a k)  = FVar a k
+> wkClosedVar (BVar b)    = impossibleBVar b
+
+> fixKind :: Kind k -> Var () l -> Maybe (Var () k)
+> fixKind k v = hetEq k (varKind v) (Just v) Nothing
+
+> fixNum :: Var () l -> Maybe (Var () KNum)
+> fixNum = fixKind KNum  
+
+
+> class FV t a where
+>     fvFoldMap :: Monoid m => (forall k . Var a k -> m) -> t -> m
+
+> (<<?) :: FV t a => [Ex (Var a)] -> t -> Bool
+> as <<? t = getAny $ fvFoldMap (Any . (`hetElem` as)) t
+
+> (<?) :: FV t a => Var a k -> t -> Bool
+> a <? t = [Ex a] <<? t
+
+> vars :: FV t a => t -> [Ex (Var a)]
+> vars = fvFoldMap (\ x -> [Ex x])
+
+> numvars :: FV t () => t -> [Var () KNum]
+> numvars = fvFoldMap f
+>   where
+>     f :: Var () k -> [Var () KNum]
+>     f a@(FVar _ KNum)  = [a]
+>     f _                = []
+
+
+> instance FV (Var a l) a where
+>     fvFoldMap f a = f a
+
+> instance FV t a => FV [t] a where
+>     fvFoldMap f = foldMap (fvFoldMap f)
+
+> instance FV t a => FV (Fwd t) a where
+>     fvFoldMap f = foldMap (fvFoldMap f)
+
+> instance FV t a => FV (Bwd t) a where
+>     fvFoldMap f = foldMap (fvFoldMap f)
+
+> instance (FV t a, FV u a) => FV (Either t u) a where
+>     fvFoldMap f (Left x)   = fvFoldMap f x
+>     fvFoldMap f (Right x)  = fvFoldMap f x
+
+> instance (FV t a, FV u a) => FV (t, u) a where
+>     fvFoldMap f (x, y) = fvFoldMap f x <.> fvFoldMap f y
+
+> instance (FV s a, FV t a, FV u a) => FV (s, t, u) a where
+>     fvFoldMap f (x, y, z) = fvFoldMap f x <.> fvFoldMap f y <.> fvFoldMap f z
+
+> instance (Ord t, FV t a) => FV (Map t x) a where
+>     fvFoldMap f = Map.foldrWithKey (\ t _ m -> fvFoldMap f t <.> m) mempty
+
+> instance FV (Ex (Var a)) a where
+>     fvFoldMap f (Ex v) = f v 
+
+> data VarSuffix a b x where
+>     VS0    :: VarSuffix a a ()
+>     (:<<)  :: VarSuffix a b x -> Var a k -> VarSuffix a (b, k) (x, k)
+
+> renameBVarVS :: VarSuffix a b x -> BVar a k -> BVar b k
+> renameBVarVS VS0         x = x
+> renameBVarVS (vs :<< _)  x = Pop (renameBVarVS vs x)
+
+> renameVS :: VarSuffix a b x -> Var a k -> Var b k
+> renameVS _   (FVar a k)  = FVar a k
+> renameVS vs  (BVar x)    = BVar (renameBVarVS vs x)
+
+> renameVSinv :: VarSuffix a b x -> Var b k -> Var a k
+> renameVSinv _          (FVar a k)      = FVar a k
+> renameVSinv VS0        (BVar v)        = BVar v
+> renameVSinv (_ :<< v)  (BVar Top)      = v
+> renameVSinv (vs :<< _) (BVar (Pop x))  = renameVSinv vs (BVar x)
+
+> extRenaming :: VarSuffix a b x -> VarSuffix c d x -> (Var a k -> Var c k) ->
+>                    Var b k -> Var d k
+> extRenaming _            ecd          g (FVar a k)      = renameVS ecd $ g (FVar a k)
+> extRenaming VS0          VS0          g (BVar v)        = g (BVar v)
+> extRenaming (_ :<<_)     (_ :<< _)    _ (BVar Top)      = BVar Top
+> extRenaming (eab :<< _)  (ecd :<< _)  g (BVar (Pop v))  = wkVar $ extRenaming eab ecd g (BVar v)
+> extRenaming _ _ _ _ = error "extRenaming: invariant violation"
+
+< extExt :: Ext a b x -> (forall d y . Ext c d y -> p) -> p
+< extExt E0       q = q E0
+< extExt (EC ex)  q = extExt ex (q . EC)
+
+> extComp :: VarSuffix a b x -> VarSuffix b c y -> (forall z . VarSuffix a c z -> p) -> p
+> extComp eab VS0          q = q eab
+> extComp eab (ebc :<< v)  q = extComp eab ebc (q . (:<< renameVSinv eab v))
+
+
+
+> data VarSuffixFwd a b where
+>     VF0    :: VarSuffixFwd a a
+>     (:>>)  :: Var a k -> VarSuffixFwd (a, k) b -> VarSuffixFwd a b
+
+> {-
+> renameVSFinv :: VarSuffixFwd a b -> Var b k -> Var a k
+> renameVSFinv _ (FVar a k) = FVar a k
+> renameVSFinv VF0 (BVar v) = BVar v
+> renameVSFinv (v :>> _) (BVar Top) = v
+> -}
diff --git a/src/Language/Inch/KindCheck.lhs b/src/Language/Inch/KindCheck.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/KindCheck.lhs
@@ -0,0 +1,57 @@
+> {-# LANGUAGE TypeOperators, GADTs #-}
+
+> module Language.Inch.KindCheck where
+
+> import Control.Applicative
+> import Data.Traversable
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.Context
+> import Language.Inch.Kit
+> import Language.Inch.Error
+
+> inferKind :: Binder -> Bwd (Ex (Var ())) -> SType -> Contextual TyKind
+> inferKind b g (STyVar x)   = (\ (Ex v) -> TK (TyVar v) (varKind v)) <$> lookupTyVar b g x
+> inferKind _ _ (STyCon c)   = (\ (Ex k) -> TK (TyCon c k) k) <$> lookupTyCon c
+>                            <|> (\ (Ex t) -> case getTySynKind t of
+>                                          k -> TK (TySyn c t) k) <$> lookupTySyn c
+> inferKind b g (STyApp f s)  = do
+>     TK f' k  <- inferKind b g f
+>     case k of
+>         k1 :-> k2 -> do
+>             TK s' l  <- inferKind b g s
+>             hetEq k1 l
+>                 (return $ TK (TyApp f' s') k2)
+>                 (errKindMismatch (s ::: fogKind l) (fogKind k1))
+>             
+>         _ -> errKindNotArrow (fogKind k)
+> inferKind _ _ SArr         = return $ TK Arr (KSet :-> KSet :-> KSet)
+> inferKind _ _ (STyInt i)   = return $ TK (TyInt i) KNum
+> inferKind _ _ (SUnOp o)    = return $ TK (UnOp o) (KNum :-> KNum)
+> inferKind _ _ (SBinOp o)   = return $ TK (BinOp o) (KNum :-> KNum :-> KNum)
+> inferKind _ _ (STyComp c)  = return $ TK (TyComp c) (KNum :-> KNum :-> KConstraint)
+> inferKind b g (SBind c a SKNat t)  = do
+>     v <- freshVar (UserVar All) a KNum
+>     ty <- checkKind KSet b (g :< Ex v) t
+>     return $ TK (Bind c a KNum (bindTy v (Qual (tyPred LE 0 (TyVar v)) ty))) KSet
+> inferKind b g (SBind c a k t)  = case kindKind k of
+>     Ex k' -> do
+>         v <- freshVar (UserVar All) a k'
+>         ty <- checkKind KSet b (g :< Ex v) t
+>         return $ TK (Bind c a k' (bindTy v ty)) KSet
+> inferKind b g (SQual p t) = do
+>     p' <- checkKind KConstraint b g p
+>     TK t' KSet <- inferKind b g t
+>     return $ TK (Qual p' t') KSet
+
+
+> checkKind :: Kind k -> Binder -> Bwd (Ex (Var ())) -> SType -> Contextual (Type k)
+> checkKind k b g t = do
+>   TK t' k' <- inferKind b g t
+>   hetEq k k' (return t')
+>              (errKindMismatch (fogTy t' ::: fogKind k') (fogKind k))
+
+> checkPredKind :: Binder -> Bwd (Ex (Var ())) -> SPredicate -> Contextual Predicate
+> checkPredKind b g = traverse (checkKind KNum b g)
diff --git a/src/Language/Inch/Kit.lhs b/src/Language/Inch/Kit.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Kit.lhs
@@ -0,0 +1,114 @@
+> {-# LANGUAGE TypeOperators, GADTs, DeriveFunctor, DeriveFoldable, DeriveTraversable,
+>              RankNTypes, TypeFamilies #-}
+
+> module Language.Inch.Kit where
+
+> import Control.Applicative
+> import Data.Foldable hiding (foldr)
+> import Data.List
+> import Data.Monoid
+> import Data.Traversable
+> import Debug.Trace
+
+
+> (<.>) :: Monoid a => a -> a -> a
+> (<.>) = mappend
+
+
+> data Ex f where
+>     Ex :: f a -> Ex f
+
+> unEx :: Ex t -> (forall a . t a -> b) -> b
+> unEx (Ex t) f = f t
+
+> unEx2 :: (forall a . t a -> b) -> Ex t -> b
+> unEx2 f (Ex t) = f t
+
+> mapEx :: (forall a . f a -> g a) -> Ex f -> Ex g
+> mapEx f (Ex t) = Ex (f t)
+
+> travEx :: Functor t => (forall a . f a -> t (g a)) -> Ex f -> t (Ex g)
+> travEx f (Ex t) = Ex <$> f t
+
+
+> class HetEq t where
+>     hetEq :: t a -> t b -> (a ~ b => x) -> x -> x
+>     (=?=) :: t a -> t b -> Bool
+>     s =?= t = hetEq s t True False
+
+> instance HetEq t => Eq (Ex t) where
+>     Ex s == Ex t = s =?= t
+
+> hetElem :: HetEq t => t a -> [Ex t] -> Bool
+> hetElem _ []      = False
+> hetElem x (Ex y:ys)  = x =?= y || hetElem x ys
+
+> class HetOrd t where
+>     (<?=) :: t a -> t b -> Bool     
+
+> data S a where
+>     S :: a -> S a
+>     Z :: S a
+>   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+> bind :: (Functor f, Eq a) => a -> f a -> f (S a)
+> bind x = fmap inS
+>   where  inS y | x == y     = Z
+>                | otherwise  = S y
+
+> unbind :: Functor f => a -> f (S a) -> f a
+> unbind x = fmap unS
+>   where  unS Z      = x
+>          unS (S a)  = a
+
+> subst :: (Monad m, Eq a) => a -> m a -> m a -> m a
+> subst a t = (>>= f)
+>   where f b | a == b     = t
+>             | otherwise  = return b
+
+> wk :: Applicative f => (a -> f b) -> (S a -> f (S b))
+> wk _ Z      = pure Z
+> wk g (S a)  = fmap S (g a)
+
+
+Really we want g to be a pointed functor!
+
+> wkwk :: (Applicative f, Functor g) =>
+>     (S b -> g (S b)) -> (a -> f (g b)) -> (S a -> f (g (S b)))
+> wkwk p _ Z      = pure $ p Z
+> wkwk _ g (S a)  = fmap S <$> g a
+
+
+> data a :=   b  = a :=   b
+>     deriving (Eq, Show, Functor, Foldable, Traversable)
+> data a :::  b  = a :::  b
+>     deriving (Eq, Show, Functor, Foldable, Traversable)
+> infix 3 :=
+> infix 4 :::
+
+> tmOf :: a ::: b -> a
+> tmOf (a ::: _) = a
+
+> tyOf :: a ::: b -> b
+> tyOf (_ ::: b) = b
+
+> unzipAsc :: [(a ::: b)] -> ([a] ::: [b])
+> unzipAsc xs = map tmOf xs ::: map tyOf xs
+
+
+
+> mtrace :: Monad m => String -> m ()
+> mtrace s = trace s (return ()) >>= \ () -> return ()
+
+
+
+> newtype Id a = Id {unId :: a}
+>     deriving (Functor, Foldable, Traversable)
+
+> instance Applicative Id where
+>     pure = Id
+>     Id f <*> Id s = Id (f s)
+
+
+> unions :: Eq a => [[a]] -> [a]
+> unions = foldr union []
diff --git a/src/Language/Inch/Main.lhs b/src/Language/Inch/Main.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Main.lhs
@@ -0,0 +1,32 @@
+> {-# LANGUAGE ScopedTypeVariables #-}
+
+> module Main where
+
+> import Prelude hiding (catch)
+> import System.Environment
+> import System.FilePath
+
+> import Language.Inch.Syntax
+> import Language.Inch.PrettyPrinter
+> import Language.Inch.File
+
+
+> help :: String -> String
+> help me = "Usage: " ++ me ++ " [original file] [input file] [output file]\n\
+>           \    or " ++ me ++ " [input file]"
+
+> main :: IO ()
+> main = do
+>     args <- getArgs
+>     me <- getProgName
+>     case args of
+>         [original, input, output] -> do
+>             s <- readFile input
+>             (md, st) <- checkFile original s
+>             writeFile (replaceExtension original ".inch") (getInterface md)
+>             eraseWrite output md st
+>         [original] -> do
+>             s <- readFile original
+>             (md, _) <- checkFile original s
+>             putStrLn $ renderMe (fog md)
+>         _ -> putStrLn $ help me
diff --git a/src/Language/Inch/ModuleSyntax.lhs b/src/Language/Inch/ModuleSyntax.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/ModuleSyntax.lhs
@@ -0,0 +1,165 @@
+> {-# LANGUAGE StandaloneDeriving, TypeOperators, GADTs,
+>              FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}
+
+> module Language.Inch.ModuleSyntax where
+
+> import Language.Inch.Kit
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.Syntax
+
+> type Module            = Mod OK
+> type ClassDeclaration  = ClassDecl OK
+> type InstDeclaration   = InstDecl OK
+> type TopDeclaration    = TopDecl OK
+
+> type SModule            = Mod RAW
+> type SClassDeclaration  = ClassDecl RAW
+> type SInstDeclaration   = InstDecl RAW
+> type STopDeclaration    = TopDecl RAW
+
+
+> type family ExTy s
+> type instance ExTy OK = Ex (Ty ())
+> type instance ExTy RAW = SType
+
+
+
+> data Mod s = Mod { modName :: Maybe (String, [String])
+>                  , modImports :: [Import]
+>                  , modDecls :: [TopDecl s]
+>                  }
+
+> deriving instance Show (Mod RAW)
+> deriving instance Eq (Mod RAW)
+
+> instance TravTypes Mod where
+
+<     travTypes    g (Mod mh is ds) = Mod mh is <$> traverse (travTypes g) ds
+
+>     fogTypes     g (Mod mh is ds) = Mod mh is (map (fogTypes g) ds)
+>     renameTypes  g (Mod mh is ds) = Mod mh is (map (renameTypes g) ds)
+
+> data Import = Import  {  qualified   :: Bool
+>                       ,  importName  :: String
+>                       ,  asName      :: Maybe String
+>                       ,  impSpec     :: ImpSpec
+>                       }
+>   deriving (Eq, Show)
+
+> data ImpSpec = ImpAll | Imp [String] | ImpHiding [String]
+>   deriving (Eq, Show)
+
+
+
+> type ClassMeths s   = [TmName ::: AType s KSet]
+> type ClassMethods   = ClassMeths OK
+> type SClassMethods  = ClassMeths RAW
+
+> data ClassDecl s = ClassDecl {  classVars     :: [VarKind s ()]
+>                              ,  superclasses  :: [AType s KConstraint]
+>                              ,  classMethods  :: ClassMeths s
+>                              }
+
+> deriving instance Eq (ClassDecl RAW)
+> deriving instance Show (ClassDecl RAW)                            
+> deriving instance Show (ClassDecl OK)
+
+> instance TravTypes ClassDecl where
+
+<     travTypes g (ClassDecl vs ss ms) =
+<         ClassDecl vs <$> traverse g ss <*> traverse (\ (y ::: t) -> (y :::) <$> g t) ms 
+
+>     fogTypes g (ClassDecl vs ss ms) =
+>         ClassDecl (map (fogTypes1 g) vs)
+>                   (map (fogTy' g []) ss)
+>                   (map (\ (y ::: t) -> (y ::: fogTy' g [] t)) ms)
+>     renameTypes g (ClassDecl vks ss ms) = 
+>         ClassDecl (map (renameTypes1 g) vks)
+>                   (map (renameTy g) ss)
+>                   (map (\ (y ::: t) -> y ::: renameTy g t) ms)
+
+
+> classKind :: SClassDeclaration -> Ex Kind
+> classKind (ClassDecl vs _ _) = varListKind vs
+>   where
+>     varListKind :: [VarKind RAW ()] -> Ex Kind
+>     varListKind [] = Ex KConstraint
+>     varListKind (VK _ k : ks) = case (kindKind k, varListKind ks) of
+>                                    (Ex k', Ex l) -> Ex (k' :-> l)
+
+> lookupMethodType :: TmName -> ClassMethods -> Maybe (Type KSet)
+> lookupMethodType x xs = lookup x (map (\ (a ::: b) -> (a, b)) xs)
+
+
+> data InstDecl s = InstDecl {  instTypes        :: [ExTy s]
+>                            ,  instConstraints  :: [AType s KConstraint]
+>                            ,  instMethods      :: [(TmName, [Alt s ()])]
+>                            }
+>                            
+
+> deriving instance Eq (InstDecl RAW)
+> deriving instance Show (InstDecl RAW)
+> deriving instance Show (InstDecl OK)
+
+> instance TravTypes InstDecl where
+
+<     travTypes g (InstDecl ts cs zs) = InstDecl
+<         <$> traverse (travEx g) ts
+<         <*> traverse g cs
+<         <*> traverse (\ (n, as) -> (,) n <$> traverse (travTypes1 g) as) zs
+
+>     fogTypes g (InstDecl ts cs zs) = InstDecl
+>         (map (unEx2 (fogTy' g [])) ts)
+>         (map (fogTy' g []) cs)
+>         (map (\ (n, as) -> (n, map (fogTypes1 g) as)) zs)
+>     renameTypes g (InstDecl ts cs zs) = InstDecl
+>         (map (mapEx (renameTy g)) ts)
+>         (map (renameTy g) cs)
+>         (map (\ (n, as) -> (n, map (renameTypes1 g) as)) zs)
+
+
+> data TopDecl s where
+>     DataDecl  :: TyConName -> AKind s k -> [TmConName ::: AType s KSet] ->
+>                      [String] -> TopDecl s
+>     TypeDecl  :: TyConName -> ATypeSyn s k -> TopDecl s
+>     CDecl     :: ClassName -> ClassDecl s -> TopDecl s
+>     IDecl     :: ClassName -> InstDecl s -> TopDecl s 
+>     Decl      :: Decl s () -> TopDecl s
+
+> deriving instance Show (TopDecl RAW)
+> deriving instance Show (TopDecl OK)
+> deriving instance Eq (TopDecl RAW)
+
+> instance TravTypes TopDecl where
+
+<     travTypes g (DataDecl x k cs ds) =
+<         DataDecl x k <$> traverse (\ (y ::: t) -> (y :::) <$> g t) cs <*> pure ds
+<     travTypes g (TypeDecl x t) = error "travTypes _ TypeDecl"
+<     travTypes g (CDecl x d) = CDecl x <$> travTypes g d
+<     travTypes g (IDecl x d) = IDecl x <$> travTypes g d
+<     travTypes g (Decl d) = Decl <$> travTypes1 g d
+
+>     fogTypes g (DataDecl x k cs ds) = DataDecl x (fogKind k)
+>         (map (\ (y ::: t) -> y ::: fogTy' g [] t) cs)
+>         ds
+>     fogTypes g (TypeDecl x t) = TypeDecl x (fogTySyn g t)
+>     fogTypes g (CDecl x d) = CDecl x (fogTypes g d)
+>     fogTypes g (IDecl x d) = IDecl x (fogTypes g d)
+>     fogTypes g (Decl d)  = Decl (fogTypes1 g d)
+
+>     renameTypes g (DataDecl x k cs ds) = DataDecl x k
+>         (map (\ (y ::: t) -> y ::: renameTy g t) cs)
+>         ds
+>     renameTypes g (TypeDecl x t) = TypeDecl x (renameTySyn g t)
+>     renameTypes g (CDecl x d) = CDecl x (renameTypes g d)
+>     renameTypes g (IDecl x d) = IDecl x (renameTypes g d)
+>     renameTypes g (Decl d)  = Decl (renameTypes1 g d)
+
+
+> topDeclName :: TopDecl s -> String
+> topDeclName (DataDecl x _ _ _)  = x
+> topDeclName (TypeDecl x _)      = x
+> topDeclName (CDecl x _)         = x
+> topDeclName (IDecl x _)         = x
+> topDeclName (Decl d)            = declName d
diff --git a/src/Language/Inch/Parser.lhs b/src/Language/Inch/Parser.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Parser.lhs
@@ -0,0 +1,527 @@
+> {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+> module Language.Inch.Parser (parseModule, parseInterface) where
+
+> import Control.Applicative
+> import Control.Monad
+> import Data.Char
+> import Data.Maybe
+> import Data.List
+
+> import Text.ParserCombinators.Parsec hiding (parse, optional, many, (<|>))
+> import Text.ParserCombinators.Parsec.Expr
+> import Text.ParserCombinators.Parsec.Language
+> import qualified Text.ParserCombinators.Parsec.Token as T
+> import qualified Text.ParserCombinators.Parsec.IndentParser as I
+> import qualified Text.ParserCombinators.Parsec.IndentParser.Token as IT
+
+
+> import Language.Inch.Type
+> import Language.Inch.Syntax
+> import Language.Inch.ModuleSyntax
+> import Language.Inch.Kit
+> import Language.Inch.Kind hiding (kind)
+
+> parseModule = I.parse module_
+
+> parseInterface = I.parse interface
+
+> def = haskellDef { identStart = identStart haskellDef <|> char '_'
+>                  , reservedNames = "_" : reservedNames haskellDef }
+
+> lexer       = T.makeTokenParser def    
+      
+> identifier     = IT.identifier lexer
+> reserved       = IT.reserved lexer
+> operator       = IT.operator lexer
+> reservedOp     = IT.reservedOp lexer
+> charLiteral    = IT.charLiteral lexer
+> stringLiteral  = IT.stringLiteral lexer
+> natural        = IT.natural lexer
+> integer        = IT.integer lexer
+> symbol         = IT.symbol lexer
+> whiteSpace     = IT.whiteSpace lexer
+> parens         = IT.parens lexer
+> braces         = IT.braces lexer
+> brackets       = IT.brackets lexer
+> dot            = IT.dot lexer
+> commaSep       = IT.commaSep lexer
+> commaSep1      = IT.commaSep1 lexer
+
+< lexeme         = IT.lexeme lexer
+< angles         = IT.angles lexer
+< semi           = IT.semi lexer
+< comma          = IT.comma lexer
+< colon          = IT.colon lexer
+< semiSep        = IT.semiSep lexer
+< semiSep1       = IT.semiSep1 lexer
+
+> backticks p = reservedOp "`" *> p <* reservedOp "`"
+
+> specialOp s = try $
+>     string s >> notFollowedBy (opLetter def) >> whiteSpace
+
+> optionalList p = maybe [] id <$> optional p
+
+> doubleColon = reservedOp "::"
+
+> underscore = reserved "_"
+
+> wrapParens p = (\ s -> "(" ++ s ++ ")") <$> p
+
+> single p = (\ x -> [x]) <$> p
+> manymany p = join <$> many p 
+
+> isVar :: String -> Bool
+> isVar ('_':_:_)  = True
+> isVar (x:_)      = isLower x
+> isVar []         = error "isVar: empty"
+
+> isVarOp :: String -> Bool
+> isVarOp (':':_)  = False
+> isVarOp _        = True
+
+> identLike v desc = try $ do
+>     s <- identifier <?> desc
+>     when (v /= isVar s) $ fail $ "expected " ++ desc
+>     return s
+
+> opLike v desc = try $ do
+>     s <- operator <?> desc
+>     when (v /= isVarOp s) $ fail $ "expected " ++ desc
+>     return s
+
+
+> varid   = identLike True "variable"
+> conid   = identLike False "constructor"
+> varsym  = wrapParens (opLike True "variable symbol")
+> consym  = wrapParens (opLike False "constructor symbol")
+
+> var     = varid <|> try (parens varsym)
+> con     = conid <|> try (parens consym)
+> varop   = varsym <|> backticks varid
+> conop   = consym <|> backticks conid
+
+< op      = varop <|> conop
+
+> gcon    =    reservedOp "()" *> return "()"
+>         <|>  reservedOp "[]" *> return "[]"
+>         <|>  reservedOp "(,)" *> return "(,)"
+>         <|>  con
+
+> gtycon =     reservedOp "()" *> return "()"
+>         <|>  reservedOp "[]" *> return "[]"
+>         <|>  reservedOp "(,)" *> return "(,)"
+>         <|>  con
+
+
+
+Kinds
+
+> kind       = kindBit `chainr1` kindArrow
+> kindBit    = setKind <|> try numKind <|> natKind <|> constraintKind <|> parens kind
+> setKind    = symbol "*" >> return SKSet
+> numKind    = (symbol "Integer" <|> symbol "Num") >> return SKNum
+> natKind    = symbol "Nat" >> return SKNat
+> constraintKind = symbol "Constraint" >> return SKConstraint
+> kindArrow  = reservedOp "->" >> return (:-->)
+
+
+
+Types
+
+> tyVarName  = identLike True "type variable"
+> tyConName  = identLike False "type constructor"
+>              <|> try (reservedOp "()" >> return unitTypeName)
+> numVarName = identLike True "numeric type variable"
+> tyVar      = STyVar <$> tyVarName
+> tyCon      = STyCon <$> gtycon
+> tyExp      = tyAll <|> tyPi <|> tyQual <|> tyExpArr
+> tyAll      = tyQuant "forall" (SBind All)
+> tyPi       = tyQuant "pi" (SBind Pi)
+> tyExpArr   = tyBit `chainr1` tyArrow
+> tyArrow    = reservedOp "->" *> return (--->)
+>            <|> reservedOp "=>" *> return SQual
+
+> tyBit = buildExpressionParser
+>     [  [prefix "-" negate]
+>     ,  [binary "^" (sbinOp Pow) AssocLeft]
+>     ,  [binary "*" (*) AssocLeft]
+>     ,  [binary "+" (+) AssocLeft, sbinary "-" (-) AssocLeft]
+>     ,  [  binary "<"  (styPred LS) AssocNone
+>        ,  binary "<=" (styPred LE) AssocNone
+>        ,  binary ">"  (styPred GR) AssocNone
+>        ,  binary ">=" (styPred GE) AssocNone
+>        ,  binary "~"  (styPred EL) AssocNone
+>        ] 
+>     ]
+>     (tyAtom `chainl1` pure STyApp)
+
+> tyAtom     =    STyInt <$> try natural
+>            <|>  SBinOp <$> prefixBinOp
+>            <|>  SUnOp <$> prefixUnOp
+>            <|>  STyComp <$> prefixComparator
+>            <|>  tyVar
+>            <|>  tyCon
+>            <|>  parens ((reservedOp "->" *> pure SArr) <|> fmap (foldr1 (STyApp . STyApp (STyCon tupleTypeName))) (commaSep1 tyExp))
+>            <|>  brackets (STyApp (STyCon listTypeName) <$> tyExp)
+
+> prefixBinOp  =    reserved "min" *> pure Min
+>              <|>  reserved "max" *> pure Max
+>              <|>  try (parens ((specialOp "-" *> pure Minus)
+>                                <|> (reservedOp "*" *> pure Times)
+>                                <|> (reservedOp "+" *> pure Plus)
+>                                <|> (reservedOp "^" *> pure Pow)))
+
+> prefixUnOp   =    reserved "abs" *> pure Abs
+>              <|>  reserved "signum" *> pure Signum
+
+> prefixComparator  =    reservedOp "(~)" *> pure EL
+>                   <|>  reservedOp "(>=)" *> pure GE
+>                   <|>  reservedOp "(>)"  *> pure GR
+>                   <|>  reservedOp "(<=)" *> pure LE
+>                   <|>  reservedOp "(<)"  *> pure LS
+
+> binary   name fun assoc = Infix (do{ reservedOp name; return fun }) assoc
+> sbinary  name fun assoc = Infix (do{ specialOp name; return fun }) assoc
+> prefix   name fun       = Prefix (do{ reservedOp name; return fun })
+
+< postfix  name fun       = Postfix (do{ reservedOp name; return fun })
+
+
+> tyQuant q f = do
+>     reserved q
+>     aks <- many1 $ foo <$> quantifiedVar
+>     reservedOp "."
+>     t <- tyExp
+>     return $ foldr (\ (a, k) ty -> f a k ty) t $ join aks
+>   where
+>     foo :: ([as], k) -> [(as, k)]
+>     foo (as, k) = map (\ a -> (a, k)) as
+
+> quantifiedVar  =    parens ((,) <$> many1 tyVarName <* doubleColon <*> kind)
+>                <|>  (\ a -> ([a] , SKSet)) <$> tyVarName
+
+> tyQual = do
+>     ps <- try ((parens constraints <|> (pure <$> tyBit)) <* reservedOp "=>")
+>     t <- tyExp
+>     return $ foldr SQual t ps
+
+> constraints = commaSep1 constraint
+> constraint = tyBit
+
+> predicates = commaSep1 predicate
+
+> predicate = do
+>     c <- constraint
+>     case sConstraintToPred c of
+>         Just p   -> return p
+>         Nothing  -> fail "expected testable predicate"
+
+
+
+
+Terms
+
+> expr = do
+>     t    <- lexp
+>     mty  <- optionMaybe (doubleColon >> tyExp)
+>     case mty of
+>         Just ty -> return $ t :? ty
+>         Nothing -> return t
+
+> lexp  =    lambda
+>       <|>  letExpr
+>       <|>  caseExpr
+>       <|>  fexp
+
+
+> letExpr = do
+>     reserved "let"
+>     ds <- I.block decls
+>     reserved "in"
+>     t <- expr
+>     return $ Let ds t
+
+> caseExpr = do
+>     reserved "case"
+>     t <- expr
+>     reserved "of"
+>     as <- I.block $ many caseAlternative
+>     return $ Case t as
+
+> caseAlternative = I.lineFold (CaseAlt <$> pat <*> altRest (reservedOp "->")
+>     <?> "case alternative")
+
+> fexp = buildExpressionParser
+>     [
+>         [prefix "-" (tmBinOp Minus (TmInt 0))],
+>         [binary "^" (tmBinOp Pow) AssocLeft],
+>         [binary "*" (tmBinOp Times) AssocLeft],    
+>         [binary "+" (tmBinOp Plus) AssocLeft, sbinary "-" (tmBinOp Minus) AssocLeft],
+>         [binary ":" (TmApp . TmApp (TmCon listConsName)) AssocRight]
+>     ]
+>     (aexp `chainl1` pure TmApp)
+
+> aexp :: I.IndentCharParser st (STerm ())
+> aexp  =    TmInt <$> try natural
+>       <|>  CharLit <$> charLiteral
+>       <|>  StrLit  <$> stringLiteral
+>       <|>  TmVar <$> var
+>       <|>  TmCon <$> gcon
+>       <|>  parens (fmap (foldr1 (TmApp . TmApp (TmCon tupleConsName))) (commaSep1 expr))
+>       <|>  braces (TmBrace <$> tyBit) 
+>       <|>  listy
+
+> listy = foldr (TmApp . TmApp (TmCon listConsName)) (TmCon listNilName) <$> brackets (commaSep fexp)
+
+> lambda = do
+>     reservedOp "\\"
+>     ss <- many1 $ (Left <$> var) <|> (Right <$> braces numVarName)
+>     reservedOp "->"
+>     t <- expr
+>     return $ wrapLam ss t
+>   where
+>     wrapLam []              t = t
+>     wrapLam (Left s : ss)   t = Lam s $ wrapLam ss t
+>     wrapLam (Right s : ss)  t = NumLam s $ rawCoerce $ wrapLam ss t
+
+
+Interface files
+
+> interface = manymany (   single dataDecl
+>                      <|> single typeDecl
+>                      <|> single classDecl
+>                      <|> single instHeader
+>                      <|> map Decl <$> sigDecls
+>                      ) <* eof
+
+
+Modules
+
+> module_ = do
+>     whiteSpace
+>     _ <- optional (reserved "#line" >> integer >> stringLiteral)
+>     mh <- optional (reserved "module" *>
+>                        ((,) <$> moduleName
+>                            <*> optionalList (parens (commaSep identifier)))
+>                     <* reserved "where")
+>     is <- many importStmt
+>     ds <- topdecls
+>     eof
+>     return $ Mod mh is ds
+
+> importStmt = do
+>     reserved "import"
+>     q   <- isJust <$> optional (reserved "qualified")
+>     n   <- moduleName
+>     as  <- optional (reserved "as" *> moduleName)
+>     im  <- importSpec
+>     return $ Import q n as im
+
+> importSpec =    Imp <$> parens (commaSep identifier)
+>            <|>  ImpHiding <$> (reserved "hiding" *> parens (commaSep (var <|> con)))
+>            <|>  pure ImpAll
+
+> moduleName = join . intersperse "." <$> identLike False "module name" `sepBy` dot
+
+
+> topdecls  = associateTop <$> manymany (   single dataDecl
+>                                       <|> single typeDecl
+>                                       <|> single classDecl
+>                                       <|> single instDecl
+>                                       <|> map Decl <$> (sigDecls <|> single funDecl)
+>                                       )
+>  where
+>     associateTop :: [STopDeclaration] -> [STopDeclaration]
+>     associateTop = map joinFun . groupBy sameFun
+>
+>     sameFun (Decl (FunDecl x _)) (Decl (FunDecl y _))  = x == y
+>     sameFun _             _                            = False
+> 
+>     joinFun :: [STopDeclaration] -> STopDeclaration
+>     joinFun [d] = d
+>     joinFun fs@(Decl (FunDecl x _) : _) = Decl (FunDecl x (join (map altsOf fs)))
+>     joinFun _ = error "joinFun: impossible"
+>
+>     altsOf (Decl (FunDecl _ as)) = as
+>     altsOf _ = error "altsOf: impossible"
+
+> decls     = associate <$> manymany (sigDecls <|> single funDecl)
+>   where
+>     associate :: [SDeclaration ()] -> [SDeclaration ()]
+>     associate = map joinFun . groupBy sameFun
+>
+>     sameFun (FunDecl x _) (FunDecl y _)  = x == y
+>     sameFun _             _              = False
+> 
+>     joinFun :: [SDeclaration ()] -> SDeclaration ()
+>     joinFun [d] = d
+>     joinFun fs@(FunDecl x _ : _) = FunDecl x (join (map altsOf fs))
+>     joinFun _ = error "joinFun: impossible"
+>
+>     altsOf (FunDecl _ as) = as
+>     altsOf _ = error "altsOf: impossible"
+
+
+
+> dataDecl = I.lineFold $ do
+>     try (reserved "data")
+>     s <- tyConName
+>     k <- (doubleColon >> kind) <|> return SKSet
+>     reserved "where"
+>     cs <- many $ I.lineFold constructor
+>     ds <- maybe [] id <$> optional (reserved "deriving" >>
+>               parens (commaSep className)
+>               <|> fmap pure className)
+>     return $ DataDecl s k cs ds
+>     
+
+
+> typeDecl = I.lineFold $ do
+>     reserved "type"
+>     x <- tyConName
+>     t <- tySyn
+>     return $ TypeDecl x t
+>   where
+>     tySyn = SSynTy <$> (reservedOp "=" *> tyExp)
+>           <|> SSynAll <$> tyVarName <*> pure SKSet <*> tySyn
+>           <|> (do
+>                 (x, k)  <- kindParens
+>                 t       <- tySyn
+>                 return $ SSynAll x k t
+>               )
+
+
+> kindParens = parens ((,) <$> tyVarName <* doubleColon <*> kind)
+
+
+> className = identLike False "type class name"
+
+> classDecl = I.lineFold $ do
+>     reserved "class"
+>     ss  <- optionalList $ parens (commaSep tyExp) <* reservedOp "=>"
+>     s   <- className
+>     vs  <- many classVar
+>     ms  <- optionalList (reserved "where" *> manymany tmtypes)
+>     return $ CDecl s (ClassDecl vs ss ms) 
+>   where
+>     classVar = ( ((\ v -> VK v SKSet) <$> var)
+>              <|> parens (VK <$> var <*> (doubleColon *> kind)))
+
+> instDecl = I.lineFold $ do
+>     reserved "instance"
+>     t <- tyExp
+>     (cs, s, ts) <- implyBits t
+>     zs <- optionalList (reserved "where" *> many funline)
+>     return $ IDecl s (InstDecl ts cs zs)
+
+
+> implyBits :: Monad m => SType -> m ([SType], String, [SType])
+> implyBits (SQual q t) = do
+>     let qs = uncomma q
+>     (cs, s, ts) <- implyBits t
+>     return (qs ++ cs, s, ts)
+>   where
+>     uncomma (STyCon c `STyApp` x `STyApp` y)
+>         | c == tupleConsName = uncomma x ++ uncomma y
+>     uncomma x = [x]
+> implyBits (STyApp f t) = do
+>     ([], s, ts) <- implyBits f
+>     return ([], s, ts ++ [t])
+> implyBits (STyCon c) = return ([], c, [])
+> implyBits _ = fail "ook"
+
+
+
+> instHeader = instDecl
+
+
+> constructor = do
+>     s <- con
+>     doubleColon
+>     t <- tyExp
+>     return $ s ::: t
+
+
+> tmtypes = I.lineFold $ do
+>     ss  <- try $ commaSep var <* doubleColon
+>     ty  <- tyExp
+>     return $ map (\ s -> s ::: ty) ss
+
+> sigDecls = map (\ (s ::: ty) -> SigDecl s ty) <$> tmtypes
+
+> funline = I.lineFold $ do
+>     (v, ps)  <- funlhs
+>     gt       <- rhs
+>     return (v, [Alt (foldr (:!) P0 ps) gt])
+
+> funDecl = uncurry FunDecl <$> funline
+
+> altRest p  =    Unguarded <$> (p *> expr) <*> whereClause
+>            <|>  Guarded <$> (many1 (reservedOp "|" *> ((:*:) <$> guarded <* p <*> expr)))
+>                     <*> whereClause
+
+> guarded  =    NumGuard <$> braces predicates
+>          <|>  ExpGuard <$> commaSep expr
+
+> whereClause = maybe [] id <$> optional (reserved "where" >> I.block decls)
+
+
+
+
+
+> funlhs  =    (,) <$> var <*> many apat
+>         <|>  (\ x o y -> (o, [x, y])) <$> pat <*> varop <*> pat
+>         <|>  (\ (o, ps) qs -> (o, ps ++ qs)) <$> parens funlhs <*> many apat
+
+> rhs = (Unguarded <$> (reservedOp "=" *> expr)
+>     <|> Guarded <$> (many1 (reservedOp "|" *> ((:*:) <$> guarded <* reservedOp "=" <*> expr))))
+>     <*> whereClause
+
+
+> rtc p  =    (:!) <$> p <*> rtc p
+>        <|>  pure P0
+
+> patList = rtc apat
+
+> pat = do
+>     l   <- lpat
+>     mr  <- optional ((,) <$> conop <*> pat)
+>     case mr of
+>         Nothing      -> return l
+>         Just (o, r)  -> return $ PatCon o (l :! r :! P0)
+
+> lpat  =    PatCon <$> gcon <*> patList
+>       <|>  apat
+
+> apat =        nplusk
+>          <|>  PatCon <$> gcon <*> pure P0
+>          <|>  PatIntLit <$> try integer
+>          <|>  PatStrLit <$> stringLiteral
+>          <|>  PatCharLit <$> charLiteral
+>          <|>  underscore *> pure PatIgnore
+>          <|>  parens (foldr1 tupleConsPat <$> commaSep1 pat)
+>          <|>  brackets (foldr listConsPat listNilPat <$> commaSep pat)
+>          <|>  braces patBrace
+>   where
+>     tupleConsPat x y  = PatCon tupleConsName (x :! y :! P0)
+>     listConsPat x y   = PatCon listConsName (x :! y :! P0)
+>     listNilPat        = PatCon listNilName P0
+
+> nplusk = do
+>     v <- var
+>     mk <- optional (reservedOp "+" *> integer)
+>     return $ case mk of
+>        Nothing  -> PatVar v
+>        Just k   -> PatNPlusK v k
+
+
+> patBrace = do
+>     ma  <- optional var
+>     k   <- option 0 $ case ma of
+>                           Just _   -> reservedOp "+" *> integer
+>                           Nothing  -> integer
+>     return $ case ma of
+>         Just a   -> rawCoerce2 $ PatBrace a k
+>         Nothing  -> PatBraceK k
diff --git a/src/Language/Inch/PrettyPrinter.lhs b/src/Language/Inch/PrettyPrinter.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/PrettyPrinter.lhs
@@ -0,0 +1,319 @@
+> {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts,
+>              TypeOperators, GADTs, PatternGuards #-}
+
+> module Language.Inch.PrettyPrinter where
+
+> import Data.Foldable
+> import Data.List
+> import Text.PrettyPrint.HughesPJ
+
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.BwdFwd
+> import Language.Inch.Syntax
+> import Language.Inch.ModuleSyntax
+> import Language.Inch.Kit
+
+
+> data Size = ArgSize | AppSize | ArrSize | LamSize
+>     deriving (Bounded, Eq, Ord, Show)
+
+> class Pretty x where
+>     pretty :: x -> Size -> Doc
+
+> prettyLow :: Pretty x => x -> Doc
+> prettyLow = flip pretty minBound
+
+> prettyHigh :: Pretty x => x -> Doc
+> prettyHigh = flip pretty maxBound
+
+> wrapDoc :: Size -> Doc -> Size -> Doc
+> wrapDoc dSize d curSize
+>   | dSize > curSize  = parens d
+>   | otherwise        = d
+
+> prettyVar :: Var () k -> Doc
+> prettyVar = prettyHigh . fogVar
+
+> prettySysVar :: Var () k -> Doc
+> prettySysVar = prettyHigh . fogSysVar
+
+> prettyFog :: (TravTypes1 t, Pretty (t RAW ())) => t OK () -> Doc
+> prettyFog = prettyHigh . fog1
+
+> prettyFogSys :: (TravTypes1 t, Pretty (t RAW ())) => t OK () -> Doc
+> prettyFogSys = prettyHigh . fogSys
+
+> renderMe :: Pretty a => a -> String
+> renderMe x = renderStyle style{ribbonsPerLine=1.2, lineLength=80} (prettyHigh x)
+
+> (<++>) :: Doc -> Doc -> Doc
+> d1 <++> d2 = sep [d1, nest 2 d2]
+> infix 2 <++>
+
+
+> instance Pretty String where
+>     pretty s _ = text s
+
+> instance Pretty [STopDeclaration] where
+>     pretty ds _ = vcat (map prettyHigh ds)
+
+> instance Pretty SKind where
+>     pretty SKSet       = const $ text "*"
+>     pretty SKNum       = const $ text "Integer"
+>     pretty SKNat       = const $ text "Nat"
+>     pretty SKConstraint = const $ text "Constraint"
+>     pretty (k :--> l)  = wrapDoc AppSize $
+>         pretty k ArgSize <+> text "->" <+> pretty l AppSize
+
+> instance Pretty Binder where
+>     pretty Pi _   = text "pi"
+>     pretty All _  = text "forall"
+
+> instance Pretty ty => Pretty (Pred ty) where
+>     pretty (P c n m) = wrapDoc AppSize $
+>         pretty n ArgSize <+> pretty c ArgSize <+> pretty m ArgSize
+>     pretty (p :=> q) = wrapDoc AppSize $ 
+>         pretty p ArgSize <+> text "=>" <++> pretty q ArgSize
+
+> instance Pretty Comparator where
+>     pretty LS _ = text "<"
+>     pretty LE _ = text "<=" 
+>     pretty GR _ = text ">"
+>     pretty GE _ = text ">="
+>     pretty EL _ = text "~"
+
+> instance Pretty UnOp where
+>     pretty o _ = text $ unOpString o
+
+> instance Pretty BinOp where
+>     pretty o _ | binOpInfix o  = text $ "(" ++ binOpString o ++ ")"
+>                | otherwise     = text $ binOpString o
+
+> instance Pretty SType where
+>     pretty (STyVar v)                  = const $ text v
+>     pretty (STyCon c)                  = const $ text c
+>     pretty (STyApp (STyCon l) t) | l == listTypeName  = const $ brackets (prettyHigh t)
+>     pretty (STyApp (STyApp (STyCon c) s) t) | c == tupleTypeName = const $ parens (prettyHigh s <> text "," <+> prettyHigh t)
+>     pretty (STyApp (STyApp f s) t) | Just fx <- infixName f = wrapDoc ArrSize $ 
+>         pretty s AppSize <+> text fx <++> pretty t AppSize
+>     pretty (STyApp f s)  = wrapDoc AppSize $ 
+>         pretty f AppSize <+> pretty s ArgSize
+>     pretty (SBind b a k t)  = prettyBind b (B0 :< (a, k)) t
+>     pretty (SQual p t)      = prettyQual (B0 :< p) t
+>     pretty SArr             = const $ text "(->)"
+>     pretty (STyInt k)       = wrapDoc (if k < 0 then ArrSize else minBound) $
+>                                   integer k
+>     pretty (SBinOp o)       = pretty o
+>     pretty (SUnOp o)        = pretty o
+>     pretty (STyComp c)      = const . parens $ prettyHigh c
+ 
+> infixName :: SType -> Maybe String
+> infixName SArr                       = Just "->"
+> infixName (SBinOp o) | binOpInfix o  = Just (binOpString o)
+> infixName (STyCon ('(':s))           = Just (init s)
+> infixName (STyComp c)                = Just (show (prettyHigh c))
+> infixName _                          = Nothing
+
+
+> prettyBind :: Binder -> Bwd (String, SKind) ->
+>     SType -> Size -> Doc
+> prettyBind b bs (SBind b' a k t) | b == b' = prettyBind b (bs :< (a, k)) t
+> -- prettyBind b (bs :< (a, SKNum)) (SQual (P LE 0 (STyVar a')) t) | a == a' = prettyBind b (bs :< (a, SKNat)) t
+> prettyBind b bs t = wrapDoc LamSize $ prettyHigh b
+>         <+> prettyBits (trail bs)
+>         <+> text "." <++> pretty t ArrSize
+>   where
+>     prettyBits []             = empty
+>     prettyBits ((a, SKSet) : aks) = text a <+> prettyBits aks
+>     prettyBits ((a, k) : aks) = parens (text a <+> text "::" <+> prettyHigh k) <+> prettyBits aks
+
+
+> prettyQual :: Bwd SType -> SType -> Size -> Doc
+> prettyQual ps (SQual p t) = prettyQual (ps :< p) t
+> prettyQual ps t = wrapDoc ArrSize $
+>     prettyPreds (trail ps) <+> text "=>" <++> pretty t ArrSize
+>   where
+>     prettyPreds xs = parens (hsep (punctuate (text ",") (map prettyHigh xs)))
+
+
+> instance Pretty (STerm a) where
+>     pretty (TmVar x)    = const $ text x
+>     pretty (TmCon s)    = const $ text s
+>     pretty (TmInt k)    = wrapDoc (if k < 0 then ArrSize else minBound) $
+>                               integer k
+>     pretty (CharLit c)  = const $ text $ show c
+>     pretty (StrLit s)   = const $ text $ show s
+>     -- pretty (TmApp (TmApp f m) n) | Just s <- infixTmName f =
+>     --    wrapDoc AppSize $ pretty m ArgSize <+> text s <+> pretty n ArgSize
+>     pretty (TmApp f s)  = wrapDoc AppSize $
+>         pretty f AppSize <++> pretty s ArgSize
+>     pretty (TmBrace n)  = const $ braces $ prettyHigh n 
+>     pretty (Lam x t)    = prettyLam (text x) t
+>     pretty (NumLam x t) = prettyLam (braces (text x)) t
+>     pretty (Let ds t)   = wrapDoc maxBound $ text "let" <+> vcatSpacePretty ds $$ text "in" <+> prettyHigh t
+>     pretty (Case t as)  = wrapDoc maxBound $ text "case" <+> prettyHigh t <+> text "of" <++> vcatPretty as
+>     pretty (t :? ty)    = wrapDoc ArrSize $ 
+>         pretty t AppSize <+> text "::" <+> pretty ty maxBound
+
+> infixTmName :: STerm a -> Maybe String
+> infixTmName (TmVar ('(':v)) = Just (init v)
+> infixTmName _ = Nothing
+
+> prettyLam :: Doc -> STerm a -> Size -> Doc
+> prettyLam d (Lam x t) = prettyLam (d <+> text x) t
+> prettyLam d (NumLam a t) = prettyLam (d <+> braces (text a)) t
+> prettyLam d t = wrapDoc LamSize $
+>         text "\\" <+> d <+> text "->" <+> pretty t AppSize
+
+
+> parenCommaList :: Doc -> [String] -> Doc
+> parenCommaList _ [] = empty
+> parenCommaList d xs = d <+> parens (hsep (punctuate (text ",") (map text xs)))
+
+
+> instance Pretty SModule where
+>     pretty (Mod mh is ds) _ = maybe empty prettyModHeader mh
+>                                   $$ vcat (map prettyHigh is)
+>                                   $$ vcat (intersperse (text " ") (map prettyHigh ds))
+>       where
+>         prettyModHeader (s, es) = text "module" <+> text s <+> parenCommaList empty es <+> text "where"
+
+
+> instance Pretty Import where
+>     pretty (Import q n as imp) _ = text "import"
+>                                            <+> (if q then text "qualified" else empty)
+>                                            <+> text n
+>                                            <+> (maybe empty (\ s -> text "as" <+> text s) as)
+>                                            <+> prettyHigh imp
+
+> instance Pretty ImpSpec where
+>     pretty ImpAll          _ = empty
+>     pretty (Imp xs)        _ = parens (hsep (punctuate (text ",") (map text xs)))
+>     pretty (ImpHiding xs)  _ = text "hiding" <+> parens (hsep (punctuate (text ",") (map text xs)))
+
+
+> instance Pretty STypeSyn where
+>     pretty (SSynTy t)      _ = text "=" <+> prettyHigh t
+>     pretty (SSynAll x k t) _ = kindBracket k <+> prettyHigh t
+>       where
+>         kindBracket SKSet  = text x
+>         kindBracket l      = parens (text x <+> text "::" <+> prettyHigh l)
+
+> instance Pretty STopDeclaration where
+>     pretty (DataDecl n k cs ds) _ = hang (text "data" <+> text n
+>         <+> (if k /= SKSet then text "::" <+> prettyHigh k else empty)
+>         <+> text "where") 2 $
+>             vcat (map prettyHigh cs) $$ derivingClause ds
+>       where
+>         derivingClause []  = empty
+>         derivingClause xs  = text "deriving" <+>
+>                                parens (hsep (punctuate  (text ",") (map text xs)))
+>     pretty (TypeDecl x t) _ = text "type" <+> text x <+> prettyHigh t
+>     pretty (CDecl x (ClassDecl vs ss ms)) _ =
+>         hang (text "class"
+>               <+> (if null ss then empty else parens (fsepPretty ss) <+> text "=>")
+>               <+> text x <+> fsep (map prettyHigh vs)
+>               <+> text "where") 2 $
+>                   vcat (map prettyHigh ms)
+>     pretty (IDecl x (InstDecl ts cs zs)) _ =
+>         hang (text "instance"
+>               <+> (if null cs then empty else parens (fsepPretty cs) <+> text "=>")
+>               <+> text x  <+> fsep (map prettyLow ts)
+>               <+> text "where") 2 $
+>                   vcat (map (prettyHigh . uncurry FunDecl) zs)
+>     pretty (Decl d) s = pretty d s
+
+> instance Pretty (SDeclaration a) where
+>     pretty (FunDecl n ps) _ = vcat (map ((text n <+>) . prettyHigh) ps)
+>     pretty (SigDecl n ty) _ = text n <+> text "::" <+> prettyHigh ty
+
+
+> instance (Pretty x, Pretty p) => Pretty (x ::: p) where
+>   pretty (x ::: p) _ = prettyHigh x <+> text "::" <+> prettyHigh p
+
+
+
+> instance Pretty (SCaseAlternative a) where
+>     pretty (CaseAlt v gt) _ = prettyHigh v <+> prettyGuardTerms (text "->") gt
+
+> instance Pretty (SAlternative a) where
+>     pretty (Alt vs gt) _ = prettyLow vs <+> prettyGuardTerms (text "=") gt
+
+
+> prettyGuardTerms :: Doc -> SGuardTerms a -> Doc
+> prettyGuardTerms d (Unguarded e ds) = d <++> prettyHigh e $$ prettyWhere ds
+> prettyGuardTerms d (Guarded gts ds) =
+>     vcat (map (\ (g :*: e) -> text "|" <+> prettyLow g <+> d <+> prettyHigh e) gts)
+>     $$ prettyWhere ds
+
+> prettyWhere :: [SDeclaration a] -> Doc 
+> prettyWhere []  = empty
+> prettyWhere ds  = text "where" <+> vcat (map prettyHigh ds)
+
+
+
+> instance Pretty (SPatternList a b) where
+>     pretty P0         _  = empty
+>     pretty (p :! ps)  z  = pretty p z <+> pretty ps z
+
+> instance Pretty (SPattern a b) where
+>     pretty (PatVar x)    = const $ text x
+>     pretty (PatCon c P0) = const $ text c
+>     pretty (PatCon "+" (a :! b:! P0)) = wrapDoc AppSize $
+>         prettyLow a <+> text "+" <+> prettyLow b
+>     pretty (PatCon c ps) = wrapDoc AppSize $
+>                                text c <+> prettyLow ps
+>     pretty PatIgnore = const $ text "_"
+>     pretty (PatBraceK k)   = const $ braces $ integer k
+>     pretty (PatBrace a 0)  = const $ braces $ text a
+>     pretty (PatBrace a k)  = const $ braces $
+>                                     text a <+> text "+" <+> integer k
+>     pretty (PatIntLit i)   = const $ integer i
+>     pretty (PatCharLit c)  = const $ text $ show c
+>     pretty (PatStrLit s)   = const $ text $ show s
+>     pretty (PatNPlusK n k) = const $ parens $ text n <+> text "+" <+> integer k
+
+> instance Pretty (SGuard a) where
+>     pretty (ExpGuard t)  = const $ fsepPretty t
+>     pretty (NumGuard p)  = const $ braces (fsepPretty p)
+
+
+> instance Pretty (VarList RAW a b) where
+>     pretty P0         _  = empty
+>     pretty (p :! ps)  z  = pretty p z <+> pretty ps z
+
+> instance Pretty (VarBinding RAW a b) where
+>     pretty (VB x SKSet) _ = prettyHigh x
+>     pretty (VB x k)     _ = parens (prettyHigh x <+> text "::" <+> prettyHigh k)
+
+> instance Pretty (TyList RAW a b) where
+>     pretty P0               _  = empty
+>     pretty (TyK t _ :! ps)  z  = pretty t z <+> pretty ps z
+
+> instance Pretty (VarKind RAW ()) where
+>     pretty (VK v _) = pretty v
+
+> {-
+> instance Pretty SNormalPred where
+>     pretty p = pretty (reifyPred p)
+
+> instance Pretty SNormalNum where
+>     pretty n _ = prettyHigh $ reifyNum n
+> -}
+
+> instance Pretty x => Pretty (Bwd x) where
+>     pretty bs _ = fsep $ punctuate (text ",") (map prettyHigh (trail bs))
+
+> instance Pretty x => Pretty (Fwd x) where
+>     pretty bs _ = fsep $ punctuate (text ",") $ map prettyHigh $ Data.Foldable.foldr (:) [] bs
+
+
+> fsepPretty :: Pretty a => [a] -> Doc
+> fsepPretty xs  = fsep . punctuate (text ",") . map prettyHigh $ xs
+
+> vcatSpacePretty :: Pretty a => [a] -> Doc
+> vcatSpacePretty xs  = vcat . intersperse (text " ") . map prettyHigh $ xs
+
+> vcatPretty :: Pretty a => [a] -> Doc
+> vcatPretty xs  = vcat . map prettyHigh $ xs
diff --git a/src/Language/Inch/ProgramCheck.lhs b/src/Language/Inch/ProgramCheck.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/ProgramCheck.lhs
@@ -0,0 +1,256 @@
+> {-# LANGUAGE GADTs, TypeOperators, FlexibleContexts, RankNTypes #-}
+
+> module Language.Inch.ProgramCheck where
+
+> import Control.Applicative hiding (Alternative)
+> import Control.Monad
+> import Control.Monad.State
+> import Control.Monad.Writer hiding (All)
+> import Data.List
+> import Data.Traversable
+> import Text.PrettyPrint.HughesPJ
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.Syntax
+> import Language.Inch.ModuleSyntax
+> import Language.Inch.Context
+> import Language.Inch.Kit
+> import Language.Inch.Error
+> import Language.Inch.KindCheck
+> import Language.Inch.TypeCheck
+> import Language.Inch.Check
+> import Language.Inch.PrettyPrinter
+
+> checkModule :: SModule -> [STopDeclaration] -> Contextual Module
+> checkModule (Mod mh is ds) xs = do
+>     mapM_ makeTyCon xs
+>     mapM_ (makeTopBinding True) xs
+>     mapM_ checkTopDecl' xs
+>     mapM_ makeTyCon ds
+>     mapM_ (makeTopBinding False) ds
+>     ds' <- concat <$> traverse checkTopDecl' ds
+>     return $ Mod mh is ds'
+>   where
+>     checkTopDecl' ds' = assertContextEmpty *> checkTopDecl ds' <* assertContextEmpty 
+>
+>     makeTyCon :: STopDeclaration -> Contextual ()
+>     makeTyCon (DataDecl t k _ _) = inLocation (text "in data type" <+> text t) $
+>         case kindKind k of
+>           Ex k' -> do
+>             unless (targetsSet k') $ errKindTarget k
+>             insertTyCon t (Ex k')
+>     makeTyCon (TypeDecl x t) = inLocation (text "in type synonym" <+> text x) $ do
+>         Ex t' <- checkTySyn B0 t
+>         insertTySyn x t'
+>     makeTyCon (CDecl x d)  = insertTyCon x (classKind d)
+>     makeTyCon (IDecl _ _)  = return ()
+>     makeTyCon (Decl _)     = return ()
+
+
+> checkTySyn :: Bwd (Ex (Var ())) -> STypeSyn -> Contextual (Ex (TySyn ()))
+> checkTySyn b (SSynTy t) = do
+>     TK t' _ <- inferKind All b t
+>     return . Ex $ SynTy t'
+> checkTySyn b (SSynAll x k t) = case kindKind k of                               
+>     Ex k' -> do
+>         v   <- freshVar (UserVar All) x k'
+>         Ex t'  <- checkTySyn (b :< Ex v) t
+>         return . Ex $ SynAll x k' (bindTySyn v t')
+
+
+> makeTopBinding :: Bool -> STopDeclaration -> Contextual ()
+> makeTopBinding _ (DataDecl _ _ _ _)  = return ()
+> makeTopBinding _ (TypeDecl _ _)      = return ()
+> makeTopBinding _ (CDecl _ _)         = return ()
+> makeTopBinding _ (IDecl _ _)         = return ()
+> makeTopBinding b (Decl d)            = makeBinding b d
+
+
+
+> checkTopDecl :: STopDeclaration -> Contextual [TopDeclaration]
+> checkTopDecl (DataDecl t k cs ds) = checkDataDecl t k cs ds
+> checkTopDecl (TypeDecl x _)       = do
+>     Ex t' <- lookupTySyn x
+>     return [TypeDecl x t']
+> checkTopDecl (CDecl x d) = (\ d' -> [CDecl x d']) <$> checkClassDecl x d
+> checkTopDecl (IDecl x d) = (\ d' -> [IDecl x d']) <$> checkInstDecl x d
+> checkTopDecl (Decl d) = do
+>     ds <- checkInferDecl d
+>     unless (all (goodDecl B0) ds) $ erk $
+>         unlines ("checkTopDecl: bad declaration" : map (renderMe . fog1) ds)
+>     return $ map Decl ds
+
+
+> checkDataDecl ::  TyConName -> SKind -> [TmConName ::: SType] ->
+>                      [String] -> Contextual [TopDeclaration]
+> checkDataDecl t k cs ds =  inLocation (text $ "in data type " ++ t) $ 
+>   unEx (kindKind k) $ \ k' -> do
+>     cs'    <- traverse checkConstructor cs
+>     mapM_ (checkDerived k') ds
+>     return [DataDecl t k' cs' ds]
+>   where
+>     checkConstructor :: SConstructor -> Contextual Constructor
+>     checkConstructor (c ::: ty) = inLocation (text $ "in constructor " ++ c) $ do
+>         ty' <- checkKind KSet All B0 (wrapForall [] ty)
+>         unless (ty' `targets` t) $ errConstructorTarget ty
+>         ty'' <- goGadtMangle ty'
+>         insertTmCon c ty''
+>         return (c ::: ty'')
+> 
+>     checkDerived :: Kind k -> ClassName -> Contextual ()
+>     checkDerived l x
+>       | x `notElem` derivableClasses = erk $ "Cannot derive instance of " ++ x
+>       | otherwise = insertInstDecl x =<< instDecl l (TyCon t l)
+>                         (\ s -> TyCon x (KSet :-> KConstraint) `TyApp` s)
+>                                                 
+>     instDecl :: Kind k -> Ty a k -> (Ty a KSet -> Type KConstraint) ->
+>                 Contextual (Type KConstraint)
+>     instDecl KSet        u f = return $ f u
+>     instDecl (k' :-> l)  u f = do
+>         v <- freshVar SysVar "_c" k'
+>         instDecl l (u `TyApp` TyVar (wkClosedVar v))
+>             (\ s -> Bind All "_c" k' (bindTy v (f s)))
+>     instDecl _ _ _ = erk "instDecl: bad kind"
+
+>     derivableClasses = ["Eq", "Ord", "Enum", "Bounded", "Show", "Read"] 
+
+
+> checkClassDecl :: ClassName -> SClassDeclaration -> Contextual ClassDeclaration
+> checkClassDecl x (ClassDecl vks ss ms) = inLocation (text $ "in class " ++ x) $ do
+>     vks'  <- traverse checkVK vks
+>     ss'   <- traverse (checkKind KConstraint All B0) ss
+>     ms'   <- traverse (wongle vks') ms
+>     putContext B0
+>     let d = ClassDecl vks' ss' ms'
+>     insertClassDecl x d
+>     return d
+>   where
+>     checkVK :: VarKind RAW () -> Contextual (VarKind OK ())
+>     checkVK (VK v k) = case kindKind k of
+>         Ex k' -> flip VK k' <$> fresh (UserVar All) v k' Fixed
+>
+>     wongle :: [VarKind OK ()] -> TmName ::: SType -> Contextual (TmName ::: Type KSet)
+>     wongle xs (m ::: t) = inLocation (text $ "in method " ++ m) $ do
+>         t' <- checkKind KSet All B0 (wrapForall (map (\ (VK v _) -> nameToString (varName v)) xs) t)
+>         let tsc = allWrapVK xs (Qual (applyVK (TyCon x) xs KConstraint) t')
+>         insertBinding m (Just tsc, True)
+>         -- mtrace $ "foo " ++ show tb ++ "\nbar " ++ show tsc
+>         return $ m ::: t'
+
+
+
+> checkInstDecl :: ClassName -> SInstDeclaration -> Contextual InstDeclaration
+> checkInstDecl x (InstDecl ts cs zs) =
+>   inLocation (text "in instance" <+> text x <+> fsep (map prettyLow ts)) $ do
+>       let vs = unions (map (collectUnbound []) ts ++ map (collectUnbound []) cs)
+>       vs' <- traverse (\ s -> fresh (UserVar All) s KSet Fixed) vs
+>       ClassDecl vks _ _ <- lookupClassDecl x
+>       cs' <- traverse checkPrecondition cs 
+>       ts' <- traverse (uncurry checkTyKind) (zip vks ts)
+>       zs' <- traverse (uncurry (checkMethod ts')) zs
+>       insertInstDecl x (allWrapVK (map (\ v -> VK v KSet) vs')
+>                            (cs' /=> applys (TyCon x) ts' KConstraint))
+>       putContext B0
+>       return $ InstDecl ts' cs' zs'
+>     where
+>       checkPrecondition :: SType -> Contextual (Type KConstraint)
+>       checkPrecondition c = do
+>           c' <- checkKind KConstraint All B0 c
+>           modifyContext (:< Constraint Given c')
+>           return c'
+
+>       checkTyKind :: VarKind OK () -> SType -> Contextual (Ex (Ty ()))
+>       checkTyKind (VK _ k) t = Ex <$> checkKind k All B0 t 
+>
+>       checkMethod :: [Ex (Ty ())] -> TmName -> [SAlternative ()] ->
+>                          Contextual (TmName, [Alternative ()])
+>       checkMethod tys mn as = do
+>           (_ ::: qty, _) <- lookupTopBinding mn 
+>           (\ as' -> (mn, as')) <$> checkFunDecl (instExTys tys qty) qty mn as
+> 
+>       instExTys :: [Ex (Ty ())] -> Type k -> Type k
+>       instExTys []          t                = t
+>       instExTys (Ex u : us) (Bind All _ k t) =
+>           hetEq (getTyKind u) k
+>               (instExTys us (instTy u t))
+>               (error "instExTys: bad")
+>       instExTys _ _ = error "instExTys: bad"
+
+> {-
+>       instSubst :: [(VarKind OK (), Ex (Ty ()))] -> Var () k -> Type k
+>       instSubst [] v = TyVar v
+>       instSubst ((VK w _, Ex u) : wus) v
+>           | v =?= w    = hetEq (getTyKind u) (varKind v) u (error "instSubst bad")
+>                                  
+>           | otherwise  = instSubst wus v
+> -}
+
+
+
+> goGadtMangle :: Type KSet -> Contextual (Type KSet)
+> goGadtMangle ty = do
+>     (ty', vts) <- runWriterT $ makeEqGadtMangle [] ty
+>     return $ foldr bindVarWrap ty' (map fst vts)
+>   where
+>     bindVarWrap :: Var () KNum -> Type KSet -> Type KSet
+>     bindVarWrap a = Bind All (fogVar a) KNum . bindTy a
+
+> makeEqGadtMangle :: [Ex (Var ())] -> Type KSet ->
+>     ContextualWriter [(Var () KNum, Maybe TypeNum)] (Type KSet)
+> makeEqGadtMangle as ty = do
+>     (ty', vts) <- lift $ runWriterT $ gadtMangle as ty
+>     tell $ map (\ (a, _) -> (a, Nothing)) vts
+>     return $ foldr makeEq ty' vts
+>   where
+>     makeEq :: (Var () KNum, Maybe TypeNum) -> Type KSet -> Type KSet
+>     makeEq (a, Just n)   = Qual (tyPred EL (TyVar a) n)
+>     makeEq (_, Nothing)  = id
+
+> gadtMangle :: [Ex (Var ())] -> Type k ->
+>     ContextualWriter [(Var () KNum, Maybe TypeNum)] (Type k)
+> gadtMangle as (Qual p t) = Qual p <$> gadtMangle as t
+> gadtMangle as (Bind b x k t) = do
+>     a <- freshVar SysVar x k
+>     let as' = case b of
+>                   All -> Ex a : as
+>                   _   -> as
+>         t' = unbindTy a t
+>     case getTyKind t' of
+>         KSet -> do
+>             t'' <- makeEqGadtMangle as' t'
+>             return $ Bind b x k (bindTy a t'')
+>         l -> errKindNotSet (fogKind l)
+
+> gadtMangle as (TyApp (TyApp Arr s) t) =
+>     TyApp (TyApp Arr s) <$> gadtMangle as t
+
+> gadtMangle xs (TyApp f s) = help xs (TyApp f s)
+>   where
+>     isAllBound :: [Ex (Var ())] -> Type k -> Either String [Ex (Var ())]
+>     isAllBound as (TyVar a)
+>         | Ex a `elem` as     = Right $ delete (Ex a) as
+>         | otherwise          = Left  $ fogVar a ++ "'"
+>     isAllBound _  _          = Left "_ga"
+
+>     help :: [Ex (Var ())] -> Type k ->
+>                 ContextualWriter [(Var () KNum, Maybe TypeNum)] (Type k)
+>     help _  (TyCon c k) = pure $ TyCon c k
+>     help as (TyApp g t) = do
+>         (t', as') <- warp as t
+>         TyApp <$> help as' g <*> pure t'
+>     help _ t = error $ "gadtMangle.help: malformed type " ++ show t
+
+>     warp :: [Ex (Var ())] -> Type k ->
+>                 ContextualWriter [(Var () KNum, Maybe TypeNum)]
+>                     (Type k, [Ex (Var ())])
+>     warp as t = case (isAllBound as t, getTyKind t) of
+>         (Right as', _) -> pure (t, as')
+>         (Left x, KNum) -> do
+>             a <- freshVar SysVar x KNum
+>             tell [(a, Just t)]
+>             return (TyVar a, as)
+>         (Left _, _) -> erk "Non-numeric GADT"
+
+> gadtMangle _ t = pure t
diff --git a/src/Language/Inch/Solver.lhs b/src/Language/Inch/Solver.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Solver.lhs
@@ -0,0 +1,295 @@
+> {-# LANGUAGE GADTs, TypeOperators, FlexibleContexts, PatternGuards,
+>              RankNTypes #-}
+
+> module Language.Inch.Solver where
+
+> import Control.Applicative hiding (Alternative)
+> import Control.Monad.Writer hiding (All)
+> import Data.List
+> import Data.Map (Map)
+> import qualified Data.Map as Map
+> import Data.Maybe
+
+> import qualified Data.Integer.Presburger as P
+> import Data.Integer.Presburger (Formula (TRUE, FALSE, (:=:), (:<:), (:<=:), (:>:), (:>=:), (:\/:), (:/\:), (:=>:)), (.*))
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Kind 
+> import Language.Inch.Type
+> import Language.Inch.TyNum
+> import Language.Inch.Context
+> import Language.Inch.Unify
+> import Language.Inch.Kit
+> import Language.Inch.Error
+> import Language.Inch.Check
+
+
+> unifySolveConstraints :: Contextual ()
+> unifySolveConstraints = do
+>     (g, ns) <- runWriter . collectEqualities <$> getContext
+>     putContext g
+>     mapM_ (uncurry unify) ns
+>     return ()
+>   where
+>     collectEqualities :: Context -> Writer [(Type KNum, Type KNum)] Context
+>     collectEqualities B0 = return B0
+>     collectEqualities (g :< Layer l True)  = return $ g :< Layer l True
+>     collectEqualities (g :< Layer l False) = (:< Layer l False) <$> collectEqualities g
+>     collectEqualities (g :< Constraint Wanted (TyComp EL `TyApp` m `TyApp` n)) = tell [(m, n)]
+>         >> collectEqualities g
+>     collectEqualities (g :< e) = (:< e) <$> collectEqualities g
+
+
+> trySolveConstraints :: Contextual ([Type KConstraint], [Type KConstraint])
+> trySolveConstraints = do
+>     g <- getContext
+>     let (g', vs, hs, ps) = collect g [] [] []
+>     putContext g'
+>     qs <- simplifyConstraints vs hs ps
+>     return (hs, qs)
+>   where
+>     collect :: Context -> [Ex (Var ())] -> [Type KConstraint] -> [Type KConstraint] ->
+>                    (Context, [Ex (Var ())], [Type KConstraint], [Type KConstraint])
+>     collect B0 vs hs ps = (B0, vs, hs, ps)
+>     collect (g :< Constraint Wanted p)  vs hs ps = collect g vs hs (p:ps)
+>     collect (g :< Constraint Given h)   vs hs ps =
+>         collect g vs (h:hs) ps <:< Constraint Given h
+>     collect (g :< A e@(a := Some d)) vs hs ps =
+>         collect g vs (map (replaceTy a d) hs) (map (replaceTy a d) ps) <:< A e
+>     collect (g :< A e@(a := _)) vs hs ps | a <? (hs, ps) =
+>         collect g (Ex a:vs) hs ps <:< A e
+>     collect (g :< Layer l True)   vs hs ps = (g :< Layer l True, vs', hs', ps')
+>         where (vs', hs', ps') = collectHyps g vs hs ps
+>     collect (g :< Layer l False)  vs hs ps = collect g vs hs ps <:< Layer l False
+>     collect (g :< e) vs hs ps = collect g vs hs ps <:< e
+>
+>     collectHyps ::  Context -> [Ex (Var ())] -> [Type KConstraint] -> [Type KConstraint] ->
+>                         ([Ex (Var ())], [Type KConstraint], [Type KConstraint])
+>     collectHyps B0 vs hs ps = (vs, hs, ps)
+>     collectHyps (g :< Constraint Given h) vs hs ps = collectHyps g vs (h:hs) ps
+>     collectHyps (g :< A (a := Some d)) vs hs ps =
+>         collectHyps g vs (map (replaceTy a d) hs) (map (replaceTy a d) ps)
+>     collectHyps (g :< A (a := _)) vs hs ps | a <? (hs, ps) =
+>         collectHyps g (Ex a:vs) hs ps
+>     collectHyps (g :< _) vs hs ps = collectHyps g vs hs ps
+
+>     (g, a, b, c) <:< e = (g :< e, a, b, c)
+
+> solveConstraints :: Contextual ()
+> solveConstraints = do
+>     (hs, qs) <- trySolveConstraints
+>     case qs of
+>         []  -> return ()
+>         _   -> traceContext "halp" >> errCannotDeduce hs qs
+
+> solveOrSuspend :: Contextual ()
+> solveOrSuspend = want . snd =<< trySolveConstraints
+>   where
+>     want :: [Type KConstraint] -> Contextual ()
+>     want [] = return ()
+>     want (p:ps)
+>         | nonsense p  = errImpossible p
+>         | otherwise   = modifyContext (:< Constraint Wanted p)
+>                                 >> want ps
+>
+>     nonsense :: Type KConstraint -> Bool
+>     nonsense t = maybe False not $ 
+>                  trivialPred . normalisePred =<< constraintToPred t
+
+
+> simplifyConstraints :: [Ex (Var ())] -> [Type KConstraint] ->
+>                            [Type KConstraint] -> Contextual [Type KConstraint]
+> simplifyConstraints vs hs ps = do
+>     hs' <- mapM expandTySyns hs
+>     ps' <- mapM expandTySyns ps
+>     simplifyClassConstraints hs' $ filter (not . checkPred hs') (nub ps')
+>   where
+>     -- Compute the transitive dependency closure of the variables that occur in p.
+>     -- We have to keep iterating until we reach a fixed point. This
+>     -- will produce the minimum set of variables and hypotheses on
+>     -- which the solution of p can depend.
+>     iterDeps :: ([Ex (Var ())], [Type KConstraint]) ->
+>                     ([Ex (Var ())], [Type KConstraint]) ->
+>                         ([Ex (Var ())], [Type KConstraint]) ->
+>                             ([Ex (Var ())], [Type KConstraint])
+>     iterDeps old             ([], [])         _                = old
+>     iterDeps (oldVs, oldHs)  (newVs, newHs)  (poolVs, poolHs)  =
+>         iterDeps (oldVs ++ newVs, oldHs ++ newHs) (newVs', newHs') (poolVs', poolHs')
+>       where
+>         (newVs', poolVs') = partition (\ (Ex v) -> v <? newHs) poolVs
+>         (newHs', poolHs') = partition (newVs <<?) poolHs
+>
+>     checkPred :: [Type KConstraint] -> Type KConstraint -> Bool
+>     checkPred chs p = p' `elem` phs' || case constraintToPred p' of
+>                      Just p''  -> P.check . toFormula xs'' phs'' . normalisePred $ p''
+>                      Nothing   -> False
+>       where
+>         (pvs, pool)  = partition (\ (Ex v) -> v <? p) vs
+>         (xs, phs)    = iterDeps ([], []) (pvs, []) (pool, chs)
+>         (xs', phs', p')   = elimEquations xs phs p 
+>         phs'' = map normalisePred . catMaybes . map constraintToPred $ phs'
+>         xs'' = catMaybes $ map (\ (Ex v) -> fixNum v) xs'
+
+>     elimEquations :: [Ex (Var ())] -> [Type KConstraint] -> Type KConstraint ->
+>                          ([Ex (Var ())], [Type KConstraint], Type KConstraint)
+>     elimEquations xs ys q = help [] ys q
+>       where
+>         help :: [Type KConstraint] -> [Type KConstraint] -> Type KConstraint ->
+>                     ([Ex (Var ())], [Type KConstraint], Type KConstraint)
+>         help ohs []      p = (xs, ohs, p)
+>         help ohs (h@(TyComp EL `TyApp` m `TyApp` n):rs) p = 
+>             case solveForAny (normaliseNum (n - m)) of
+>                 Nothing      -> help (h:ohs) rs p
+>                 Just (a, t)  -> help [] (map (replaceTy a t') (rs ++ ohs)) (replaceTy a t' p)
+>                     where t' = reifyNum t
+>         help ohs (h:rs) p = help (h:ohs) rs p
+
+
+> toFormula :: [Var () KNum] -> [NormalPredicate] -> NormalPredicate -> P.Formula
+> toFormula xs ys px = 
+
+<  trace (unlines ["toFormula", "[" ++ intercalate "," (map fogSysVar vs) ++ "]","[" ++ intercalate "," (map (renderMe . fogSysPred . reifyPred) hs) ++ "]","(" ++ renderMe (fogSysPred $ reifyPred p) ++ ")"]) $
+
+>   case trivialPred px of
+>     Just True   -> TRUE
+>     Just False  -> FALSE
+>     Nothing -- | null ys && isSimple p  -> FALSE
+>             | px `elem` ys            -> TRUE
+>     Nothing     -> let r = convert xs []
+>                    in {- trace ("result: " ++ show r) -} r
+>                   
+>   where
+>     convert :: [Var () KNum] -> [(Var () KNum, P.Term)] -> P.Formula
+>     convert []      axs = gogo axs ys Map.empty $ \ hs' mts' ->
+>                              predToFormula axs px mts' $ \ p' _ ->
+>                                  hs' :=>: p'
+>     convert (v:vs)  axs = P.Forall (\ t -> convert vs ((v, t) : axs))
+                
+>     gogo :: [(Var () KNum, P.Term)] -> [NormalPredicate] -> Map Monomial P.Term ->
+>                 (P.Formula -> Map Monomial P.Term -> P.Formula) -> P.Formula
+>     gogo _   []      mts f = f TRUE mts
+>     gogo axs (h:hs)  mts f = predToFormula axs h mts $ \ h' mts' ->
+>                                  gogo axs hs mts' (\ x -> f (h' :/\: x))
+
+>     predToFormula :: [(Var () KNum, P.Term)] -> NormalPredicate ->
+>                          Map Monomial P.Term ->
+>                          (P.Formula -> Map Monomial P.Term -> P.Formula) -> P.Formula
+>     predToFormula axs (P c m n) mts f  = linearise axs m mts $ \ m' mts' ->
+>                                                linearise axs n mts' $ \ n' mts'' ->
+>                                                  f (compToFormula c m' n') mts''
+>     predToFormula axs (p :=> q) mts f  = predToFormula axs p mts $ 
+>         \ p' mts' -> predToFormula axs q mts' $ \ q' mts'' -> f (p' :=>: q') mts''
+
+>     linearise ::  [(Var () KNum, P.Term)] -> NormalNum ->
+>                     Map Monomial P.Term ->
+>                     (P.Term -> Map Monomial P.Term -> P.Formula) -> P.Formula
+>     linearise axs zs ms f = help 0 (Map.toList (elimNN zs)) ms
+>       where
+>         help :: P.Term -> [(Monomial, Integer)] ->
+>                     Map Monomial P.Term -> P.Formula
+>         help t []            mts = f t mts
+>         help t ((fs, k):ks)  mts = case getLinearMono fs of
+>             Just (Left ())           -> help (t + fromInteger k) ks mts
+>             Just (Right (VarFac a))  -> help (t + k .* fromJust (lookup a axs)) ks mts
+>             Just (Right (UnFac o `AppFac` m)) | Just lo <- linUnOp o ->
+>                 linearise axs m mts $ \ m' mts' ->
+>                     P.Exists $ \ y ->
+>                         lo m' y :/\: help (t + k .* y) ks mts'
+>             Just (Right (BinFac o `AppFac` m `AppFac` n)) | Just lo <- linBinOp o ->
+>                  linearise axs m mts $ \ m' mts' ->
+>                      linearise axs n mts' $ \ n' mts'' ->
+>                          P.Exists $ \ y ->
+>                              lo m' n' y :/\: help (t + k .* y) ks mts''        
+>             _ -> case Map.lookup fs mts of
+>                 Just n   -> help (t + k .* n) ks mts    
+>                 Nothing  -> P.Forall (\ y -> help (t + k .* y) ks (Map.insert fs y mts))
+
+>     linUnOp :: UnOp -> Maybe (P.Term -> P.Term -> P.Formula)
+>     linUnOp Abs = Just $ \ m y -> ((m :=: y) :/\: (m :>=: 0))
+>                                       :\/: ((m :=: -y) :/\: (m :<: 0))
+>     linUnOp Signum = Just $ \ m y -> ((y :=: 1) :/\: (m :>: 0))
+>                                       :\/: ((y :=: -1) :/\: (m :<: 0))
+>                                       :\/: ((y :=: 0) :/\: (m :=: 0))
+
+>     linBinOp :: BinOp -> Maybe (P.Term -> P.Term -> P.Term -> P.Formula)
+>     linBinOp Max = Just $ \ m n y -> ((m :=: y) :/\: (m :>=: n))
+>                                       :\/: ((n :=: y) :/\: (n :>=: m))
+>     linBinOp Min = Just $ \ m n y -> ((m :=: y) :/\: (m :<=: n))
+>                                       :\/: ((n :=: y) :/\: (n :<=: m))
+>     linBinOp _ = Nothing
+
+>     compToFormula :: Comparator -> P.Term -> P.Term -> P.Formula
+>     compToFormula EL  = (:=:)
+>     compToFormula LE  = (:<=:)
+>     compToFormula LS  = (:<:)
+>     compToFormula GE  = (:>=:)
+>     compToFormula GR  = (:>:)
+
+
+
+> simplifyClassConstraints :: [Type KConstraint] -> [Type KConstraint] ->
+>                                 Contextual [Type KConstraint]
+> simplifyClassConstraints _  []     = return []
+> simplifyClassConstraints hs (q:qs) = case splitConstraint q of
+>     Nothing      -> (q :) <$> simplifyClassConstraints hs qs
+>     Just (c, _) -> do
+>         is <- lookupInstances c
+>         let hs' = hs ++ is
+>         (simp, hard) <- if q `elem` hs' then return ([], [])
+>                                         else simplify (hs ++ is) q
+>         (simp ++) <$> simplifyClassConstraints (simp ++ hs) (hard ++ qs)
+>   where
+>     splitConstraint :: Type k -> Maybe (ClassName, [Ex (Ty ())])
+>     splitConstraint (TyCon c _)    = Just (c, [])
+>     splitConstraint (f `TyApp` s)  = do  (c, as) <- splitConstraint f
+>                                          Just (c, as ++ [Ex s])
+>                                       
+>     splitConstraint _              = Nothing
+>
+>     simplify :: [Type KConstraint] -> Type KConstraint ->
+>                     Contextual ([Type KConstraint], [Type KConstraint])
+>     simplify []     p = return ([p], [])
+>     simplify (h:xs) p = do
+>         ms <- matcher h p []
+>         case ms of
+>             Just (cs, _)  -> return ([], cs)
+>             Nothing       -> simplify xs p
+>
+>     matcher :: Type k -> Type k -> [Ex (Var ())] -> 
+>                    Contextual (Maybe ([Type KConstraint], Subst))
+>     matcher (Qual g h) p vs = (\ mp -> (\ (cs, ss) -> (applySubst ss g:cs, ss)) <$> mp) <$> matcher h p vs
+>     matcher (TyVar a) p vs | a `hetElem` vs = return (Just ([], [VT a p]))
+>     matcher (Bind All x k t) p vs = do
+>         v   <- freshVar SysVar x k
+>         ms  <- matcher (unbindTy v t) p (Ex v : vs)
+>         return $ (\ (cs, ss) -> (cs, filter (vtVarIs v) ss)) <$> ms
+>     matcher (TyApp f s) (TyApp f' s') vs = hetEq (getTyKind f) (getTyKind f') (do
+>         ms <- matcher f f' vs
+>         case ms of
+>             Nothing        -> return Nothing
+>             Just (cs, ss)  -> do
+>                 ms' <- matcher (applySubst ss s) s' vs
+>                 case ms' of
+>                     Nothing -> return Nothing
+>                     Just (cs', ss') -> return $ Just (cs ++ cs', ss ++ ss')
+>       ) (return Nothing)
+>     matcher s t _  | s == t     = return (Just ([], []))
+>                    | otherwise  = return Nothing
+
+> type Subst = [VarType]
+
+> data VarType where
+>   VT :: Var () k -> Type k -> VarType
+
+> vtVarIs :: Var () k -> VarType -> Bool
+> vtVarIs a (VT v _) = a =?= v
+
+> lookupSubst :: Subst -> Var () k -> Maybe (Type k)
+> lookupSubst [] _ = Nothing
+> lookupSubst (VT v t : s) a = hetEq a v (Just t) (lookupSubst s a)
+
+> applySubst :: Subst -> Type k -> Type k
+> applySubst s = substTy f
+>   where
+>     f :: Var () l -> Type l
+>     f v = maybe (TyVar v) id (lookupSubst s v)
diff --git a/src/Language/Inch/Syntax.lhs b/src/Language/Inch/Syntax.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Syntax.lhs
@@ -0,0 +1,618 @@
+> {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable,
+>              GADTs, TypeOperators, FlexibleInstances,
+>              StandaloneDeriving, TypeFamilies, RankNTypes,
+>              ImpredicativeTypes, FlexibleContexts,
+>              MultiParamTypeClasses, EmptyDataDecls,
+>              UndecidableInstances #-}
+
+> module Language.Inch.Syntax where
+
+> import Control.Applicative
+> import Data.Traversable
+> import Data.Monoid hiding (All)
+> import Unsafe.Coerce
+
+> import Language.Inch.Kit
+> import Language.Inch.Kind
+> import Language.Inch.Type
+
+
+> listTypeName, listNilName, listConsName :: String
+> listTypeName  = "[]"
+> listNilName   = "[]"
+> listConsName  = "(:)"
+
+> unitTypeName, unitConsName :: String
+> unitTypeName = "()"
+> unitConsName = "()"
+
+> tupleTypeName, tupleConsName :: String
+> tupleTypeName = "(,)"
+> tupleConsName = "(,)"
+
+
+> data OK
+> data RAW
+
+> type family AKind s k
+> type instance AKind OK k   = Kind k
+> type instance AKind RAW k  = SKind
+
+> type family ATy s a k
+> type instance ATy OK   a k = Ty a k
+> type instance ATy RAW  a k = SType
+
+> type family ATySyn s a k 
+> type instance ATySyn OK a k = TySyn a k
+> type instance ATySyn RAW a k = STypeSyn
+
+> type family AVar s a k
+> type instance AVar OK   a k = Var a k
+> type instance AVar RAW  a k = String
+
+> type AType s k = ATy s () k
+> type ATypeSyn s k = ATySyn s () k
+
+
+> type Con s        = TmConName ::: ATy s () KSet
+
+> type Term             = Tm OK
+> type Constructor      = Con OK
+> type Alternative      = Alt OK
+> type CaseAlternative  = CaseAlt OK
+> type PatternList      = PatList OK
+> type Pattern          = Pat OK
+> type Declaration      = Decl OK
+> type Guard            = Grd OK
+> type GuardTerms       = GrdTms OK
+
+> type STerm             = Tm RAW
+> type SConstructor      = Con RAW
+> type SAlternative      = Alt RAW
+> type SCaseAlternative  = CaseAlt RAW
+> type SPatternList      = PatList RAW
+> type SPattern          = Pat RAW
+> type SDeclaration      = Decl RAW
+> type SGuard            = Grd RAW
+> type SGuardTerms       = GrdTms RAW
+
+
+
+> class TravTypes t where
+
+<     travTypes :: Applicative f =>
+<          (forall a k . Ty a k -> f (Ty a k)) -> t OK -> f (t OK)
+
+>     fogTypes :: (forall k. Var () k -> String) -> t OK -> t RAW
+>     renameTypes :: (forall k . Var () k -> Var () k) -> t OK -> t OK
+
+
+> class TravTypes1 t where
+>     travTypes1 :: Applicative f =>
+>          (forall a k . Ty a k -> f (Ty a k)) -> t OK b -> f (t OK b)
+>     fogTypes1 :: (forall k. Var a k -> String) -> t OK a -> t RAW a
+>     renameTypes1 :: (forall k . Var a k -> Var c k) -> t OK a -> t OK c
+>     rawCoerce :: t RAW a -> t RAW c
+>     rawCoerce = unsafeCoerce
+
+> class TravTypes2 t where
+>     fogTypes2 :: (forall k . Var a k -> String) -> t OK a b ->
+>                     (t RAW a b, (forall k . Var b k -> String))
+>     renameTypes2 ::
+>         (forall k . Var a k -> Var c k) -> VarSuffix a b x -> t OK a b ->
+>             (forall d . VarSuffix c d x -> t OK c d -> p) ->
+>                 p
+>
+>     rawCoerce2 :: t RAW a b -> t RAW c d
+>     rawCoerce2 = unsafeCoerce
+>
+
+>     ext :: t OK a b -> (forall x . VarSuffix a b x -> p) -> p
+
+> class FV2 t where
+>     fvFoldMap2 :: Monoid m => (forall k . Var a k -> m) -> t OK a b -> (m, (forall k. Var b k -> m))
+
+> mapTypes :: TravTypes1 t =>
+>                 (forall a k. Ty a k -> Ty a k) -> t OK b -> t OK b
+> mapTypes g = unId . travTypes1 (Id . g)
+
+> replaceTypes :: TravTypes1 t => Var () k -> Type k -> t OK a -> t OK a
+> replaceTypes a t = mapTypes (replaceTy (wkClosedVar a) (wkClosedTy t))
+
+> bindTm :: TravTypes1 t => Var a k -> t OK a -> t OK (a, k)
+> bindTm v = renameTypes1 (bindVar v)
+
+> unbindTm :: TravTypes1 t => Var c k -> t OK (c, k) -> t OK c
+> unbindTm v = renameTypes1 (unbindVar v)
+
+> fog :: TravTypes t => t OK -> t RAW
+> fog = fogTypes fogVar
+
+> fog1 :: TravTypes1 t => t OK () -> t RAW ()
+> fog1 = fogTypes1 fogVar
+
+> fogSys :: TravTypes1 t => t OK () -> t RAW ()
+> fogSys = fogTypes1 fogSysVar
+
+> fogSys2 :: TravTypes2 t => t OK () a -> t RAW () a
+> fogSys2 = fst . fogTypes2 fogSysVar
+
+> bindUn :: TravTypes2 t =>
+>             Var a k -> VarSuffix a b x -> t OK a b ->
+>              (forall d . VarSuffix (a, k) d x -> t OK (a, k) d -> p) -> p
+> bindUn v vs t q = renameTypes2 (bindVar v) vs t q
+
+
+
+> data (:*:) f g a b where
+>     (:*:) :: f a b -> g a b -> (:*:) f g a b 
+
+> deriving instance (Show (f s a), Show (g s a)) => Show ((:*:) f g s a)
+
+> instance (Eq (f RAW b), Eq (g RAW b)) => Eq ((f :*: g) RAW b) where
+>     x :*: y == x' :*: y'  =  x == x' && y == y'
+
+> instance (TravTypes1 f, TravTypes1 g) => TravTypes1 (f :*: g) where
+>     travTypes1    g (x :*: y) = (:*:) <$> travTypes1 g x <*> travTypes1 g y
+>     fogTypes1     g (x :*: y) = fogTypes1 g x     :*: fogTypes1 g y
+>     renameTypes1  g (x :*: y) = renameTypes1 g x  :*: renameTypes1 g y
+
+> instance (FV (f s a) a, FV (g s a) a) => FV ((f :*: g) s a) a where
+>     fvFoldMap f (x :*: y) = fvFoldMap f x <.> fvFoldMap f y
+
+> {-
+> data (:+:) f g a b where
+>     InL  :: f a b -> (f :+: g) a b 
+>     InR  :: g a b -> (f :+: g) a b 
+
+> instance (Eq (f RAW b), Eq (g RAW b)) => Eq ((f :+: g) RAW b) where
+>     InL x  == InL y  =  x == y
+>     InR x  == InR y  =  x == y
+>     _      == _      =  False
+
+> instance (TravTypes f, TravTypes g) => TravTypes (f :+: g) where
+>     travTypes    g (InL x) = InL <$> travTypes g x
+>     travTypes    g (InR x) = InR <$> travTypes g x
+>     fogTypes     g (InL x) = InL (fogTypes g x)
+>     fogTypes     g (InR x) = InR (fogTypes g x)
+>     renameTypes  g (InL x) = InL (renameTypes g x)
+>     renameTypes  g (InR x) = InR (renameTypes g x)
+> -}
+
+
+
+
+
+
+
+
+
+
+> data Tm s a where
+>     TmVar    :: TmName                    -> Tm s a
+>     TmCon    :: TmConName                 -> Tm s a
+>     TmInt    :: Integer                   -> Tm s a
+>     CharLit  :: Char                      -> Tm s a
+>     StrLit   :: String                    -> Tm s a
+>     TmApp    :: Tm s a -> Tm s a          -> Tm s a
+>     TmBrace  :: ATy s a KNum              -> Tm s a
+>     Lam      :: TmName -> Tm s a          -> Tm s a
+>     NumLam   :: String -> Tm s (a, KNum)  -> Tm s a
+>     Let      :: [Decl s a] -> Tm s a      -> Tm s a
+>     Case     :: Tm s a -> [CaseAlt s a]   -> Tm s a
+>     (:?)     :: Tm s a -> ATy s a KSet    -> Tm s a
+
+> deriving instance Show (Tm RAW a)
+> deriving instance Show (Tm OK a)
+> deriving instance Eq (Tm RAW a)
+
+> instance TravTypes1 Tm where
+
+>     travTypes1 g (TmApp f s)  = TmApp <$> travTypes1 g f <*> travTypes1 g s
+>     travTypes1 g (TmBrace n)  = TmBrace <$> g n
+>     travTypes1 g (Lam x b)    = Lam x <$> travTypes1 g b
+>     travTypes1 g (NumLam a b) = NumLam a <$> travTypes1 g b 
+>     travTypes1 g (Let ds t)   = Let <$> traverse (travTypes1 g) ds
+>                                    <*> travTypes1 g t
+>     travTypes1 g (t :? ty)    = (:?) <$> travTypes1 g t <*> g ty
+>     travTypes1 _ t            = pure t
+
+>     fogTypes1 _ (TmVar x)     = TmVar x
+>     fogTypes1 _ (TmCon c)     = TmCon c
+>     fogTypes1 _ (TmInt k)     = TmInt k
+>     fogTypes1 _ (CharLit c)   = CharLit c
+>     fogTypes1 _ (StrLit s)    = StrLit s
+>     fogTypes1 g (TmApp f s)   = TmApp (fogTypes1 g f) (fogTypes1 g s)
+>     fogTypes1 g (TmBrace n)   = TmBrace (fogTy' g [] n)
+>     fogTypes1 g (Lam x b)     = Lam x (fogTypes1 g b)
+>     fogTypes1 g (NumLam x b)  = NumLam x (fogTypes1 (wkF g x) b)
+>     fogTypes1 g (Let ds t)    = Let (map (fogTypes1 g) ds)
+>                                    (fogTypes1 g t)
+>     fogTypes1 g (Case t as)   = Case (fogTypes1 g t) (map (fogTypes1 g) as)
+>     fogTypes1 g (t :? ty)     = fogTypes1 g t :? fogTy' g [] ty
+
+>     renameTypes1 _ (TmVar x)     = TmVar x
+>     renameTypes1 _ (TmCon c)     = TmCon c
+>     renameTypes1 _ (TmInt k)     = TmInt k
+>     renameTypes1 _ (CharLit c)   = CharLit c
+>     renameTypes1 _ (StrLit s)    = StrLit s
+>     renameTypes1 g (TmApp f s)   = TmApp (renameTypes1 g f) (renameTypes1 g s)
+>     renameTypes1 g (TmBrace n)   = TmBrace (renameTy g n)
+>     renameTypes1 g (Lam x b)     = Lam x (renameTypes1 g b)
+>     renameTypes1 g (NumLam x b)  = NumLam x (renameTypes1 (wkRenaming g) b)
+>     renameTypes1 g (Let ds t)    = Let (map (renameTypes1 g) ds)
+>                                    (renameTypes1 g t)
+>     renameTypes1 g (Case t as)   = Case (renameTypes1 g t) (map (renameTypes1 g) as)
+>     renameTypes1 g (t :? ty)     = renameTypes1 g t :? renameTy g ty
+
+> instance a ~ b => FV (Tm OK a) b where
+>     fvFoldMap g (TmApp f s)   = fvFoldMap g f <.> fvFoldMap g s
+>     fvFoldMap g (TmBrace n)   = fvFoldMap g n
+>     fvFoldMap g (Lam _ b)     = fvFoldMap g b
+>     fvFoldMap g (NumLam _ b)  = fvFoldMap (wkF g mempty) b 
+>     fvFoldMap g (Let ds t)    = fvFoldMap g ds <.> fvFoldMap g t
+>     fvFoldMap g (t :? ty)     = fvFoldMap g t <.> fvFoldMap g ty
+>     fvFoldMap _ _             = mempty
+
+> tmUnOp :: UnOp -> Tm s a -> Tm s a
+> tmUnOp o m = TmVar (unOpString o) `TmApp` m
+
+> tmBinOp :: BinOp -> Tm s a -> Tm s a -> Tm s a
+> tmBinOp o m n = TmVar (binOpPrefixString o) `TmApp` m `TmApp` n
+
+> tmComp :: Comparator -> Tm s a -> Tm s a -> Tm s a
+> tmComp c m n = TmVar ("(" ++ compStringTm c ++ ")") `TmApp` m `TmApp` n
+
+
+
+> data Decl s a where
+>     FunDecl   :: TmName -> [Alt s a] -> Decl s a
+>     SigDecl   :: TmName -> ATy s a KSet -> Decl s a
+
+> deriving instance Show (Decl RAW a)
+> deriving instance Show (Decl OK a)
+> deriving instance Eq (Decl RAW a)
+
+> instance TravTypes1 Decl where
+>     travTypes1 g (FunDecl x ps) =
+>         FunDecl x <$> traverse (travTypes1 g) ps
+>     travTypes1 g (SigDecl x ty) = SigDecl x <$> g ty
+
+>     fogTypes1 g (FunDecl x ps)  = FunDecl x (map (fogTypes1 g) ps)
+>     fogTypes1 g (SigDecl x ty)  = SigDecl x (fogTy' g [] ty)
+
+>     renameTypes1 g (FunDecl x ps)  = FunDecl x (map (renameTypes1 g) ps)
+>     renameTypes1 g (SigDecl x ty)  = SigDecl x (renameTy g ty) 
+
+> instance a ~ b => FV (Decl OK a) b where
+>     fvFoldMap f (FunDecl _ as)       = fvFoldMap f as
+>     fvFoldMap f (SigDecl _ t)        = fvFoldMap f t
+
+> declName :: Decl s a -> String
+> declName (FunDecl x _)       = x
+> declName (SigDecl x _)       = x
+
+
+> data Grd s a where
+>     ExpGuard  :: [Tm s a] -> Grd s a
+>     NumGuard  :: [Pred (ATy s a KNum)] -> Grd s a
+
+> deriving instance Show (Grd RAW a)
+> deriving instance Show (Grd OK a)
+> deriving instance Eq (Grd RAW a)
+
+> instance TravTypes1 Grd where
+
+>     travTypes1 g (ExpGuard ts)  = ExpGuard <$> traverse (travTypes1 g) ts
+>     travTypes1 g (NumGuard ps)  = NumGuard <$> traverse (traverse g) ps
+
+>     fogTypes1 g (ExpGuard ts)  = ExpGuard (map (fogTypes1 g) ts)
+>     fogTypes1 g (NumGuard ps)  = NumGuard (map (fmap (fogTy' g [])) ps)
+
+>     renameTypes1 g (ExpGuard ts)  = ExpGuard (map (renameTypes1 g) ts)
+>     renameTypes1 g (NumGuard ps)  = NumGuard (map (fmap (renameTy g)) ps)
+
+> instance a ~ b => FV (Grd OK a) b where
+>     fvFoldMap f (ExpGuard ts)  = fvFoldMap f ts
+>     fvFoldMap f (NumGuard ps)  = fvFoldMap f ps
+
+
+
+
+
+
+
+> data GrdTms s b where
+>     Guarded    :: [(Grd :*: Tm) s b] -> [Decl s b] -> GrdTms s b
+>     Unguarded  :: Tm s b -> [Decl s b] -> GrdTms s b
+
+> deriving instance Show (GrdTms RAW a)
+> deriving instance Show (GrdTms OK b)
+
+> instance Eq (GrdTms RAW b) where
+>     Guarded xs ds   == Guarded xs' ds'   = xs == xs' && ds == ds'
+>     Unguarded t ds  == Unguarded t' ds'  = t == t' && ds == ds'
+>     _               == _                 = False
+
+> instance TravTypes1 GrdTms where
+>     travTypes1 g (Guarded xs ds)     = Guarded <$> traverse (travTypes1 g) xs
+>                                           <*> traverse (travTypes1 g) ds
+>     travTypes1 g (Unguarded t ds)    = Unguarded <$> travTypes1 g t
+>                                           <*> traverse (travTypes1 g) ds
+>     fogTypes1 g (Guarded xs ds)      = Guarded (map (fogTypes1 g) xs)
+>                                           (map (fogTypes1 g) ds)
+>     fogTypes1 g (Unguarded t ds)     = Unguarded (fogTypes1 g t)
+>                                           (map (fogTypes1 g) ds)
+>     renameTypes1 g (Guarded xs ds)   = Guarded (map (renameTypes1 g) xs)
+>                                           (map (renameTypes1 g) ds)
+>     renameTypes1 g (Unguarded t ds)  = Unguarded (renameTypes1 g t)
+>                                           (map (renameTypes1 g) ds)
+
+> instance FV (GrdTms OK b) b where
+>     fvFoldMap f (Guarded xs ds)   = fvFoldMap f xs <.> fvFoldMap f ds
+>     fvFoldMap f (Unguarded t ds)  = fvFoldMap f t <.> fvFoldMap f ds
+
+> data Alt s a where
+>     Alt :: PatList s a b -> GrdTms s b -> Alt s a
+
+> deriving instance Show (Alt RAW a)
+> deriving instance Show (Alt OK a)
+
+> instance Eq (Alt RAW a) where
+>    (Alt xs gt) == (Alt xs' gt') =
+>        hetEq xs xs' (gt == gt') False
+
+> instance TravTypes1 Alt where
+>     travTypes1 g (Alt xs gt) = Alt xs <$> travTypes1 g gt
+
+>     fogTypes1 g (Alt xs gt) = Alt xs' (fogTypes1 g' gt)
+>       where (xs', g') = fogTypes2 g xs
+
+>     renameTypes1 g (Alt xs gt) = ext xs $ \ ex -> 
+>       renameTypes2 g ex xs $ \ ex' xs' ->
+>         Alt xs' (renameTypes1 (extRenaming ex ex' g) gt)
+
+> instance a ~ b => FV (Alt OK a) b where
+>     fvFoldMap f (Alt xs gt) = let (m, f') = fvFoldMap2 f xs
+>                               in m <.> fvFoldMap f' gt
+
+> isVarAlt :: Alt s a -> Bool
+> isVarAlt (Alt P0 (Unguarded _ _))  = True
+> isVarAlt _                         = False
+
+
+
+> data CaseAlt s a where
+>     CaseAlt :: Pat s a b -> GrdTms s b -> CaseAlt s a
+
+> deriving instance Show (CaseAlt RAW a)
+> deriving instance Show (CaseAlt OK a)
+
+> instance Eq (CaseAlt RAW a) where
+>    (CaseAlt x gt) == (CaseAlt x' gt') =
+>        hetEq x x' (gt == gt') False
+
+> instance TravTypes1 CaseAlt where
+
+>     travTypes1 g (CaseAlt x gt) =  CaseAlt x <$> travTypes1 g gt
+
+>     fogTypes1 g (CaseAlt x gt) = CaseAlt x' (fogTypes1 g' gt)
+>         where (x', g') = fogTypes2 g x
+
+>     renameTypes1 g (CaseAlt x gt) = ext x $ \ ex -> 
+>       renameTypes2 g ex x $ \ ex' x' ->
+>         CaseAlt x' (renameTypes1 (extRenaming ex ex' g) gt)
+
+> instance a ~ b => FV (CaseAlt OK a) b where
+>     fvFoldMap f (CaseAlt x gt) = let (m, f') = fvFoldMap2 f x
+>                                  in m <.> fvFoldMap f' gt
+
+
+
+
+
+
+
+> data RTC f s a b where
+>     P0    :: RTC f s a a
+>     (:!)  :: f s a b -> RTC f s b c -> RTC f s a c
+
+> type PatList = RTC Pat
+
+> deriving instance Show (RTC Pat s a b)
+
+> infixr 5 :!
+
+> instance HetEq (RTC Pat RAW a) where
+>     hetEq P0         P0         t _ = t
+>     hetEq (x :! xs)  (y :! ys)  t f = hetEq x y (hetEq xs ys t f) f
+>     hetEq _          _          _ f = f
+
+> instance TravTypes2 f => TravTypes2 (RTC f) where
+>     fogTypes2 g P0         = (P0, g)
+>     fogTypes2 g (p :! ps)  = (p' :! ps', g'')
+>       where  (p', g')    = fogTypes2 g p
+>              (ps', g'')  = fogTypes2 g' ps
+
+>     renameTypes2 _ VS0 P0 q         = q VS0 P0
+>     renameTypes2 g _ (p :! ps) q  = ext p $ \ eab ->
+>       ext ps $ \ ebc ->
+>         renameTypes2 g eab p $ \ eab' p' ->
+>             renameTypes2 (extRenaming eab eab' g) ebc ps $ \ ebc' ps' ->
+>                 extComp eab' ebc' $ \ eac' ->
+>                     q (unsafeCoerce eac') (p' :! ps')
+>     renameTypes2 _ (_ :<< _) P0 _ = error "renameTypes2: impossible"
+
+>     ext P0         q = q VS0
+>     ext (p :! ps)  q = ext p $ \ ex ->
+>                               ext ps $ \ ex' ->
+>                                   extComp ex ex' q
+
+
+> instance FV2 f => FV2 (RTC f) where
+>     fvFoldMap2 f P0 = (mempty, f)
+>     fvFoldMap2 f (p :! ps) = let (m, f') = fvFoldMap2 f p
+>                                  (m', f'') = fvFoldMap2 f' ps
+>                              in (m <.> m', f'')
+
+> rtcLength :: RTC f s a b -> Int
+> rtcLength P0 = 0
+> rtcLength (_ :! ps) = 1 + rtcLength ps
+
+> patLength :: PatList s a b -> Int
+> patLength = rtcLength
+
+> data Pat s a b where
+>     PatVar     :: TmName                      ->  Pat s a a
+>     PatCon     :: TmConName -> PatList s a b  ->  Pat s a b
+>     PatIgnore  ::                                 Pat s a a
+>     PatBrace   :: String -> Integer           ->  Pat s a (a, KNum)
+>     PatBraceK  :: Integer                     ->  Pat s a a
+>     PatIntLit  :: Integer                     ->  Pat s a a
+>     PatCharLit :: Char                        ->  Pat s a a
+>     PatStrLit  :: String                      ->  Pat s a a
+>     PatNPlusK  :: String -> Integer           ->  Pat s a a
+
+> deriving instance Show (Pat s a b)
+
+> instance HetEq (Pat RAW a) where
+>     hetEq (PatVar x)       (PatVar y)         t _  | x == y  = t
+>     hetEq (PatCon c xs)    (PatCon d ys)      t f  | c == d  = hetEq xs ys t f
+>     hetEq PatIgnore        PatIgnore          t _  = t
+>     hetEq (PatBrace _ j)   (PatBrace _ k)     t _  | j == k  = t
+>     hetEq (PatBraceK j)    (PatBraceK k)      t _  | j == k  = t
+>     hetEq (PatIntLit i)    (PatIntLit j)      t _  | i == j  = t
+>     hetEq (PatCharLit c)   (PatCharLit c')    t _  | c == c' = t
+>     hetEq (PatStrLit s)    (PatStrLit s')     t _  | s == s' = t 
+>     hetEq (PatNPlusK n k)  (PatNPlusK n' k')  t _  | n == n' && k == k' = t
+>     hetEq _                _                  _ f  = f
+
+> instance TravTypes2 Pat where
+>     fogTypes2 g (PatVar x)      = (PatVar x, g)
+>     fogTypes2 g (PatCon x ps)   = (PatCon x ps', g')
+>       where (ps', g') = fogTypes2 g ps
+>     fogTypes2 g PatIgnore       = (PatIgnore, g)
+>     fogTypes2 g (PatBrace x k)  = (PatBrace x k, wkF g x)
+>     fogTypes2 g (PatBraceK k)   = (PatBraceK k, g)
+>     fogTypes2 g (PatIntLit i)   = (PatIntLit i, g)
+>     fogTypes2 g (PatCharLit c)  = (PatCharLit c, g)
+>     fogTypes2 g (PatStrLit s)   = (PatStrLit s, g)
+>     fogTypes2 g (PatNPlusK n k) = (PatNPlusK n k, g)
+
+>     renameTypes2 _ VS0      (PatVar x)      q = q VS0 (PatVar x)
+>     renameTypes2 g vs       (PatCon x ps)   q = renameTypes2 g vs ps
+>                                                     (\ vs' ps' -> q vs' (PatCon x ps'))
+>     renameTypes2 _ VS0      PatIgnore       q = q VS0 PatIgnore
+>     renameTypes2 g (VS0 :<< v)  (PatBrace x k)  q = q (VS0 :<< g v) (PatBrace x k)
+>     renameTypes2 _ VS0      (PatBraceK k)   q = q VS0 (PatBraceK k)
+>     renameTypes2 _ VS0      (PatIntLit i)   q = q VS0 (PatIntLit i)
+>     renameTypes2 _ VS0      (PatCharLit c)  q = q VS0 (PatCharLit c)
+>     renameTypes2 _ VS0      (PatStrLit s)   q = q VS0 (PatStrLit s)
+>     renameTypes2 _ VS0      (PatNPlusK n k) q = q VS0 (PatNPlusK n k)
+>     renameTypes2 _ _        _               _ = error "renameTypes2: impossible"
+
+>     ext (PatVar _)      q = q VS0
+>     ext (PatCon _ xs)   q = ext xs q
+>     ext PatIgnore       q = q VS0
+>     ext (PatBrace _ _)  q = q (VS0 :<< error "woona")
+>     ext (PatBraceK _)   q = q VS0
+>     ext (PatIntLit _)   q = q VS0
+>     ext (PatCharLit _)  q = q VS0
+>     ext (PatStrLit _)   q = q VS0
+>     ext (PatNPlusK _ _) q = q VS0
+
+> instance FV2 Pat where
+>     fvFoldMap2 f (PatVar _)      = (mempty, f)
+>     fvFoldMap2 f (PatCon _ ps)   = fvFoldMap2 f ps
+>     fvFoldMap2 f PatIgnore       = (mempty, f)
+>     fvFoldMap2 f (PatBrace _ _)  = (mempty, wkF f mempty)
+>     fvFoldMap2 f (PatBraceK _)   = (mempty, f)
+>     fvFoldMap2 f (PatIntLit _)   = (mempty, f)
+>     fvFoldMap2 f (PatCharLit _)  = (mempty, f)
+>     fvFoldMap2 f (PatStrLit _)   = (mempty, f)
+>     fvFoldMap2 f (PatNPlusK _ _) = (mempty, f)
+
+> data VarBinding s a b where
+>     VB  :: AVar s a k -> AKind s k -> VarBinding s a (a, k)
+
+> deriving instance Show (VarBinding RAW a b)
+> deriving instance Show (VarBinding OK a b)
+
+> instance TravTypes2 VarBinding where
+>     fogTypes2 g (VB x k) = (VB (g x) (fogKind k), wkF g (g x))
+>     renameTypes2 g (VS0 :<< v) (VB x k) q = q (VS0 :<< g v) (VB (g x) k)
+>     renameTypes2 _ _ _ _ = error "renameTypes2: impossible" 
+>     ext (VB v _) q = q (VS0 :<< v)
+
+> instance FV2 VarBinding where
+>     fvFoldMap2 f (VB _ _) = (mempty, wkF f mempty)
+
+> instance Eq (VarBinding RAW a b) where
+>     VB x k == VB y l = x == y && k == l
+
+
+> type VarList = RTC VarBinding
+
+> deriving instance Show (RTC VarBinding RAW a b)
+> deriving instance Show (RTC VarBinding OK a b)
+
+> instance Eq (RTC VarBinding RAW a b) where
+>     P0         ==  P0         = True
+>     (x :! xs)  ==  (y :! ys)  = x == rawCoerce2 y && xs == rawCoerce2 ys
+>     _          ==  _          = False
+
+
+
+> data TyK s a b where
+>     TyK :: ATy s a k -> AKind s k -> TyK s a (a, k) 
+> deriving instance Show (TyK RAW a b)
+> deriving instance Show (TyK OK a b)
+
+> instance TravTypes2 TyK where
+>     fogTypes2 g (TyK t k) = (TyK (fogTy' g [] t) (fogKind k), wkF g undefined)
+>     renameTypes2 g (VS0 :<< v) (TyK t k) q = q (VS0 :<< g v) (TyK (renameTy g t) k)
+>     renameTypes2 _ _ _ _ = error "renameTypes2: invariant violated"
+>     ext (TyK _ _) q = q (VS0 :<< error "woonk")
+
+> instance Eq (TyK RAW a b) where
+>     TyK t k == TyK t' k' = t == t' && k == k'
+
+> type TyList = RTC TyK
+
+> deriving instance Show (RTC TyK RAW a b)
+> deriving instance Show (RTC TyK OK a b)
+
+> instance Eq (RTC TyK RAW a b) where
+>     P0         ==  P0         = True
+>     (x :! xs)  ==  (y :! ys)  = x == rawCoerce2 y && xs == rawCoerce2 ys
+>     _          ==  _          = False
+
+
+
+> data VarKind s a where
+>     VK :: AVar s a k -> AKind s k -> VarKind s a
+
+> deriving instance Eq (VarKind RAW ())
+> deriving instance Show (VarKind RAW ())
+> deriving instance Show (VarKind OK ())
+
+> instance FV (VarKind OK ()) () where
+>     fvFoldMap f (VK v _) = f v
+
+> instance TravTypes1 VarKind where
+>     travTypes1 _ vk = pure vk
+>     fogTypes1 g (VK v k) = VK (g v) (fogKind k)
+>     renameTypes1 g (VK v k) = VK (g v) k
+>                               
+> allWrapVK :: [VarKind OK ()] -> Type k -> Type k
+> allWrapVK [] t = t
+> allWrapVK (VK v k : xs) t = Bind All (nameToString (varName v)) k
+>                                      (bindTy v (allWrapVK xs t)) 
+
+
+> applyVK :: (forall k . Kind k -> Type k) -> [VarKind OK ()] -> Kind k' -> Type k'
+> applyVK f xs k' = help xs k'
+>       where
+>         help :: [VarKind OK ()] -> Kind l -> Type l
+>         help [] l = f l
+>         help (VK v k : xks) l = help xks (k :-> l) `TyApp` TyVar v
diff --git a/src/Language/Inch/TyNum.lhs b/src/Language/Inch/TyNum.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/TyNum.lhs
@@ -0,0 +1,329 @@
+> {-# LANGUAGE GADTs, TypeOperators, TypeSynonymInstances, FlexibleInstances,
+>              MultiParamTypeClasses, TypeFamilies, StandaloneDeriving,
+>              PatternGuards #-}
+
+> module Language.Inch.TyNum
+>     (  NormalNum
+>     ,  Monomial
+>     ,  Fac(..)
+>     ,  SolveResult(..)
+>     ,  NormalPredicate
+>     ,  normaliseNum
+>     ,  normalisePred
+>     ,  trivialPred
+>     ,  partitionNum
+>     ,  isZero
+>     ,  reifyNum
+>     ,  reifyPred
+>     ,  mkVar
+>     ,  getConstant
+>     ,  getLinearMono
+>     ,  solveFor
+>     ,  maybeSolveFor
+>     ,  solveForAny
+>     ,  substNum
+>     ,  numVariables
+>     ,  elimNN
+>     )
+>   where
+
+> import Prelude hiding (all, any, foldr)
+> import Control.Applicative
+> import Data.Foldable
+> import Data.List hiding (all, any, foldr)
+> import Data.Map (Map)
+> import qualified Data.Map as Map
+> import Data.Monoid hiding (All)
+
+> import Language.Inch.Kit
+> import Language.Inch.Kind
+> import Language.Inch.Type
+
+> type NVar a           = Var a KNum
+> type NormalNum        = NormNum ()
+> type NormPred a       = Pred (NormNum a)
+> type NormalPredicate  = Pred NormalNum
+
+
+> newtype NormNum a = NN {elimNN :: Map (Mono a) Integer}
+>   deriving (Eq, Ord, Show)
+
+> instance a ~ b => FV (NormNum a) b where
+>     fvFoldMap f = fvFoldMap f . elimNN
+
+> type Mono a    = Map (Fac a KNum) Integer
+> type Monomial  = Mono ()
+
+> monoVar :: NVar a -> Mono a
+> monoVar v = Map.singleton (VarFac v) 1
+
+> singleMono :: Mono a -> NormNum a
+> singleMono x = NN (Map.singleton x 1)
+
+
+> data Fac a k where
+>     VarFac  :: Var a k -> Fac a k
+>     AppFac  :: Fac a (KNum :-> k) -> NormNum a -> Fac a k
+>     AptFac  :: Fac a (k' :-> k) -> Ty a k' -> Fac a k
+>     UnFac   :: UnOp -> Fac a (KNum :-> KNum)
+>     BinFac  :: BinOp -> Fac a (KNum :-> KNum :-> KNum)
+
+> deriving instance Show (Fac a k)
+
+> instance HetEq (Fac a) where
+>     hetEq (VarFac a)    (VarFac b)    yes no = hetEq a b yes no
+>     hetEq (AppFac f m)  (AppFac g n)  yes no | m == n = hetEq f g yes no
+>     hetEq (AptFac f s)  (AptFac g t)  yes no = hetEq f g (hetEq s t yes no) no
+>     hetEq (UnFac o)     (UnFac o')    yes _ | o == o' = yes
+>     hetEq (BinFac o)    (BinFac o')   yes _ | o == o' = yes
+>     hetEq _             _             _   no = no
+
+> instance Eq (Fac a k) where
+>     (==) = (=?=)
+
+> instance HetOrd (Fac a) where
+>     VarFac a    <?= VarFac b    = a <?= b
+>     VarFac _    <?= _           = True
+>     _           <?= VarFac _    = False
+>     AppFac f m  <?= AppFac g n  = m < n || (m == n && f <?= g)
+>     AppFac _ _  <?= _           = True
+>     _           <?= AppFac _ _  = False
+>     AptFac f s  <?= AptFac g t  | f =?= g    = s <?= t
+>                                 | otherwise  = f <?= g
+>     AptFac _ _  <?= _           = True
+>     _           <?= AptFac _ _  = False
+>     UnFac o     <?= UnFac p     = o <= p
+>     UnFac _     <?= _           = True
+>     _           <?= UnFac _     = False
+>     BinFac o    <?= BinFac p    = o <= p
+
+> instance Ord (Fac a k) where
+>     (<=) = (<?=)
+
+> type Factor k = Fac () k
+
+> instance a ~ b => FV (Fac a k) b where
+>     fvFoldMap f (VarFac a)    = f a
+>     fvFoldMap f (AppFac t m)  = fvFoldMap f t <.> fvFoldMap f m
+>     fvFoldMap f (AptFac t s)  = fvFoldMap f t <.> fvFoldMap f s
+>     fvFoldMap _ (UnFac _)     = mempty
+>     fvFoldMap _ (BinFac _)    = mempty
+
+> singleFac :: Fac a KNum -> NormNum a
+> singleFac x = singleMono (Map.singleton x 1)
+
+
+
+> instance Num (NormNum a) where
+>     fromInteger i   | i == 0     = NN Map.empty
+>                     | otherwise  = NN $ Map.singleton Map.empty i
+>     (+)     = nbinOp Plus
+>     (-)     = nbinOp Minus
+>     (*)     = nbinOp Times
+>     abs     = nunOp Abs
+>     signum  = nunOp Signum
+
+
+> dropZeroes :: Ord a => Map a Integer -> Map a Integer
+> dropZeroes = Map.filter (/= 0)
+
+> unionMaps :: Ord a => Map a Integer -> Map a Integer -> Map a Integer
+> unionMaps a b = dropZeroes $ Map.unionWith (+) a b
+
+> (*~) :: Integer -> NormNum a -> NormNum a
+> 0 *~ _      = 0
+> 1 *~ n      = n
+> i *~ NN xs  = NN $ Map.map (i*) xs
+
+> getSingleton :: Map k t -> Maybe (k, t)
+> getSingleton xs = case Map.toList xs of
+>                     [kt]  -> Just kt
+>                     _     -> Nothing
+
+> getConstant :: NormNum a -> Maybe Integer
+> getConstant (NN xs)  | Map.null xs                                   = Just 0
+>                      | Just (ys, k) <- getSingleton xs, Map.null ys  = Just k
+>                      | otherwise                                     = Nothing
+
+> isZero :: NormNum a -> Bool
+> isZero = Map.null . elimNN
+
+
+> mkVar :: Var a KNum -> NormNum a
+> mkVar = singleMono . monoVar
+
+
+> numVariables :: NormNum a -> Int
+> numVariables = length . nub . vars
+
+> substNum :: Var () KNum -> Type KNum -> NormalNum -> NormalNum
+> substNum a t n = normaliseNum (replaceTy a t (reifyNum n))
+
+
+
+> data SolveResult t where
+>     Absent    :: SolveResult t
+>     Solve     :: t -> SolveResult t
+>     Simplify  :: t -> SolveResult t
+>     Stuck     :: SolveResult t
+>   deriving Show
+
+> solveFor :: Var () KNum -> NormalNum -> SolveResult NormalNum
+> solveFor a n =
+>   let (NN ys, NN zs) = partitionNum [a] n 
+>   in case Map.toList ys of
+>     []                                                    -> Absent
+>     [(m, k)]  | isMono && all (k `divides`) zs            -> Solve t
+>               | isMono && any (\ j -> abs k <= abs j) zs  -> Simplify t
+>       where
+>         isMono         = m == monoVar a
+>         t              = NN . dropZeroes $ Map.map q zs
+>         q x            = x `quot` (-k)
+>         x `divides` y  = y `mod` x == 0
+>     _ -> Stuck
+
+> maybeSolveFor :: Var () KNum -> NormalNum -> Maybe NormalNum
+> maybeSolveFor a n = case solveFor a n of
+>                         Solve t  -> Just t
+>                         _        -> Nothing
+
+> solveForAny :: NormalNum -> Maybe (Var () KNum, NormalNum)
+> solveForAny n = msum [(\ x -> (a, x)) <$> maybeSolveFor a n | a <- numvars n]
+
+> partitionNum :: [Var () KNum] -> NormalNum -> (NormalNum, NormalNum)
+> partitionNum vs (NN xs) = (NN ls, NN rs)
+>   where (ls, rs) = Map.partitionWithKey (const . (map Ex vs <<?)) xs
+
+> {-
+> getLinear :: NormNum a -> Maybe (Integer, [(NVar a, Integer)])
+> getLinear (NN xs) = lin (Map.toList xs)
+>   where
+>     lin :: [(Mono a, Integer)] -> Maybe (Integer, [(NVar a, Integer)])
+>     lin []            = Just (0, [])
+>     lin ((ys, k):xs)  = do
+>         l <- getLinearMono ys
+>         (j, zs) <- lin xs
+>         return $ case l of
+>             Left ()  -> (j + k, zs)
+>             Right a  -> (j, (a,k):zs)
+> -}
+
+> getLinearMono :: Mono a -> Maybe (Either () (Fac a KNum))
+> getLinearMono xs = case Map.toList xs of
+>     []        -> Just (Left ())
+>     [(f, 1)]  -> Just (Right f)
+>     _         -> Nothing
+
+
+> reifyNum :: NormNum a -> Ty a KNum
+> reifyNum (NN xs) = tySum pos -~ tySum neg
+>   where
+>     tySum :: [(Mono a, Integer)] -> Ty a KNum
+>     tySum = foldr (\ (t, k) u -> (k *** reifyMono t) +++ u) 0
+
+>     pos  = Map.toList posXs
+>     neg  = Map.toList (Map.map negate negXs)
+>     (posXs, negXs) = Map.partition (> 0) xs
+>     
+>     (+++) :: Ty a KNum -> Ty a KNum -> Ty a KNum
+>     TyInt i  +++ TyInt j  = TyInt (i + j)
+>     TyInt 0  +++ t        = t
+>     t        +++ TyInt 0  = t
+>     t        +++ t'       = t + t'
+
+>     (***) :: Integer -> Ty a KNum -> Ty a KNum
+>     i        *** TyInt j  = TyInt (i * j)
+>     0        *** _        = 0
+>     1        *** t        = t
+>     k        *** t        = TyInt k * t
+
+>     (-~) :: Ty a KNum -> Ty a KNum -> Ty a KNum
+>     TyInt i  -~ TyInt j   = TyInt (i - j)
+>     t        -~ TyInt 0   = t
+>     t        -~ t'        = t - t'
+
+>     reifyMono :: Mono a -> Ty a KNum
+>     reifyMono = Map.foldrWithKey (\ f k t -> pow (reifyFac f) k **** t) 1
+
+>     (****) :: Ty a KNum -> Ty a KNum -> Ty a KNum
+>     TyInt i  **** TyInt j  = TyInt (i * j)
+>     TyInt 0  **** _        = TyInt 0
+>     _        **** TyInt 0  = TyInt 0
+>     TyInt 1  **** t        = t
+>     t        **** TyInt 1  = t
+>     s        **** t        = s * t
+
+>     reifyFac :: Fac a k -> Ty a k
+>     reifyFac (VarFac a)    = TyVar a
+>     reifyFac (AppFac f m)  = TyApp (reifyFac f) (reifyNum m)
+>     reifyFac (AptFac f t)  = TyApp (reifyFac f) t
+>     reifyFac (UnFac o)     = UnOp o
+>     reifyFac (BinFac o)    = BinOp o
+
+>     pow :: Ty a KNum -> Integer -> Ty a KNum
+>     pow _  0  = 1
+>     pow t  1  = t
+>     pow t  k  = binOp Pow t (fromInteger k)
+
+
+> reifyPred :: Pred (NormNum a) -> Pred (Ty a KNum)
+> reifyPred = fmap reifyNum
+
+> normaliseNum :: Type KNum -> NormalNum
+> normaliseNum (TyInt i)  = fromInteger i
+> normaliseNum t          = facToNum (factorise t)
+>   where
+>     factorise :: Type k -> Factor k
+>     factorise (TyVar a)    = VarFac a
+>     factorise (UnOp o)     = UnFac o
+>     factorise (BinOp o)    = BinFac o
+>     factorise (TyApp f s)  = case getTyKind s of
+>                                  KNum  -> factorise f `AppFac` normaliseNum s
+>                                  _     -> factorise f `AptFac` s
+>     factorise x = error $ "normaliseNum: can't factorise " ++ show x
+>
+>     facToNum :: Factor KNum -> NormalNum
+>     facToNum (UnFac o `AppFac` m)              = nunOp o m
+>     facToNum (BinFac o `AppFac` m `AppFac` n)  = nbinOp o m n
+>     facToNum f                                 = singleFac f
+
+> normalisePred :: Predicate -> NormalPredicate
+> normalisePred (P c m n) = P c 0 (normaliseNum (n - m))
+> normalisePred (p :=> q) = normalisePred p :=> normalisePred q
+
+> trivialPred :: Ord a => NormPred a -> Maybe Bool
+> trivialPred (P c m n)     = compFun c 0 <$> (getConstant (n - m))
+> trivialPred (p :=> q)     = case trivialPred p of
+>                                 Just False  -> Just True
+>                                 _           -> trivialPred q
+
+> nunOp :: UnOp -> NormNum a -> NormNum a
+> nunOp o m = case getConstant m of
+>                 Just i   -> fromInteger (unOpFun o i)
+>                 Nothing  -> singleFac (UnFac o `AppFac` m)
+
+> nbinOp :: BinOp -> NormNum a -> NormNum a -> NormNum a
+> nbinOp Pow m n = case (getConstant m, getConstant n) of
+>                    (Just i,   Just j)  | j >= 0     -> fromInteger (i ^ j)
+>                    (_,        Just j)  | j >= 0     -> m ^ j
+>                                        | otherwise  -> singleFac (BinFac Pow `AppFac` m `AppFac` n)
+>                    (Just 1,   _)                    -> 1
+>                    _                                -> foldr foo 1 (Map.toList $ elimNN n)
+>  where
+>      foo (x, k) t | Map.null x  = t * (m ^ k)
+>                   | otherwise   = t * (singleFac (BinFac Pow `AppFac` m `AppFac` singleMono x) ^ k)
+
+> nbinOp o m n = case (o, getConstant m, getConstant n) of
+>         (_,      Just i,   Just j)  -> fromInteger (binOpFun o i j)
+>         (Plus,   _,        _)       -> NN $ unionMaps (elimNN m) (elimNN n)
+>         (Minus,  _,        _)       -> NN $ unionMaps (elimNN m) (Map.map negate $ elimNN n)
+>         (Times,  Just i,   _)       -> i *~ n
+>         (Times,  _,        Just j)  -> j *~ m
+>         (Times,  _,        _)       -> NN . dropZeroes . Map.fromList $ 
+>             [(unionMaps xs ys, i*j)
+>                 | (xs, i) <- Map.toList (elimNN m), (ys, j) <- Map.toList (elimNN n)]
+
+>         _                           -> singleFac (BinFac o `AppFac` m `AppFac` n)
+
+
+Note that we cannot rewrite 0 ^ n to 0 because n might turn out to be 0 later!
diff --git a/src/Language/Inch/Type.lhs b/src/Language/Inch/Type.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Type.lhs
@@ -0,0 +1,596 @@
+> {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable,
+>              GADTs, TypeOperators, TypeFamilies, RankNTypes,
+>              ScopedTypeVariables, FlexibleInstances,
+>              StandaloneDeriving, TypeSynonymInstances,
+>              MultiParamTypeClasses #-}
+
+> module Language.Inch.Type where
+
+> import Prelude hiding (foldr)
+> import Control.Applicative
+> import Data.Foldable hiding (any, elem, notElem)
+> import qualified Data.Monoid as M
+> import Data.Traversable
+> import Data.List hiding (foldr)
+
+> import Language.Inch.Kit
+> import Language.Inch.Kind
+
+> type TyNum a  = Ty a KNum
+> type TypeNum  = TyNum ()
+
+> type Type k  = Ty () k
+> type Tau     = Type KSet
+> type Sigma   = Type KSet
+> type Rho     = Type KSet
+
+> type Predicate   = Pred TypeNum
+> type SPredicate  = Pred SType
+
+
+> data Comparator = LE | LS | GE | GR | EL
+>   deriving (Eq, Ord, Show)
+
+> compFun :: Comparator -> Integer -> Integer -> Bool
+> compFun LE = (<=)
+> compFun LS = (<)
+> compFun GE = (>=)
+> compFun GR = (>)
+> compFun EL = (==)
+
+> compStringTm :: Comparator -> String
+> compStringTm LE = "<="
+> compStringTm LS = "<"
+> compStringTm GE = ">="
+> compStringTm GR = ">"
+> compStringTm EL = "=="
+
+> compStringTy :: Comparator -> String
+> compStringTy LE = "<="
+> compStringTy LS = "<"
+> compStringTy GE = ">="
+> compStringTy GR = ">"
+> compStringTy EL = "~"
+
+> data Pred ty where
+>     P      :: Comparator -> ty -> ty -> Pred ty
+>     (:=>)  :: Pred ty -> Pred ty -> Pred ty
+>   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+> (%==%), (%<=%), (%<%), (%>=%), (%>%) :: forall ty. ty -> ty -> Pred ty
+> (%==%)  = P EL
+> (%<=%)  = P LE
+> (%<%)   = P LS
+> (%>=%)  = P GE
+> (%>%)   = P GR
+
+
+
+> data UnOp = Abs | Signum
+>   deriving (Eq, Ord, Show)
+
+> unOpFun :: UnOp -> Integer -> Integer
+> unOpFun Abs     = abs
+> unOpFun Signum  = signum
+
+> unOpString :: UnOp -> String
+> unOpString Abs     = "abs"
+> unOpString Signum  = "signum"
+
+
+> data BinOp = Plus | Minus | Times | Pow | Min | Max
+>   deriving (Eq, Ord, Show)
+
+> {-
+>     Mod | Pow
+> -}
+
+> binOpFun :: BinOp -> Integer -> Integer -> Integer
+> binOpFun Plus   = (+)
+> binOpFun Minus  = (-)
+> binOpFun Times  = (*)
+> binOpFun Pow    = (^)
+> binOpFun Min    = min
+> binOpFun Max    = max
+
+> binOpString :: BinOp -> String
+> binOpString Plus   = "+"
+> binOpString Minus  = "-"
+> binOpString Times  = "*"
+> binOpString Pow    = "^"
+> binOpString Min    = "min"
+> binOpString Max    = "max"
+
+> binOpInfix :: BinOp -> Bool
+> binOpInfix Plus   = True
+> binOpInfix Minus  = True
+> binOpInfix Times  = True
+> binOpInfix Pow    = True
+> binOpInfix Min    = False
+> binOpInfix Max    = False
+
+> binOpPrefixString :: BinOp -> String
+> binOpPrefixString b | binOpInfix b  = '(' : binOpString b ++ ")"
+>                     | otherwise     = binOpString b
+
+
+> data TyKind where
+>     TK :: Type k -> Kind k -> TyKind
+
+> tkToEx :: TyKind -> Ex (Ty ())
+> tkToEx (TK t _) = Ex t
+
+
+> data Ty a k where
+>     TyVar  :: Var a k                                       -> Ty a k
+>     TyCon  :: TyConName -> Kind k                           -> Ty a k
+>     TySyn  :: TyConName -> TySyn a k                        -> Ty a k
+>     TyApp  :: Ty a (l :-> k) -> Ty a l                      -> Ty a k
+>     Bind   :: Binder -> String -> Kind l -> Ty (a, l) k     -> Ty a k
+>     Qual   :: Ty a KConstraint -> Ty a k                    -> Ty a k
+>     Arr    :: Ty a (KSet :-> KSet :-> KSet)
+>     TyInt  :: Integer     -> Ty a KNum
+>     UnOp   :: UnOp        -> Ty a (KNum :-> KNum)
+>     BinOp  :: BinOp       -> Ty a (KNum :-> KNum :-> KNum)
+>     TyComp :: Comparator  -> Ty a (KNum :-> KNum :-> KConstraint)
+
+> deriving instance Show (Ty a k)
+> deriving instance Show (Ex (Ty ()))
+
+> instance HetEq (Ty a) where
+>     hetEq (TyVar a)       (TyVar b)           yes no              = hetEq a b yes no
+>     hetEq (TyCon c k)     (TyCon c' k')       yes no | c == c'    = hetEq k k' yes no
+>     hetEq (TySyn c k)     (TySyn c' k')       yes no | c == c'    = hetEq k k' yes no
+>     hetEq (TyApp f s)     (TyApp f' s')       yes no              = hetEq f f' (hetEq s s' yes no) no
+>     hetEq (Bind b x k t)  (Bind b' x' k' t')  yes no | b == b' && x == x' = hetEq k k' (hetEq t t' yes no) no
+>     hetEq (Qual p t)      (Qual p' t')        yes no | p == p'    = hetEq t t' yes no
+>     hetEq Arr             Arr                 yes _               = yes
+>     hetEq (TyInt i)       (TyInt j)           yes _  | i == j     = yes
+>     hetEq (UnOp o)        (UnOp o')           yes _  | o == o'    = yes
+>     hetEq (BinOp o)       (BinOp o')          yes _  | o == o'    = yes
+>     hetEq (TyComp c)      (TyComp c')         yes _  | c == c'    = yes
+>     hetEq _               _                   _   no = no
+
+> instance Eq (Ty a k) where
+>     (==) = (=?=)
+
+> instance HetOrd (Ty a) where
+>     TyVar a    <?= TyVar b    = a <?= b
+>     TyVar _    <?= _          = True
+>     _          <?= TyVar _    = False
+>     TyCon c k  <?= TyCon d l  = c < d || (c == d && k <?= l)
+>     TyCon _ _  <?= _          = True
+>     _          <?= TyCon _ _  = False
+>     TySyn c k  <?= TySyn d l  = c < d || (c == d && k <?= l)
+>     TySyn _ _  <?= _          = True
+>     _          <?= TySyn _ _  = False
+>     TyApp f s  <?= TyApp g t  | f =?= g = s <?= t
+>                               | otherwise = f <?= g
+>     TyApp _ _  <?= _          = True
+>     _          <?= TyApp _ _  = False
+>     Bind b x k t  <?= Bind b' x' k' t'  = 
+>         b < b' || (b == b' && (x < x' || (x == x' &&
+>             ((k <?= k' && not (k =?= k')) || (hetEq k k' (t <?= t') False)))))
+>     Bind _ _ _ _  <?= _                 = True
+>     _             <?= Bind _ _ _ _      = False
+>     Qual p s      <?= Qual q t          = p < q || (p == q && s <?= t) 
+>     Qual _ _      <?= _                 = True
+>     _             <?= Qual _ _          = False
+>     Arr           <?= _                 = True
+>     _             <?= Arr               = False
+>     TyInt i       <?= TyInt j           = i <= j
+>     TyInt _       <?= _                 = True
+>     _             <?= TyInt _           = False
+>     UnOp o        <?= UnOp p            = o <= p
+>     UnOp _        <?= _                 = True
+>     _             <?= UnOp _            = False
+>     BinOp o       <?= BinOp p           = o <= p
+>     BinOp _       <?= _                 = True
+>     _             <?= BinOp _           = False
+>     TyComp c      <?= TyComp c'         = c <= c'
+
+> instance Ord (Ty a k) where
+>     (<=) = (<?=)
+
+
+> instance Num (Ty a KNum) where
+>     fromInteger  = TyInt
+>     (+)          = binOp Plus
+>     (*)          = binOp Times
+>     (-)          = binOp Minus
+>     abs          = unOp Abs
+>     signum       = unOp Signum
+>
+>     negate (TyInt k)  = TyInt (- k)
+>     negate t          = 0 - t
+
+
+> data SType where
+>     STyVar  :: String                              ->  SType
+>     STyCon  :: TyConName                           ->  SType
+>     STyApp  :: SType -> SType                      ->  SType
+>     SBind   :: Binder -> String -> SKind -> SType  ->  SType
+>     SQual   :: SType -> SType                      ->  SType
+>     SArr    ::                                         SType
+>     STyInt  :: Integer                             ->  SType
+>     SUnOp   :: UnOp                                ->  SType
+>     SBinOp  :: BinOp                               ->  SType
+>     STyComp :: Comparator                          ->  SType
+>   deriving (Eq, Show)
+
+> instance Num SType where
+>     fromInteger  = STyInt
+>     (+)          = sbinOp Plus
+>     (*)          = sbinOp Times
+>     (-)          = sbinOp Minus
+>     abs          = sunOp Abs
+>     signum       = sunOp Signum
+
+>     negate (STyInt k)  = STyInt (- k)
+>     negate t           = 0 - t
+
+> collectUnbound :: [String] -> SType -> [String]
+> collectUnbound bs (STyVar s)       | s `elem` bs  = []
+>                                    | otherwise    = [s]
+> collectUnbound _ (STyCon _)        = []
+> collectUnbound bs (STyApp f s)     = collectUnbound bs f `union` collectUnbound bs s
+> collectUnbound bs (SBind _ b _ u)  = collectUnbound (b:bs) u
+> collectUnbound bs (SQual p u)      = collectUnbound bs p `union` collectUnbound bs u
+> collectUnbound _ SArr              = []
+> collectUnbound _ (STyInt _)        = []
+> collectUnbound _ (SUnOp _)         = []
+> collectUnbound _ (SBinOp _)        = []
+> collectUnbound _ (STyComp _)       = []
+
+> wrapForall :: [String] -> SType -> SType
+> wrapForall _ t@(SBind All _ _ _) = t
+> wrapForall xs t = foldr (\ x y -> SBind All x SKSet y) t (collectUnbound xs t)
+
+
+
+> predToConstraint :: Predicate -> Type KConstraint
+> predToConstraint (P c m n) = tyPred c m n
+> predToConstraint (p :=> q) = Qual (predToConstraint p) (predToConstraint q)
+
+> constraintToPred :: Type KConstraint -> Maybe Predicate
+> constraintToPred (Qual p q)                      = (:=>) <$> constraintToPred p <*> constraintToPred q
+> constraintToPred (TyComp c `TyApp` m `TyApp` n)  = Just (P c m n)
+> constraintToPred _                               = Nothing
+
+> sConstraintToPred :: SType -> Maybe (Pred SType)
+> sConstraintToPred (STyComp c `STyApp` m `STyApp` n)  = Just (P c m n)
+> sConstraintToPred _                                  = Nothing
+
+
+> fogTy :: Type k -> SType
+> fogTy = fogTy' fogVar []
+
+> fogSysTy :: Type k -> SType
+> fogSysTy = fogTy' fogSysVar []
+
+> fogTy' :: (forall l. Var a l -> String) -> [String] -> Ty a k -> SType
+> fogTy' g _   (TyVar v)       = STyVar (g v)
+> fogTy' _ _   (TyCon c _)     = STyCon c
+> fogTy' _ _   (TySyn c _)     = STyCon c
+> fogTy' g xs  (TyApp f s)     = STyApp (fogTy' g xs f) (fogTy' g xs s)
+> fogTy' g xs  (Qual p t)      = SQual (fogTy' g xs p) (fogTy' g xs t)
+> fogTy' _ _   Arr             = SArr
+> fogTy' _ _   (TyInt i)       = STyInt i
+> fogTy' _ _   (UnOp o)        = SUnOp o
+> fogTy' _ _   (BinOp o)       = SBinOp o
+> fogTy' _ _   (TyComp c)      = STyComp c
+> fogTy' g xs  (Bind b x k t)  =
+>     SBind b y (fogKind k) (fogTy' (wkF g y) (y:xs) t)
+>   where
+>     y = alphaConv x xs
+
+> fogPred :: Predicate -> SPredicate
+> fogPred = fogPred' fogVar []
+
+> fogSysPred :: Predicate -> SPredicate
+> fogSysPred = fogPred' fogSysVar []
+
+> fogPred' :: (forall l. Var a l -> String) -> [String] -> Pred (Ty a KNum) -> SPredicate
+> fogPred' g xs = fmap (fogTy' g xs)
+
+
+
+
+> alphaConv :: String -> [String] -> String
+> alphaConv x xs | x `notElem` xs = x
+>                | otherwise = alphaConv (x ++ "'") xs
+
+> getTyKind :: Type k -> Kind k
+> getTyKind (TyVar v)        = varKind v
+> getTyKind (TyCon _ k)      = k
+> getTyKind (TySyn _ t)      = getTySynKind t
+> getTyKind (TyApp f _)      = kindCod (getTyKind f)
+> getTyKind (TyInt _)        = KNum
+> getTyKind (UnOp _)         = KNum :-> KNum
+> getTyKind (BinOp _)        = KNum :-> KNum :-> KNum
+> getTyKind (Qual _ t)       = getTyKind t
+> getTyKind (Bind _ _ k t)   = getTyKind (unbindTy (FVar (error "lie") k) t)
+> getTyKind Arr              = KSet :-> KSet :-> KSet
+> getTyKind (TyComp _)       = KNum :-> KNum :-> KConstraint
+
+
+> (-->) :: forall a. Ty a KSet -> Ty a KSet -> Ty a KSet
+> s --> t = TyApp (TyApp Arr s) t
+> infixr 5 -->
+
+> (--->) :: SType -> SType -> SType
+> s ---> t = STyApp (STyApp SArr s) t
+> infixr 5 --->
+
+> (/->) :: Foldable f => f (Ty a KSet) -> Ty a KSet -> Ty a KSet
+> ts /-> t = foldr (-->) t ts
+
+> (/=>) :: Foldable f => f (Ty a KConstraint) -> Ty a k -> Ty a k
+> ps /=> t = foldr Qual t ps
+
+> unOp :: UnOp -> Ty a KNum -> Ty a KNum
+> unOp o = TyApp (UnOp o)
+
+> binOp :: BinOp -> Ty a KNum -> Ty a KNum -> Ty a KNum
+> binOp o = TyApp . TyApp (BinOp o)
+
+> sunOp :: UnOp -> SType -> SType
+> sunOp o = STyApp (SUnOp o)
+
+> sbinOp :: BinOp -> SType -> SType -> SType
+> sbinOp o = STyApp . STyApp (SBinOp o)
+
+
+
+> swapTop :: Ty ((a, k), l) x -> Ty ((a, l), k) x
+> swapTop = renameTy (withBVar swapVar)
+>   where
+>     swapVar :: BVar ((a, k), l) x -> BVar ((a, l), k) x
+>     swapVar Top            = Pop Top
+>     swapVar (Pop Top)      = Top
+>     swapVar (Pop (Pop x))  = Pop (Pop x)
+
+> renameTy :: (forall k. Var a k -> Var b k) -> Ty a l -> Ty b l
+> renameTy g (TyVar v)       = TyVar (g v)
+> renameTy _ (TyCon c k)     = TyCon c k
+> renameTy g (TySyn c t)     = TySyn c (renameTySyn g t)
+> renameTy g (TyApp f s)     = TyApp (renameTy g f) (renameTy g s)
+> renameTy g (Bind b x k t)  = Bind b x k (renameTy (wkRenaming g) t)
+> renameTy g (Qual p t)      = Qual (renameTy g p) (renameTy g t)
+> renameTy _ Arr             = Arr
+> renameTy _ (TyInt i)       = TyInt i
+> renameTy _ (UnOp o)        = UnOp o
+> renameTy _ (BinOp o)       = BinOp o
+> renameTy _ (TyComp c)      = TyComp c
+
+> bindTy :: Var a k -> Ty a l -> Ty (a, k) l
+> bindTy v = renameTy (bindVar v)
+
+> unbindTy :: Var a k -> Ty (a, k) l -> Ty a l
+> unbindTy v = renameTy (unbindVar v)
+
+> wkTy :: Ty a k -> Ty (a, l) k
+> wkTy = renameTy wkVar
+
+> wkClosedTy :: Ty () k -> Ty a k
+> wkClosedTy = renameTy wkClosedVar
+
+> wkSubst :: (Var a k -> Ty b k) -> Var (a, l) k -> Ty (b, l) k
+> wkSubst g (FVar a k)      = wkTy (g (FVar a k))
+> wkSubst _ (BVar Top)      = TyVar (BVar Top)
+> wkSubst g (BVar (Pop x))  = wkTy (g (BVar x))
+
+> substTy :: (forall k . Var a k -> Ty b k) -> Ty a l -> Ty b l
+> substTy g (TyVar v)       = g v
+> substTy _ (TyCon c k)     = TyCon c k
+> substTy g (TySyn c t)     = TySyn c (substTySyn g t)
+> substTy g (TyApp f s)     = TyApp (substTy g f) (substTy g s)
+> substTy g (Bind b x k t)  = Bind b x k (substTy (wkSubst g) t)
+> substTy g (Qual p t)      = Qual (substTy g p) (substTy g t)
+> substTy _ Arr             = Arr
+> substTy _ (TyInt i)       = TyInt i
+> substTy _ (UnOp o)        = UnOp o
+> substTy _ (BinOp o)       = BinOp o
+> substTy _ (TyComp c)      = TyComp c
+
+> instTy :: forall a l k . Ty a l -> Ty (a, l) k -> Ty a k
+> instTy t = substTy (instTySubst t)
+
+> instTySubst :: Ty a l -> Var (a, l) k -> Ty a k
+> instTySubst t (BVar Top)      = t
+> instTySubst _ (BVar (Pop v))  = TyVar (BVar v)
+> instTySubst _ (FVar a k)      = TyVar (FVar a k)
+
+
+> replaceTy :: forall a k l. Var a k -> Ty a k -> Ty a l -> Ty a l
+> replaceTy a u = substTy f
+>   where
+>     f :: Var a k' -> Ty a k'
+>     -- f b@(FVar (N _ _ (UserVar Pi)) KNum) = TyVar b -- This is a hack to avoid replacing pivars
+>     f b = hetEq a b u (TyVar b)
+
+
+
+> tyPred :: Comparator -> Ty a KNum -> Ty a KNum -> Ty a KConstraint
+> tyPred c m n = TyComp c `TyApp` m `TyApp` n
+
+> styPred :: Comparator -> SType -> SType -> SType
+> styPred c m n = STyComp c `STyApp` m `STyApp` n
+
+> simplifyTy :: Ord a => Ty a KSet -> Ty a KSet
+> simplifyTy = simplifyTy' []
+>   where
+>     simplifyTy' :: Ord a => [Ty a KConstraint] -> Ty a KSet -> Ty a KSet
+>     simplifyTy' ps (Qual p t)      = simplifyTy' (simplifyPred p:ps) t
+>     simplifyTy' ps t               = nub ps /=> t
+
+> simplifyPred :: Ty a KConstraint -> Ty a KConstraint
+> simplifyPred (Qual p q) = Qual (simplifyPred p) (simplifyPred q)
+> simplifyPred (TyComp c `TyApp` m `TyApp` n) = case (simplifyNum m, simplifyNum n) of
+>     (TyApp (TyApp (BinOp Minus) m') n', TyInt 0)  -> mkP c m' n'
+>     (TyInt 0, TyApp (TyApp (BinOp Minus) n') m')  -> mkP c m' n'
+>     (m', n')                                      -> mkP c m' n'
+>   where
+>     mkP LE x (TyApp (TyApp (BinOp Minus) y) (TyInt 1)) = tyPred LS x y
+>     mkP c' x y = tyPred c' x y
+> simplifyPred t = t 
+
+> simplifyNum :: Ty a KNum -> Ty a KNum
+> simplifyNum (TyApp (TyApp (BinOp o) n) m) = case (o, simplifyNum n, simplifyNum m) of
+>     (Plus,   TyInt k,  TyInt l)  -> TyInt (k+l)
+>     (Plus,   TyInt 0,  m')       -> m'
+>     (Plus,   n',       TyInt 0)  -> n'
+>     (Plus,   TyApp (TyApp (BinOp Plus) n') (TyInt k), TyInt l)  | k == -l    -> n'
+>                                                         | otherwise  -> n' + TyInt (k+l)
+>     (Plus,   n',       m')       -> n' + m'
+>     (Times,  TyInt k,     TyInt l)     -> TyInt (k*l)
+>     (Times,  TyInt 0,     _)          -> TyInt 0
+>     (Times,  TyInt 1,     m')          -> m'
+>     (Times,  TyInt (-1),  m')          -> negate m'
+>     (Times,  _,           TyInt 0)     -> TyInt 0
+>     (Times,  n',          TyInt 1)     -> n'
+>     (Times,  n',          TyInt (-1))  -> negate n'
+>     (Times,  n',          m')          -> n' * m'
+>     (_,      n',          m')          -> TyApp (TyApp (BinOp o) n') m'
+> simplifyNum t = t
+
+
+> args :: Ty a k -> Int
+> args (TyApp (TyApp Arr _) t)  = succ $ args t
+> args (Bind Pi  _ _ t)                = succ $ args t
+> args (Bind All _ _ t)               = args t
+> args (Qual _ t)                     = args t
+> args _                              = 0
+
+> splitArgs :: Ty a k -> ([Ty a k], Ty a k)
+> splitArgs (TyApp (TyApp Arr s) t) = (s:ss, ty)
+>   where (ss, ty) = splitArgs t
+> splitArgs t = ([], t)
+
+> targets :: Ty a k -> TyConName -> Bool
+> targets (TyCon c _)               t | c == t = True
+> targets (TyApp (TyApp Arr _) ty)  t = targets ty t
+> targets (TyApp f _)               t = targets f t
+> targets (Bind _ _ _ ty)           t = targets ty t
+> targets (Qual _ ty)               t = targets ty t
+> targets _                         _ = False
+
+
+> {-
+> elemsTy :: [Var a k] -> Ty a l -> Bool
+> elemsTy as (TyVar b)       = any (b =?=) as
+> elemsTy as (TyApp f s)     = elemsTy as f || elemsTy as s
+> elemsTy as (Bind _ _ _ t)  = elemsTy (map wkVar as) t
+> elemsTy as (Qual p t)      = elemsTy as p || elemsTy as t 
+> elemsTy _  _               = False
+
+> elemTy :: Var a k -> Ty a l -> Bool
+> elemTy a t = elemsTy [a] t
+
+> elemsPred :: [Var a k] -> Pred (Ty a KNum) -> Bool
+> elemsPred as = M.getAny . foldMap (M.Any . elemsTy as)
+
+> elemPred :: Var a k -> Pred (Ty a KNum) -> Bool
+> elemPred a p = elemsPred [a] p
+> -}
+
+> elemTarget :: Var a k -> Ty a l -> Bool
+> elemTarget a (TyApp (TyApp Arr _) ty)  = elemTarget a ty
+> elemTarget a (Qual _ ty)               = elemTarget a ty
+> elemTarget a (Bind Pi _ _ ty)          = elemTarget (wkVar a) ty
+> elemTarget a t                         = a <? t
+
+> instance FV t a => FV (Pred t) a where
+>     fvFoldMap f = foldMap (fvFoldMap f)
+        
+> instance a ~ b => FV (Ty a k) b where
+>     fvFoldMap f (TyVar a)       = f a
+>     fvFoldMap _ (TyCon _ _)     = M.mempty
+>     fvFoldMap _ (TySyn _ _)     = M.mempty
+>     fvFoldMap f (TyApp t u)     = fvFoldMap f t <.> fvFoldMap f u
+>     fvFoldMap f (Bind _ _ _ t)  = fvFoldMap (wkF f M.mempty) t
+>     fvFoldMap f (Qual p t)      = fvFoldMap f p <.> fvFoldMap f t
+>     fvFoldMap _ Arr             = M.mempty
+>     fvFoldMap _ (TyInt _)       = M.mempty
+>     fvFoldMap _ (UnOp _)        = M.mempty
+>     fvFoldMap _ (BinOp _)       = M.mempty
+>     fvFoldMap _ (TyComp _)      = M.mempty
+
+
+
+> {-
+> allWrapVS :: VarSuffix () b x -> Type KSet -> Type KSet
+> allWrapVS VS0        t = t
+> allWrapVS (vs :<< v) t = allWrapVS vs (Bind All (nameToString (varName v)) (varKind v) (bindTy v t))
+
+> applyVS :: (forall k . Kind k -> Type k) -> VarSuffix () b x -> Type KConstraint
+> applyVS hd vs = help vs KConstraint
+>   where
+>     help :: VarSuffix () b x -> Kind l -> Type l
+>     help VS0        k = hd k
+>     help (vs :<< v) k = help vs (varKind v :-> k) `TyApp` TyVar v
+> -}
+
+
+
+> applys :: (forall k . Kind k -> Type k) -> [Ex (Ty ())] -> Kind k' -> Type k'
+> applys f xs k' = help xs k'
+>       where
+>         help :: [Ex (Ty ())] -> Kind l -> Type l
+>         help []          l = f l
+>         help (Ex t : ts) l = help ts (getTyKind t :-> l) `TyApp` t
+
+
+
+
+
+
+> data STypeSyn where
+>     SSynTy   :: SType -> STypeSyn
+>     SSynAll  :: String -> SKind -> STypeSyn -> STypeSyn
+>   deriving (Eq, Show)
+
+
+> type TypeSyn k = TySyn () k
+
+> data TySyn a k where
+>     SynTy   :: Ty a k -> TySyn a k
+>     SynAll  :: String -> Kind l -> TySyn (a, l) k -> TySyn a (l :-> k)
+
+> deriving instance Show (TySyn a k)
+
+> instance HetEq (TySyn a) where
+>     hetEq (SynTy t)      (SynTy u)      yes no = hetEq t u yes no
+>     hetEq (SynAll x k t) (SynAll y l u) yes no | x == y = hetEq k l (hetEq t u yes no) no
+>     hetEq _ _ _ no = no
+
+> instance HetOrd (TySyn a) where
+>     SynTy t <?= SynTy u = t <?= u
+>     SynTy _ <?= SynAll _ _ _ = True
+>     SynAll _ _ _ <?= SynTy _ = False
+>     SynAll x k t <?= SynAll y l u = x <= y || (x == y && (k <?= l || (hetEq k l (t <?= u) False)))
+
+
+> substTySyn :: (forall k . Var a k -> Ty b k) -> TySyn a l -> TySyn b l
+> substTySyn g (SynTy t)      = SynTy (substTy g t)
+> substTySyn g (SynAll x k t) = SynAll x k (substTySyn (wkSubst g) t)
+
+> renameTySyn :: (forall k. Var a k -> Var b k) -> TySyn a l -> TySyn b l
+> renameTySyn g = substTySyn (TyVar . g)
+
+> bindTySyn :: Var a k -> TySyn a l -> TySyn (a, k) l
+> bindTySyn v = renameTySyn (bindVar v)
+
+> unbindTySyn :: Var a k -> TySyn (a, k) l -> TySyn a l
+> unbindTySyn v = renameTySyn (unbindVar v)
+
+> instTySyn :: Ty a k -> TySyn (a, k) l -> TySyn a l
+> instTySyn t = substTySyn (instTySubst t)
+
+> getTySynKind :: TySyn () k -> Kind k
+> getTySynKind (SynTy t)      = getTyKind t
+> getTySynKind (SynAll _ k t) = k :-> getTySynKind (unbindTySyn (FVar (error "tySynKind") k) t)
+
+> fogTySyn :: (forall k. Var a k -> String) -> TySyn a l -> STypeSyn
+> fogTySyn g (SynTy t)       = SSynTy (fogTy' g [] t)
+> fogTySyn g (SynAll x k t)  = SSynAll x (fogKind k) (fogTySyn (wkF g x) t)
diff --git a/src/Language/Inch/TypeCheck.lhs b/src/Language/Inch/TypeCheck.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/TypeCheck.lhs
@@ -0,0 +1,660 @@
+> {-# LANGUAGE GADTs, TypeOperators, FlexibleContexts, PatternGuards,
+>              RankNTypes #-}
+
+> module Language.Inch.TypeCheck where
+
+> import Control.Applicative hiding (Alternative)
+> import Control.Monad
+> import Control.Monad.State
+> import Control.Monad.Writer hiding (All)
+> import Data.List
+> import Data.Maybe
+> import qualified Data.Map as Map
+> import Data.Foldable hiding (foldr, any, mapM_)
+> import Data.Traversable
+> import Text.PrettyPrint.HughesPJ
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Kind 
+> import Language.Inch.Type
+> import Language.Inch.TyNum
+> import Language.Inch.Syntax
+> import Language.Inch.Context
+> import Language.Inch.Unify
+> import Language.Inch.Kit
+> import Language.Inch.Error
+> import Language.Inch.PrettyPrinter
+> import Language.Inch.KindCheck
+> import Language.Inch.Solver
+> import Language.Inch.Check
+
+
+
+The |inst| function takes a name-mangling function (for modifying the
+names of binders), a type definition (for use when introducing binders
+into the context) and a type to instantiate. It instantiates
+forall-binders with fresh variables to produce a rho-type, and writes
+a list of predicates found.
+
+> inst :: VarState -> (forall k. TyDef k) -> Type l ->
+>             ContextualWriter [Type KConstraint] (Type l)
+> inst vs d (TyApp (TyApp Arr a) t) =
+>     TyApp (TyApp Arr a) <$> inst vs d t
+> inst vs d (Bind All x k t) = do
+>     beta <- fresh vs x k d
+>     inst vs d (unbindTy beta t)
+> inst vs d (Qual p t) = do
+>     tell [p]
+>     inst vs d t
+> inst _ _ t = return t
+
+
+The |instS| function is like |inst|, but also takes a constraint
+status, and stores the predicates in the context with the given
+status.
+
+> instS :: VarState -> CStatus -> (forall k. TyDef k) -> Type l ->
+>              Contextual (Type l)
+> instS vs s d t = do
+>     (ty, cs) <- runWriterT $ inst vs d t
+>     modifyContext (<><< map (Constraint s) cs)
+>     return ty
+
+> specialise :: Type l -> Contextual (Type l)
+> specialise = instS (UserVar All) Given Fixed
+
+> instantiate :: Type l -> Contextual (Type l)
+> instantiate = instS SysVar Wanted Hole
+
+
+> existentialise :: (MonadState ZipState m, FV (Type k) ()) =>
+>                       m (Type k) -> m (Type k)
+> existentialise m = do
+>     modifyContext (:< Layer FunTop False) -- hackish
+>     ty <- m
+>     modifyContext $ help (flip elemTarget ty)
+>     return ty
+>   where
+>     help :: (forall k. Var () k -> Bool) -> Context -> Context
+>     help isHole (g :< A (a := Hole))
+>         | isHole a                     = help isHole g :< A (a := Hole)
+>         | otherwise                    = help isHole g :< A (a := Exists)
+>     help _      (g :< Layer FunTop _)  = g
+>     help isHole (g :< e)               = help isHole g :< e
+>     help _      B0                     = error "existentialise: ran out of context"
+
+
+> generalise :: (FV (t OK ()) (), TravTypes1 t) => Type KSet -> [t OK ()] ->
+>                   Contextual (Type KSet, [t OK ()])
+> generalise u qs = do
+>     g <- getContext
+>     (g', tps) <- help g (u, qs) []
+>     putContext g'
+>     return tps
+>   where
+>     help :: (FV (t OK ()) (), TravTypes1 t) =>  Context ->
+>                 (Type KSet, [t OK ()]) -> [Type KConstraint] ->
+>                     Contextual (Context, (Type KSet, [t OK ()]))
+>     help (g :< Layer l True)   tps _ = return (g :< Layer l True, tps)
+>     help (g :< Layer l False)  tps hs = (<:< Layer l False) <$> help g tps hs 
+
+>     help (g :< A (a@(FVar _ KNum) := Exists)) (t, ps) hs
+>       | a <? (t, ps, hs) = case solveForLots a hs of
+>             Just n   -> replaceHelp g (t, ps) hs a (reifyNum n)
+>             Nothing  | a <? t -> traceContext "oh no" >>
+>                                     errBadExistential a t
+>                      | otherwise -> help g (t, ps) (filter (not . (a <?)) hs)
+>     help (_ :< A (a := Exists)) (t, ps) hs
+>       | a <? (t, ps, hs)     = errBadExistential a t
+>     help (g :< A (a := Some d)) (t, ps) hs = replaceHelp g (t, ps) hs a d
+>     help (g :< A (a := _)) (t, ps) hs
+>       | a <? (t, ps, hs) = help g (Bind All (fogVar a) (varKind a) (bindTy a t), ps) hs
+>     help (g :< A _)                  tps hs      = help g tps hs
+
+>     help (g :< Constraint Given h)   tps hs      = help g tps (h:hs)
+>     help (g :< Constraint Wanted p)  (t, ps) hs
+>         | impossible p  = errImpossible p
+>         | otherwise     = help g (Qual p t, ps) hs
+
+>     help _ _ _ = erk $ "generalise: hit empty context"
+
+>     impossible :: Type KConstraint -> Bool
+>     impossible p = null (vars p)
+            
+>     (<:<) :: (Context, t) -> Entry -> (Context, t)
+>     (g, x) <:< e = (g :< e, x)
+
+
+>     replaceHelp :: (FV (t OK ()) (), TravTypes1 t) => Context ->
+>                        (Type KSet, [t OK ()]) -> [Type KConstraint] ->
+>                            Var () l -> Type l ->
+>                                Contextual (Context, (Type KSet, [t OK ()]))
+>     replaceHelp g (t, ps) hs a d =
+>         help g (replaceTy a d t, map (replaceTypes a d) ps) (map (replaceTy a d) hs)
+
+>     solveForLots :: Var () KNum -> [Type KConstraint] -> Maybe NormalNum
+>     solveForLots a = getFirst . foldMap (First . maybeSolveFor a) . mapMaybe f
+>       where  f (TyComp EL `TyApp` m `TyApp` n)  = Just (normaliseNum (m - n))
+>              f _           = Nothing
+
+
+> subsCheck :: Sigma -> Sigma -> Contextual ()
+> subsCheck s t = do
+>     t'  <- specialise t
+>     s'  <- instantiate s
+>     case (s', t') of
+>         (TyApp (TyApp Arr s1) s2, _) -> do
+>             (t1, t2) <- unifyFun t'
+>             subsCheck t1 s1
+>             subsCheck s2 t2
+>         (_, TyApp (TyApp Arr t1) t2) -> do
+>             (s1, s2) <- unifyFun s'
+>             subsCheck t1 s1
+>             subsCheck s2 t2
+>         (Bind Pi x KNum t1, Bind Pi _ KNum t2) -> do
+>             a <- fresh SysVar x KNum Fixed
+>             subsCheck (unbindTy a t1) (unbindTy a t2)
+>         _ -> unify s' t'
+
+
+> instSigma :: Sigma -> Maybe Rho -> Contextual Rho
+> instSigma s Nothing   = instantiate s
+> instSigma s (Just r)  = subsCheck s r >> return r
+
+
+
+
+> inferRho :: STerm () -> Contextual (Term () ::: Rho)
+> inferRho t =
+>   inLocation (text "in inferred expression" <++> prettyHigh t) $
+>     checkInfer Nothing t
+
+> checkRho :: Rho -> STerm () -> Contextual (Term ())
+> checkRho ty t =
+>   inLocation (text "in checked expression" <++> prettyHigh t) $
+>     tmOf <$> checkInfer (Just ty) t
+
+
+
+
+> checkSigma :: Sigma -> STerm () -> Contextual (Term ())
+> checkSigma s e = inLocation (sep [text "when checking", nest 2 (prettyHigh e),
+>                                   text "has type", nest 2 (prettyHigh (fogTy s))]) $ do
+>     unifySolveConstraints
+>     modifyContext (:< Layer GenMark True)
+>     s' <- specialise s
+>     as <- getNames <$> getContext
+>     t <- checkRho s' e
+>     unifySolveConstraints
+>     solveOrSuspend
+>     g <- getContext
+>     putContext =<< help as g []
+>     return t
+>   where
+>     getNames :: Context -> [Ex (Var ())]
+>     getNames (_ :< Layer GenMark _)  = []
+>     getNames (g :< A (a := _))       = Ex a : getNames g
+>     getNames (g :< _)                = getNames g
+>     getNames B0                      = error "getNames: ran out of context"
+
+>     help :: [Ex (Var ())] -> Context -> [Entry] -> Contextual Context
+>     help [] (g :< Layer GenMark _) h  = return $ g <><| h
+>     help as (_ :< Layer GenMark _) _  = erk $ "checkSigma help: failed to squish "
+>                                         ++ intercalate "," (map (\ x -> unEx x fogSysVar) as)
+>     help _  (_ :< Layer l _)       _  = error $ "checkSigma.help: hit bad layer " ++ show l
+>     help as (g :< A (a := Fixed)) h = case suppress a h of
+>         Just h'  -> help (delete (Ex a) as) g h'
+>         Nothing  -> traceContext "noooooooooo" >> (erk $ "checkSigma help: fixed variable "
+>                                 ++ renderMe (fogSysVar a)
+>                                 ++ " occurred illegally in "
+>                                 ++ show (fsepPretty h))
+>     help as (g :< A (a := Some d)) h = help as g (fmap (replaceTyEntry a d) h)
+>     help as (g :< A a) h                   = help as g (A a : h)
+>     help as (g :< Constraint Wanted p) h   = help as g (Constraint Wanted p : h) 
+>     help as (g :< Constraint Given p) h    = help as g (map (abstract p) h)
+>     help _  B0 _ = error "checkSigma help: ran out of context"
+
+>     abstract p  (Constraint c q)  = Constraint c (Qual p q)
+>     abstract _  x                 = x
+
+>     (<><|) :: Context -> [Entry] -> Context
+>     g <><| [] = g
+>     g <><| (x:xs) = (g :< x) <><| xs
+
+>     suppress :: Var () k -> [Entry] -> Maybe [Entry]
+>     suppress _ [] = return []
+>     suppress a (x : xs) | not (a <? x) = (x :) <$> suppress a xs
+>     suppress a@(FVar _ KNum) (Constraint Wanted p : es) = suppressPred a p >>=
+>         \ p' -> (Constraint Wanted p' :) <$> suppress a es
+>     suppress _ _ = Nothing
+
+>     suppressPred :: Var () KNum -> Type KConstraint -> Maybe (Type KConstraint)
+>     suppressPred a (Qual p q) | a <? p     = suppressPred a q
+>                               | otherwise  = Qual p <$> suppressPred a q
+>     suppressPred a p | a <? p     = Nothing
+>                      | otherwise  = Just p
+
+
+
+
+> checkInfer :: Maybe Rho -> STerm () -> Contextual (Term () ::: Rho)
+
+> checkInfer mty (TmVar x) = do
+>     sc  <- tyOf <$> lookupTmVar x
+>     ty  <- instSigma sc mty
+>     return $ TmVar x ::: ty
+
+> checkInfer mty (TmCon c) = do
+>     sc  <- lookupTmCon c
+>     ty  <- instSigma sc mty
+>     return $ TmCon c ::: ty
+
+> checkInfer mty (TmInt k) = do
+>     ty <- instSigma tyIntLit mty
+>     return $ TmInt k ::: ty
+
+> checkInfer mty (CharLit c) = do
+>     _ <- instSigma tyChar mty
+>     return $ CharLit c ::: tyChar
+
+> checkInfer mty (StrLit s) = do
+>     _ <- instSigma tyString mty
+>     return $ StrLit s ::: tyString
+
+> checkInfer mty (TmApp f (TmBrace n)) = do
+>     f' ::: fty  <- inferRho f   
+>     case fty of
+>         Bind Pi _ KNum aty -> do
+>             n'   <- checkKind KNum Pi B0 n
+>             a   <- fresh SysVar "_n" KNum (Some n')
+>             ty  <- instSigma (unbindTy a aty) mty
+>             return $ TmApp f' (TmBrace n') ::: ty
+>         _ -> erk $ "Inferred type " ++ renderMe (fogSysTy fty) ++ " of " ++
+>                  renderMe (fogSys f') ++ " is not a pi-type with numeric domain"
+
+> checkInfer mty (TmApp f s) = do
+>     f' ::: fty  <- inferRho f
+>     (dom, cod)  <- unifyFun fty
+>     s'          <- checkSigma dom s
+>     _ <- instSigma cod mty
+>     return $ TmApp f' s' ::: cod
+
+> checkInfer (Just r) (Lam x t) = do
+>     (dom, cod) <- unifyFun r
+>     b <- withLayer False False (LamBody (x ::: dom)) $ checkRho cod t
+>     return $ Lam x b ::: r
+
+> checkInfer Nothing (Lam x t) = do
+>     a <- unknownTyVar x KSet
+>     b ::: ty <- withLayer False False (LamBody (x ::: a)) $ inferRho t
+>     return $ Lam x b ::: a --> ty
+
+> checkInfer (Just r@(Bind Pi _ KNum ty)) (NumLam n t) = do
+>     a <- fresh (UserVar Pi) n KNum Fixed -- should this be |Exists|?
+>     b <- withLayer False False (LamBody (n ::: tyInteger)) $
+>              checkSigma (unbindTy a ty) (rawCoerce t)
+>     return $ NumLam n (bindTm a b) ::: r
+
+> checkInfer (Just r) (NumLam n t) = erk $
+>     "Type " ++ renderMe (fogSysTy r) ++
+>       " is not a pi-type with numeric domain, so it does not accept " ++
+>         renderMe (NumLam n t)
+
+> checkInfer Nothing (NumLam n t) = do
+>     a <- fresh (UserVar Pi) n KNum Fixed -- should this be |Exists|?
+>     b ::: ty <- withLayer False False (LamBody (n ::: tyInteger)) $ inferRho (rawCoerce t)
+>     return $ NumLam n (bindTm a b) ::: Bind Pi n KNum (bindTy a ty)
+
+> checkInfer mty (Let ds t) = do
+>     (ds', bs) <- checkLocalDecls ds
+>     t' ::: ty <- withLayer False False (LetBody bs) $
+>                     checkInfer mty t
+>     return $ Let ds' t' ::: ty
+
+> checkInfer mty (t :? xty) = do
+>     sc  <- checkKind KSet All B0 xty
+>     t'  <- checkSigma sc t
+>     r   <- instSigma sc mty
+>     return $ (t' :? sc) ::: r
+
+> checkInfer (Just r) (Case t as) = do
+>     t' ::: ty <- inferRho t
+>     as' <- traverse (checkCaseAlt ty r) as
+>     return $ Case t' as' ::: r
+
+> checkInfer Nothing (Case t as) = do
+>     t' ::: ty    <- inferRho t
+>     as' ::: tys  <- unzipAsc <$> traverse (inferCaseAlt ty) as
+>     r            <- unifyList tys
+>     return (Case t' as' ::: r)
+
+> checkInfer _ (TmBrace _) = erk "Braces aren't cool"
+
+
+> checkLocalHypotheses :: TmLayer -> Contextual ()
+> checkLocalHypotheses l = modifyContext (help False)
+>   where
+>     help :: Bool -> Context -> Context
+>     help z (g :< Layer l' b) | matchLayer l l'  = g :< Layer l' (b || z)
+>     help _ (g :< Layer l' True)                 = g :< Layer l' True
+>     help _ (g :< e@(Constraint Given _))        = help True g :< e
+>     help z (g :< e)                             = help z g :< e
+>     help _ B0                                   = error "checkLocalHypotheses: empty!"
+
+-- This is horrible, please improve it
+
+> checkCaseAlt :: Rho -> Rho -> SCaseAlternative () -> Contextual (CaseAlternative ())
+> checkCaseAlt sty resty c@(CaseAlt p gt) =
+>   inLocation (text "in case alternative" <++> prettyHigh c) $
+>   withLayer False True CaseTop $ do
+>     ca <- checkPat True (sty --> resty) (p :! P0) $ \ (p' :! P0) vs rty -> do
+>       checkLocalHypotheses CaseTop
+>       gt' <- checkGuardTerms rty (rawCoerce gt)
+>       return $ CaseAlt p' (renameTypes1 (renameVS vs) gt')
+>     unifySolveConstraints
+>     solveConstraints
+>     return ca
+
+> inferCaseAlt :: Rho -> SCaseAlternative () -> Contextual (CaseAlternative () ::: Rho)
+> inferCaseAlt sty c@(CaseAlt p gt) = do
+>   resty <- unknownTyVar "_r" KSet
+>   inLocation (text "in case alternative" <++> prettyHigh c) $
+>    withLayer False True CaseTop $ do
+>     ca <- checkPat True (sty --> resty) (p :! P0) $ \ (p' :! P0) vs rty -> do
+>       checkLocalHypotheses CaseTop
+>       gt' <- checkGuardTerms rty (rawCoerce gt)
+>       return $ CaseAlt p' (renameTypes1 (renameVS vs) gt')
+>     return $ ca ::: resty
+
+
+> checkLocalDecls :: [SDeclaration ()] -> Contextual ([Declaration ()], Bindings)
+> checkLocalDecls ds =
+>     withLayerExtract False False (LetBindings Map.empty) letBindings $ do
+>         mapM_ (makeBinding False) ds
+>         Data.List.concat <$> traverse checkInferDecl ds  
+
+> makeBinding :: Bool -> SDeclaration () -> Contextual ()
+> makeBinding defd (SigDecl x ty) = inLocation (text $ "in binding " ++ x) $ do
+>     bs <- tyVarNamesInScope
+>     TK ty' k <- inferKind All B0 (wrapForall bs ty)
+>     case k of
+>         KSet  -> insertBinding x (Just ty', defd)
+>         _     -> errKindNotSet (fogKind k)
+> makeBinding _ (FunDecl _ _)       = return ()
+
+> checkInferDecl :: SDeclaration () -> Contextual [Declaration ()]
+> checkInferDecl (FunDecl s []) =
+>   inLocation (text $ "in declaration of " ++ s) $ erk $ "No alternative"
+> checkInferDecl (FunDecl s (p:ps)) = do
+>     when (not (null ps) && isVarAlt p) $ errDuplicateTmVar s
+>     mty <- optional $ lookupBinding s
+>     case mty of
+>         Just (_ ::: ty, False)  -> (\ x -> [FunDecl s x]) <$> checkFunDecl ty ty s (p:ps)
+>         Just (_, True) -> errDuplicateTmVar s
+>         Nothing          -> do
+>             (fd, ty) <- inferFunDecl s (p:ps)
+>             updateBinding s (Just ty, True)
+>             return [SigDecl s ty, FunDecl s fd]
+> checkInferDecl (SigDecl x _) = do
+>     _ ::: ty <- fst <$> lookupBinding x
+>     return [SigDecl x ty]
+
+> inferFunDecl :: String -> [SAlternative ()] -> Contextual ([Alternative ()], Type KSet)
+> inferFunDecl s pats =
+>   inLocation (text $ "in declaration of " ++ s) $ withLayer True True FunTop $ do
+>     sty     <- unknownTyVar "_x" KSet
+>     pattys  <- traverse (inferAlt (s ::: sty)) pats
+>     let ptms ::: ptys = unzipAsc pattys
+>     mapM_ (unify sty) ptys
+>     (ty', ptms') <- generalise sty ptms
+>     return (ptms', simplifyTy ty')
+
+> checkFunDecl :: Sigma -> Sigma -> String -> [SAlternative ()] ->
+>                     Contextual [Alternative ()]
+> checkFunDecl sty ty s pats =
+>   inLocation (text $ "in declaration of " ++ s) $ withLayer True True FunTop $ do
+>         ptms <- traverse (checkAlt (s ::: sty) ty) pats
+>         (_, ptms') <- generalise (TyCon "Fake" KSet) ptms
+>         return ptms'
+
+
+
+
+
+> checkAlt :: String ::: Sigma -> Sigma -> SAlternative () -> Contextual (Alternative ())
+> checkAlt (s ::: sc) ty (Alt xs gt) =
+>   inLocation (text "in alternative" <++> (text s <+> prettyHigh (Alt xs gt))) $
+>   withLayer True True (PatternTop (s ::: ty)) $ do
+>     sty <- specialise sc
+>     checkPat True sty xs $ \ xs' vs rty -> do
+>       gt' <- checkGuardTerms rty (rawCoerce gt)
+>       unifySolveConstraints
+>       solveConstraints
+>       return $ Alt xs' (renameTypes1 (renameVS vs) gt')
+
+
+> inferAlt :: String ::: Sigma -> SAlternative () ->
+>                 Contextual (Alternative () ::: Rho)
+> inferAlt (s ::: sc) (Alt xs gt) =
+>   inLocation (text "in alternative" <++> (text s <+> prettyHigh (Alt xs gt))) $
+>   withLayer True True (PatternTop (s ::: sc)) $
+>     inferPat (rawCoerce gt) xs $ \ xs' vs (gt' ::: _) ty -> do
+>       unifySolveConstraints
+>       solveOrSuspend
+>       return $ Alt xs' (renameTypes1 (renameVS vs) gt') ::: ty
+
+
+> checkGuardTerms :: Rho -> SGuardTerms () -> Contextual (GuardTerms ())
+> checkGuardTerms rho (Unguarded t ds)  = do
+>     (ds', bs) <- checkLocalDecls ds
+>     withLayer False False (LetBody bs) $ do
+>         t' <- checkRho rho t
+>         unifySolveConstraints
+>         solveOrSuspend
+>         return $ Unguarded t' ds'
+> checkGuardTerms rho (Guarded gts ds)  = do
+>     (ds', bs) <- checkLocalDecls ds
+>     withLayer False False (LetBody bs) $ do
+>         Guarded <$> traverse chk gts <*> pure ds'
+>   where
+>     chk (g :*: t) = withLayer False True GuardTop $ do
+>         g' <- checkGuard g
+>         checkLocalHypotheses GuardTop
+>         t' <- checkRho rho t
+>         unifySolveConstraints
+>         solveOrSuspend
+>         return $ g' :*: t'
+
+
+> inferGuardTerms :: SGuardTerms () -> Contextual (GuardTerms () ::: Rho)
+> inferGuardTerms (Unguarded e ds) = do
+>     (ds', bs) <- checkLocalDecls ds
+>     withLayer False False (LetBody bs) $ do
+>         e' ::: r <- inferRho e
+>         return $ Unguarded e' ds' ::: r
+> inferGuardTerms (Guarded gts ds) = do
+>     (ds', bs) <- checkLocalDecls ds
+>     withLayer False False (LetBody bs) $ do
+>         xs <- traverse (\ (g :*: t) -> do
+>                           g' <- checkGuard g 
+>                           t' ::: r <- inferRho t
+>                           return $ (g' :*: t') ::: r) gts
+>         let gts' ::: tys = unzipAsc xs
+>         ty <- unifyList tys
+>         return $ Guarded gts' ds' ::: ty
+
+
+> checkGuard :: SGuard () -> Contextual (Guard ())
+> checkGuard (NumGuard ps)  = NumGuard <$> traverse learnPred ps
+>   where
+>     learnPred p = do
+>       p' <- checkPredKind Pi B0 p
+>       modifyContext (:< Constraint Given (predToConstraint p'))
+>       return p'
+> checkGuard (ExpGuard ts)   = ExpGuard <$> traverse (checkRho tyBool) ts
+
+ 
+
+
+> checkPat :: Bool -> Rho -> SPatternList o a ->
+>               (forall b x . PatternList () b -> VarSuffix () b x -> Rho -> Contextual p) ->
+>                 Contextual p
+
+> checkPat _ ty P0 q = q P0 VS0 ty
+
+> checkPat top ty (PatVar v :! ps) q = do
+>     (dom, cod) <- unifyFun ty
+>     withLayer False False (LamBody (v ::: dom)) $
+>         checkPat top cod ps $ \ ps' vs r ->
+>             q (PatVar v :! ps') vs r
+
+> checkPat top ty (PatCon c as :! ps) q = do
+>     (cty, dom, cod) <- inLocation (text "in pattern" <++> prettyHigh (PatCon c as)) $ do
+>         (dom, cod) <- unifyFun ty
+>         sc   <- lookupTmCon c
+>         cty  <- existentialise $ instS SysVar Given Hole sc
+>         unless (patLength as == args cty) $
+>             errConUnderapplied c (args cty) (patLength as)
+>         return (cty, dom, cod)
+>     checkPat False cty as $ \ as' avs s -> do
+>         unify dom s
+>         checkPat top cod ps $ \ ps' pvs r ->
+>             renameTypes2 (renameVS avs) pvs ps' $ \ pvs' ps'' ->
+>                 extComp avs pvs' $ \ vs ->
+>                     q (PatCon c as' :! ps'') vs r
+
+> checkPat top ty (PatIgnore :! ps) q = do
+>     (_, cod) <- unifyFun ty
+>     checkPat top cod ps $ \ ps' vs r ->
+>         q (PatIgnore :! ps') vs r
+
+> checkPat top ty (PatIntLit i :! ps) q = do
+>     (dom, cod) <- unifyFun ty
+>     modifyContext (:< Constraint Wanted (TyCon "Num" (KSet :-> KConstraint) `TyApp` dom))
+>     checkPat top cod ps $ \ ps' vs r ->
+>         q (PatIntLit i :! ps') vs r
+
+> checkPat top ty (PatCharLit c :! ps) q = do
+>     (dom, cod) <- unifyFun ty
+>     unify dom tyChar
+>     checkPat top cod ps $ \ ps' vs r ->
+>         q (PatCharLit c :! ps') vs r
+
+> checkPat top ty (PatStrLit s :! ps) q = do
+>     (dom, cod) <- unifyFun ty
+>     unify dom tyString
+>     checkPat top cod ps $ \ ps' vs r ->
+>         q (PatStrLit s :! ps') vs r
+
+> checkPat top ty (PatNPlusK n k :! ps) q = do
+>     (dom, cod) <- unifyFun ty
+>     unify dom tyInteger
+>     withLayer False False (LamBody (n ::: tyInteger)) $ 
+>         checkPat top cod ps $ \ ps' vs r ->
+>             q (PatNPlusK n k :! ps') vs r
+
+> checkPat top (Bind Pi x KNum t) (PatBraceK k :! ps) q = do
+>     b        <- fresh SysVar x KNum (Some (TyInt k))
+>     aty      <- instS (UserVar All) Given Fixed (unbindTy b t)
+>     checkPat top aty ps $ \ ps' vs r -> 
+>         q (PatBraceK k :! ps') vs r
+
+> checkPat top (Bind Pi _ KNum t) (PatBrace a 0 :! ps) q =
+>   withLayer False False (LamBody (a ::: tyInteger)) $ do
+>     b <- freshVar (UserVar Pi) a KNum
+>     let  t'  = unbindTy b t
+>          d   = if top || b `elemTarget` t'
+>                    then Fixed
+>                    else Exists
+>     modifyContext (:< A (b := d))
+>     aty      <- instS (UserVar All) Given Fixed t'
+>     checkPat top aty ps $ \ ps' vs r ->
+>       bindUn b vs ps' $ \ vs' ps'' ->
+>         extComp (VS0 :<< error "woony") vs' $ \ vs'' ->
+>           q (PatBrace a 0 :! ps'') vs'' r
+
+> checkPat top (Bind Pi x KNum t) (PatBrace a k :! ps) q = 
+>   withLayer False False (LamBody (a ::: tyInteger)) $ do
+>     b <- freshVar SysVar ("_" ++ x ++ "_" ++ a ++ "_" ++ "oo") KNum
+>     let  t'  = unbindTy b t
+>          d   = if top || b `elemTarget` t'
+>                       then Fixed
+>                       else Exists
+>     am <- fresh (UserVar Pi) a KNum d
+>     modifyContext (:< A (b := Some (TyVar am + TyInt k)))
+>     modifyContext (:< Constraint Given (tyPred LE 0 (TyVar am)))
+>     aty      <- instS (UserVar All) Given Fixed t'
+>     checkPat top aty ps $ \ ps' vs r -> 
+>       bindUn am vs ps' $ \ vs' ps'' ->
+>         extComp (VS0 :<< error "woony") vs' $ \ vs'' ->
+>           q (PatBrace a k :! ps'') vs'' r
+
+> checkPat _ ty (p :! _) _ =
+>     erk $ "checkPat: couldn't match pattern " ++ renderMe p
+>                ++ " against type " ++ renderMe (fogSysTy ty)
+
+
+
+> inferPat :: SGuardTerms () -> SPatternList o a ->
+>     (forall b x . PatternList () b -> VarSuffix () b x -> GuardTerms () ::: Rho -> Rho -> Contextual p) ->
+>                 Contextual p
+
+> inferPat t P0 q = do
+>     t' ::: r <- inferGuardTerms t
+>     q P0 VS0 (t' ::: r) r
+
+> inferPat top (PatVar v :! ps) q = do
+>     a <- unknownTyVar "_a" KSet
+>     withLayer False False (LamBody (v ::: a)) $
+>         inferPat top ps $ \ ps' vs tr ty -> 
+>             q (PatVar v :! ps') vs tr (a --> ty)
+
+> inferPat top (PatCon c as :! ps) q = do
+>     cty <- inLocation (text "in pattern" <++> prettyHigh (PatCon c as)) $ do
+>         sc   <- lookupTmCon c
+>         cty  <- existentialise $ instS SysVar Given Hole sc
+>         unless (patLength as == args cty) $
+>             errConUnderapplied c (args cty) (patLength as)
+>         return cty
+>     checkPat False cty as $ \ as' yvs s ->
+>       inferPat top ps $ \ ps' xvs tr ty ->
+>         renameTypes2 (renameVS yvs) xvs ps' $ \ xvs' ps'' ->
+>           extComp yvs xvs' $ \ vs ->
+>             q (PatCon c as' :! ps'') vs tr (s --> ty)
+
+> inferPat top (PatIgnore :! ps) q = do
+>     b <- unknownTyVar "_b" KSet
+>     inferPat top ps $ \ ps' vs tr ty ->
+>         q (PatIgnore :! ps') vs tr (b --> ty)
+
+> inferPat top (PatIntLit i :! ps) q = do
+>     a <- unknownTyVar "_a" KSet
+>     modifyContext (:< Constraint Wanted (TyCon "Num" (KSet :-> KConstraint) `TyApp` a))
+>     inferPat top ps $ \ ps' vs tr ty ->
+>         q (PatIntLit i :! ps') vs tr (a --> ty)
+
+> inferPat top (PatCharLit c :! ps) q = do
+>     inferPat top ps $ \ ps' vs tr ty ->
+>         q (PatCharLit c :! ps') vs tr (tyChar --> ty)
+
+> inferPat top (PatStrLit s :! ps) q = do
+>     inferPat top ps $ \ ps' vs tr ty ->
+>         q (PatStrLit s :! ps') vs tr (tyString --> ty)
+
+> inferPat top (PatNPlusK n k :! ps) q = 
+>     withLayer False False (LamBody (n ::: tyInteger)) $ 
+>         inferPat top ps $ \ ps' vs tr ty ->
+>             q (PatNPlusK n k :! ps') vs tr (tyInteger --> ty)
+
+> inferPat top (PatBrace a 0 :! ps) q = do
+>     n <- fresh (UserVar Pi) a KNum Exists
+>     withLayer True True GenMark $ withLayer False False (LamBody (a ::: tyInteger)) $
+>       inferPat top ps $ \ ps' vs tr ty -> do
+>         (ty', _) <- generalise ty ([] :: [Alternative ()])
+>         bindUn n vs ps' $ \ vs' ps'' ->
+>           extComp (VS0 :<< error "woony") vs' $ \ vs'' ->
+>             q (PatBrace a 0 :! ps'') vs'' tr
+>                 (Bind Pi a KNum (bindTy n ty'))
+
+> inferPat _ (p :! _) _ =
+>     erk $ "inferPat: couldn't infer type of pattern " ++ renderMe p
diff --git a/src/Language/Inch/Unify.lhs b/src/Language/Inch/Unify.lhs
new file mode 100644
--- /dev/null
+++ b/src/Language/Inch/Unify.lhs
@@ -0,0 +1,284 @@
+> {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GADTs,
+>              RankNTypes, PatternGuards #-}
+
+> module Language.Inch.Unify where
+
+> import Control.Applicative
+> import Control.Monad hiding (mapM_)
+> import Data.Foldable hiding (elem)
+> import Data.List
+> import Data.Maybe
+> import Prelude hiding (any, mapM_)
+> import Text.PrettyPrint.HughesPJ
+
+> import Language.Inch.BwdFwd
+> import Language.Inch.Kind
+> import Language.Inch.Type
+> import Language.Inch.TyNum
+> import Language.Inch.Context
+> import Language.Inch.Kit
+> import Language.Inch.Error
+> import Language.Inch.PrettyPrinter
+> import Language.Inch.Check
+
+> data Extension = Restore | Replace Suffix
+
+> onTop ::  (forall k. TyEntry k -> Contextual Extension)
+>             -> Contextual ()
+> onTop f = do
+>     c <- getContext
+>     case c of
+>         _Gamma :< A alphaD -> do
+>             putContext _Gamma
+>             ext (A alphaD) =<< f alphaD
+>         _Gamma :< xD -> do
+>             putContext _Gamma
+>             onTop f
+>             modifyContext (:< xD)
+>         B0 -> erk $ "onTop: ran out of context"
+
+> onTopNum ::  (Type KConstraint, Contextual ()) ->
+>                  (TyEntry KNum -> Contextual Extension) ->
+>                  Contextual ()
+> onTopNum (p, m) f = do
+>   g <- getContext
+>   case g of
+>     _Gamma :< xD -> do  
+>       putContext _Gamma
+>       case xD of
+>         A (a@(FVar _ KNum) := d) -> ext xD =<< f (a := d)
+>         Layer l True -> do
+>             modifyContext (:< Layer l True)
+>             m
+>             modifyContext (:< Constraint Wanted p)
+>         _ -> onTopNum (p, m) f >> modifyContext (:< xD)
+>     B0 -> inLocation (text "when solving" <+> prettyHigh (fogSysTy p)) $
+>               erk $ "onTopNum: ran out of context"
+
+> restore :: Contextual Extension
+> restore = return Restore
+
+> replace :: Suffix -> Contextual Extension
+> replace = return . Replace
+
+> ext :: Entry -> Extension -> Contextual ()
+> ext _  (Replace _Xi)  = modifyContext (<>< _Xi)
+> ext xD Restore        = modifyContext (:< xD)
+
+
+
+> unifyList :: KindI k => [Type k] -> Contextual (Type k)
+> unifyList []      = unknownTyVar "_ul" kind
+> unifyList (t:ts)  = mapM_ (unify t) ts >> return t
+
+
+> unify :: Type k -> Type k -> Contextual ()
+> unify t u = do
+>     verifyContext True "unify"
+>     t' <- expandTySyns t
+>     u' <- expandTySyns u
+>     unifyTypes t' u' `inLoc` (do
+>         return $ sep [text "when unifying", nest 4 (prettyHigh $ fogSysTy t),
+>                       text "and", nest 4 (prettyHigh $ fogSysTy u)])
+
+> unifyTypes :: Type k -> Type k -> Contextual ()
+> -- unifyTypes s t | s == t = return ()
+> unifyTypes Arr Arr  = return ()
+> unifyTypes s t | KNum <- getTyKind s = unifyNum s t
+> unifyTypes (TyVar alpha) (TyVar beta) = onTop $
+>   \ (gamma := d) ->
+>     hetEq gamma alpha
+>       (hetEq gamma beta
+>         restore
+>         (case d of
+>           Hole      ->  replace (TE (alpha := Some (TyVar beta)) :> F0)
+>           Some tau  ->  do  tau' <- expandTySyns tau
+>                             unifyTypes (TyVar beta) tau'
+>                             restore
+>           _         ->  solve beta (TE (alpha := d) :> F0) (TyVar alpha)
+>                             >> replace F0
+>         )
+>       )
+>       (hetEq gamma beta
+>         (case d of
+>           Hole      ->  replace (TE (beta := Some (TyVar alpha)) :> F0)
+>           Some tau  ->  do  tau' <- expandTySyns tau
+>                             unifyTypes (TyVar alpha) tau'
+>                             restore
+>           _         ->  solve alpha (TE (beta := d) :> F0) (TyVar beta)
+>                             >> replace F0
+>         )
+>         (unifyTypes (TyVar alpha)  (TyVar beta)  >> restore)
+>       )
+
+> unifyTypes (TyCon c1 _) (TyCon c2 _)
+>     | c1 == c2   = return ()
+>     | otherwise  = erk $ "Mismatched type constructors " ++ c1
+>                               ++ " and " ++ c2
+
+> unifyTypes (TyApp f1 s1) (TyApp f2 s2) =
+>     hetEq (getTyKind f1) (getTyKind f2)
+>         (unifyTypes f1 f2 >> unifyTypes s1 s2)
+>         (erk "Mismatched kinds")
+
+> unifyTypes (UnOp o)       (UnOp o')    | o == o' = return ()
+> unifyTypes (BinOp o)      (BinOp o')   | o == o' = return ()
+> unifyTypes (TyComp c)     (TyComp c')  | c == c' = return ()
+
+> unifyTypes (TyVar alpha)  tau            = startSolve alpha tau
+> unifyTypes tau            (TyVar alpha)  = startSolve alpha tau
+> unifyTypes tau            upsilon        = errCannotUnify (fogTy tau) (fogTy upsilon)
+
+
+
+> startSolve :: Var () k -> Type k -> Contextual ()
+> startSolve alpha tau = do
+>     (rho, xs) <- rigidHull [] tau
+>     -- traceContext $ "sS\nalpha = " ++ show alpha ++ "\ntau = " ++ show tau ++ "\nrho = " ++ show rho ++ "\nxs = " ++ show xs
+>     solve alpha (pairsToSuffix xs) rho
+>     -- traceContext $ "sS2"
+>     unifyPairs xs
+
+> type FlexConstraint = (Var () KNum, TypeNum, TypeNum)
+
+> makeFlex :: [Var () KNum] -> Type KNum ->
+>                 Contextual (Type KNum, Fwd FlexConstraint)
+> makeFlex as n = do
+>     let n' = normaliseNum n
+>     let (l, r) = partitionNum as n'
+>     if isZero r
+>         then return (n, F0)
+>         else do
+>             v <- freshVar SysVar "_i" KNum
+>             -- traceContext $ "mF\nas = " ++ show as ++ "\nn = " ++ show n ++ "\nl' = " ++ show l' ++ "\nr' = " ++ show r'
+>             return (reifyNum (mkVar v + l), (v, TyVar v, reifyNum r) :> F0)
+
+
+
+> rigidHull :: [Var () KNum] -> Type k ->
+>                  Contextual (Type k, Fwd FlexConstraint)
+
+> rigidHull as t | KNum <- getTyKind t = makeFlex as t
+
+> rigidHull _  (TyVar a)    = return (TyVar a, F0)
+> rigidHull _  (TyCon c k)  = return (TyCon c k, F0)
+> rigidHull _  Arr          = return (Arr, F0)
+> rigidHull _  (UnOp o)     = return (UnOp o, F0)
+> rigidHull _  (BinOp o)    = return (BinOp o, F0)
+> rigidHull _  (TyComp c)   = return (TyComp c, F0)
+
+> rigidHull as (TyApp f s)  = do  (f',  xs  )  <- rigidHull as f
+>                                 (s',  ys  )  <- rigidHull as s
+>                                 return (TyApp f' s', xs <.> ys)
+
+> rigidHull as (Bind b x KNum t) = do
+>     v <- freshVar SysVar "_magical" KNum
+>     (t', cs) <- rigidHull (v:as) (unbindTy v t)
+>     return (Bind b x KNum (bindTy v t'), cs)
+
+> rigidHull as (Bind All x k b) | not (k =?= KNum) = do
+>     v <- freshVar SysVar "_magic" k
+>     (t, cs) <- rigidHull as (unbindTy v b)
+>     return (Bind All x k (bindTy v t), cs)
+
+This is wrong, I think:
+
+> rigidHull as (Qual p t) = (\ (u, cs) -> (Qual p u, cs)) <$> rigidHull as t
+
+> rigidHull _ b = erk $ "rigidHull can't cope with " ++ renderMe (fogSysTy b)
+
+
+
+> pairsToSuffix :: Fwd FlexConstraint -> Suffix
+> pairsToSuffix = fmap (TE . (:= Hole) . fst3)
+>   where fst3 (a, _, _) = a
+
+> unifyPairs :: Fwd FlexConstraint -> Contextual ()
+> unifyPairs = mapM_ (uncurry unifyNum . snd3)
+>   where snd3 (_, b, c) = (b, c)
+
+
+> solve :: Var () k -> Suffix -> Type k -> Contextual ()
+> solve alpha _Xi tau = onTop $
+>   \ (gamma := d) -> let occurs = gamma <? tau || gamma <? _Xi in
+>     hetEq gamma alpha
+>       (if occurs
+>          then erk $ "Occurrence of " ++ fogSysVar alpha
+>                     ++ " detected when unifying with "
+>                     ++ renderMe (fogTy tau)
+>          else case d of
+>            Hole          ->  replace (_Xi <.> (TE (alpha := Some tau) :> F0))
+>            Some upsilon  ->  do  modifyContext (<>< _Xi)
+>                                  upsilon' <- expandTySyns upsilon
+>                                  unifyTypes upsilon' tau
+>                                  restore
+>            _             ->  errUnifyFixed alpha tau
+>       )
+>       (if occurs
+>         then case d of
+>           Some upsilon  ->  do
+>             upsilon' <- expandTySyns upsilon
+>             (upsilon'', xs) <- rigidHull [] upsilon'
+>             solve alpha (pairsToSuffix xs <.> (TE (gamma := Some upsilon'') :> _Xi)) tau
+>             unifyPairs xs
+>             replace F0
+>           _             ->  solve alpha (TE (gamma := d) :> _Xi) tau
+>                                         >>  replace F0   
+>         else solve alpha _Xi tau >>  restore
+>       )
+
+
+
+> unifyNum :: TypeNum -> TypeNum -> Contextual ()
+> unifyNum (TyInt 0)  n = unifyZero F0 (normaliseNum n)
+> unifyNum m          n = unifyZero F0 (normaliseNum (m - n))
+
+> constrainZero :: NormalNum -> Contextual ()
+> constrainZero e = modifyContext (:< Constraint Wanted (tyPred EL (reifyNum e) 0))
+
+> unifyZero :: Suffix -> NormalNum -> Contextual ()
+> unifyZero _Psi e = case getConstant e of
+>   Just k  | k == 0     -> return ()
+>           | otherwise  -> errCannotUnify (fogTy (reifyNum e)) (STyInt 0)
+>   Nothing              -> onTopNum (tyPred EL (reifyNum e) 0, modifyContext (<>< _Psi)) $
+>     \ (a := d) ->
+>       case (d, solveFor a e) of
+>         (Some t,  _)           -> do  modifyContext (<>< _Psi)
+>                                       t' <- expandTySyns t
+>                                       unifyZero F0 (substNum a t' e)
+>                                       restore
+>         (_,       Absent)      -> do  unifyZero _Psi e
+>                                       restore
+>         (Hole,    Solve n)     -> do  modifyContext (<>< _Psi)
+>                                       replace $ TE (a := Some (reifyNum n)) :> F0
+>         (Hole,    Simplify n)  -> do  modifyContext (<>< _Psi)
+>                                       (p, b) <- insertFreshVar n
+>                                       let p' = reifyNum p
+>                                       unifyZero (TE (b := Hole) :> F0) $ substNum a p' e
+>                                       replace $ TE (a := Some p') :> F0
+>         _  | varsLeft -> do
+>                          unifyZero (TE (a := d) :> _Psi) e
+>                          replace F0
+>            | otherwise -> do
+>                modifyContext (:< A (a := d))
+>                modifyContext (<>< _Psi)
+>                constrainZero e
+>                replace F0
+>           where varsLeft = not . null $ vars e \\ (Ex a : vars _Psi)
+
+We can insert a fresh variable into a unit thus:
+
+> insertFreshVar :: NormalNum -> Contextual (NormalNum, Var () KNum)
+> insertFreshVar d = do
+>     v <- freshVar SysVar "_beta" KNum
+>     return (d + mkVar v, v)
+
+
+
+> unifyFun :: Rho -> Contextual (Sigma, Rho)
+> unifyFun (TyApp (TyApp Arr s) t) = return (s, t)
+> unifyFun ty = do
+>     s <- unknownTyVar "_s" KSet
+>     t <- unknownTyVar "_t" KSet
+>     unify (s --> t) ty
+>     return (s, t)
diff --git a/tests/Main.lhs b/tests/Main.lhs
new file mode 100644
--- /dev/null
+++ b/tests/Main.lhs
@@ -0,0 +1,573 @@
+> module Main where
+
+> import Control.Applicative
+> import Control.Monad.State
+> import Data.List
+> import System.Directory
+> import System.Exit
+
+> import Language.Inch.Context
+> import Language.Inch.Syntax
+> import Language.Inch.ModuleSyntax
+> import Language.Inch.Parser
+> import Language.Inch.PrettyPrinter
+> import Language.Inch.ProgramCheck
+> import Language.Inch.Erase
+> import Language.Inch.File (checkFile, readImports)
+
+> main :: IO ()
+> main = checks "examples/" >> erases "examples/"
+
+> checks :: FilePath -> IO ()
+> checks = testDir check
+
+> erases :: FilePath -> IO ()
+> erases = testDir erase
+
+> testDir :: (FilePath -> IO ()) -> FilePath -> IO ()
+> testDir f d = do
+>     fns <- sort . filter (".hs" `isSuffixOf`) <$> getDirectoryContents d
+>     mapM_ (f . (d ++)) fns
+
+> check :: FilePath -> IO ()
+> check fn = do
+>     putStrLn $ "TEST " ++ show fn
+>     s <- readFile fn
+>     (md, _) <- checkFile fn s 
+>     putStrLn $ renderMe (fog md)
+
+> erase :: FilePath -> IO ()
+> erase fn = do
+>     putStrLn $ "TEST " ++ show fn
+>     s <- readFile fn
+>     (md, st) <- checkFile fn s
+>     case evalStateT (eraseModule md) st of
+>         Right md'  -> putStrLn $ renderMe (fog md')
+>         Left err   -> putStrLn ("erase error:\n" ++ renderMe err) >> exitFailure
+
+
+
+
+> test :: (a -> String) -> (a -> Either String String)
+>             -> [a] -> Int -> Int -> IO (Int, Int)
+> test _ _ [] yes no = do
+>     putStrLn $ "Passed " ++ show yes ++ " tests, failed "
+>                          ++ show no ++ " tests."
+>     return (yes, no)
+> test g f (x:xs) yes no = do
+>     putStrLn $ "TEST\n" ++ g x
+>     case f x of
+>         Right s  -> putStrLn ("PASS\n" ++ s) >> test g f xs (yes+1) no
+>         Left s   -> putStrLn ("FAIL\n" ++ s) >> test g f xs yes (no+1)
+
+
+> roundTripTest, parseCheckTest, eraseCheckTest :: IO ()
+> roundTripTest  = void $ test id roundTrip roundTripTestData 0 0
+> parseCheckTest = do
+>     ds <- readImports "examples/" []
+>     void $ test fst (parseCheck ds) parseCheckTestData 0 0
+> eraseCheckTest = do
+>     ds <- readImports "examples/" []
+>     void $ test id (eraseCheck ds) (map fst . filter snd $ parseCheckTestData) 0 0
+
+> roundTrip :: String -> Either String String
+> roundTrip s = case parseModule "roundTrip" s of
+>     Right md  ->
+>         let s' = renderMe md in
+>         case parseModule "roundTrip2" s' of
+>             Right md'
+>               | md == md'  -> Right $ renderMe md'
+>               | otherwise      -> Left $ "Round trip mismatch:"
+>                     ++ "\n" ++ s' ++ "\n" ++ renderMe md'
+>                     ++ "\n" ++ show md ++ "\n" ++ show md'
+>                     -- ++ "\n" ++ show prog ++ "\n" ++ show prog'
+>             Left err -> Left $ "Round trip re-parse:\n"
+>                                    ++ s' ++ "\n" ++ show err
+>     Left err -> Left $ "Initial parse:\n" ++ s ++ "\n" ++ show err
+
+> parseCheck :: [STopDeclaration] -> (String, Bool) -> Either String String
+> parseCheck ds (s, b) = case parseModule "parseCheck" s of
+>     Right md   -> case evalStateT (checkModule md ds) initialState of
+>         Right md'
+>             | b          -> Right $ "Accepted good program:\n"
+>                                     ++ renderMe (fog md') ++ "\n"
+>             | otherwise  -> Left $ "Accepted bad program:\n"
+>                                     ++ renderMe (fog md') ++ "\n"
+>         Left err
+>             | b          -> Left $ "Rejected good program:\n"
+>                             ++ renderMe md ++ "\n" ++ renderMe err ++ "\n"
+>             | otherwise  -> Right $ "Rejected bad program:\n"
+>                             ++ renderMe md ++ "\n" ++ renderMe err ++ "\n"
+>     Left err  -> Left $ "Parse error:\n" ++ s ++ "\n" ++ show err ++ "\n"
+
+> eraseCheck :: [STopDeclaration] -> String -> Either String String
+> eraseCheck ds s = case parseModule "eraseCheck" s of
+>     Right md   -> case runStateT (checkModule md ds) initialState of
+>         Right (md', st) -> case evalStateT (eraseModule md') st of
+>             Right md'' -> case evalStateT (checkModule (fog md'') ds) initialState of
+>                 Right md''' -> case parseModule "eraseCheckRoundTrip" (renderMe (fog md''')) of
+>                     Right md'''' -> Right $ "Erased program:\n" ++ renderMe md''''
+>                     Left err -> Left $ "Erased program failed to round-trip:\n" ++ renderMe (fog md''') ++ "\n" ++ show err
+>                 Left err -> Left $ "Erased program failed to type check:\n" ++ renderMe (fog md'') ++ "\n" ++ renderMe err
+>             Left err        -> Left $ "Erase error:\n" ++ s ++ "\n" ++ renderMe err ++ "\n"
+
+>         Left err -> Right $ "Skipping rejected program:\n"
+>                             ++ s ++ "\n" ++ renderMe err ++ "\n"
+>     Left err  -> Left $ "Parse error:\n" ++ s ++ "\n" ++ show err ++ "\n"
+
+
+> roundTripTestData :: [String]
+> roundTripTestData = 
+>   "f = x" :
+>   "f = a b" :
+>   "f = \\ x -> x" :
+>   "f = \\ x y z -> a b c" :
+>   "f = a\ng = b" :
+>   "f = x (y z)" :
+>   "f = a\n b" :
+>   "f = x :: a" :
+>   "f = x :: a -> b -> c" :
+>   "f = x :: Foo" :
+>   "f = x :: Foo a" :
+>   "f = x :: (->)" :
+>   "f = x :: (->) a b" :
+>   "f = x :: F a -> G b" :
+>   "f = \\ x -> x :: a -> b" :
+>   "f = (\\ x -> x) :: a -> b" :
+>   "f = x :: forall (a :: *) . a" :
+>   "f = x :: forall a . a" :
+>   "f = x :: forall a b c . a" :
+>   "f = x :: forall (a :: Num)b(c :: * -> *)(d :: *) . a" :
+>   "f = x :: forall a b . pi (c :: Num) d . b -> c" :
+>   "f = x :: forall (a b c :: *) . a" :
+>   "f x y z = x y z" :
+>   "f Con = (\\ x -> x) :: (->) a a" :
+>   "f Con = \\ x -> x :: (->) a" :
+>   "f = f :: (forall a . a) -> (forall b. b)" : 
+>   "f x y = (x y :: Nat -> Nat) y" :
+>   "plus Zero n = n\nplus (Suc m) n = Suc (plus m n)" :
+>   "data Nat where Zero :: Nat\n Suc :: Nat -> Nat" :
+>   "data Foo :: (* -> *) -> (Num -> *) where Bar :: forall (f :: * -> *)(n :: Num) . (Vec (f Int) n -> a b) -> Foo f n" :
+>   "data Vec :: Num -> * -> * where\n Nil :: forall a. Vec 0 a\n Cons :: forall a (m :: Num). a -> Vec m a -> Vec (m+1) a" :
+>   "huh = huh :: Vec (-1) a" :
+>   "heh = heh :: Vec m a -> Vec n a -> Vec (m-n) a" :
+>   "hah = hah :: Foo 0 1 (-1) (-2) m (m+n) (m+1-n+2)" :
+>   "f :: a -> a\nf x = x" :
+>   "f :: forall a. a -> a\nf x = x" :
+>   "f :: forall a.\n a\n -> a\nf x = x" :
+>   "f :: forall m n. m <= n => Vec m\nf = f" :
+>   "f :: forall m n. (m) <= (n) => Vec m\nf = f" :
+>   "f :: forall m n. (m + 1) <= (2 + n) => Vec m\nf = f" :
+>   "f :: forall m n. (m <= n, m <= n) => Vec m\nf = f" :
+>   "f :: forall m n. (m <= n, (m + 1) <= n) => Vec m\nf = f" :
+>   "f :: forall m n. (0 <= n, n <= 10) => Vec m\nf = f" :
+>   "f :: forall m n. (m + (- 1)) <= n => Vec m\nf = f" :
+>   "f :: forall m n. 0 <= -1 => Vec m\nf = f" :
+>   "f :: forall m n. 0 <= -n => Vec m\nf = f" :
+>   "f :: forall m n. m ~ n => Vec m\nf = f" :
+>   "f :: forall m n. m ~ (n + n) => Vec m\nf = f" :
+>   "f :: pi (m :: Num) . Int\nf {0} = Zero\nf {n+1} = Suc f {n}" :
+>   "f x _ = x" :
+>   "f :: forall a. pi (m :: Num) . a -> Vec a\nf {0} a = VNil\nf {n} a = VCons a (f {n-1} a)" :
+>   "x = 0" :
+>   "x = plus 0 1" :
+>   "x = let a = 1\n in a" :
+>   "x = let a = \\ x -> f x y\n in let b = 2\n  in a" :
+>   "x = let y :: forall a. a -> a\n        y = \\ z -> z\n        f = f\n  in y" :
+>   "f :: 0 <= 1 => Integer\nf = 1" :
+>   "f :: forall (m n :: Num) . (m <= n => Integer) -> Integer\nf = f" :
+>   "f :: 0 + m <= n + 1 => Integer\nf = f" :
+>   "f :: 0 < 1 => a\nf = f" :
+>   "f :: 0 > 1 => a\nf = f" :
+>   "f :: (1 >= 0, a + 3 > 7) => a\nf = f" :
+>   "f x | gr x 0 = x" :
+>   "f x | {x > 0} = x" :
+>   "f x | {x > 0, x ~ 0} = x" :
+>   "f x | {x >= 0} = x\n    | {x <  0} = negate x" :
+>   "f :: forall (m :: Nat) . g m\nf = f" :
+>   "f = \\ {x} -> x" :
+>   "f = \\ {x} y {z} -> plus x y" :
+>   "x = case True of  False -> undefined\n                  True -> 3" :
+>   "x = case True of\n      False -> undefined\n      True -> 3" :
+>   "x = case f 1 3 of\n    (Baz boo) -> boo boo" :
+>   "x = case f 1 3 of\n     (Baz boo) -> boo boo\n     (Bif bof) -> bah" :
+>   "x = case f 1 3 of\n    (Baz boo) | {2 ~ 3} -> boo boo" :
+>   "x = case f 1 3 of\n     Baz boo | womble -> boo boo" :
+>   "x = case f 1 3 of\n     Baz boo | {2 ~ 3} -> boo boo" :
+>   "x = case a of\n  Wim -> Wam\n          Wom " :
+>   "f :: g (abs (-6))\nf = f" :
+>   "f :: g (signum (a + b))\nf = f" :
+>   "f :: g (a ^ b + 3 ^ 2)\nf = f" :
+>   "x = 2 + 3" :
+>   "x = 2 - 3" :
+>   "x = - 3" :
+>   "f :: f ((*) 3 2) -> g (+)\nf = undefined" :
+>   "x :: f min\nx = x" :
+>   "data Foo where X :: Foo\n  deriving Show" :
+>   "data Foo where\n    X :: Foo\n  deriving (Eq, Show)" :
+>   "x :: [a]\nx = []" :
+>   "y :: [Integer]\ny = 1 : 2 : [3, 4]" :
+>   "x :: ()\nx = ()" :
+>   "x :: (Integer, Integer)\nx = (3, 4)" :
+>   "f () = ()\ng (x, y) = (y, x)" : 
+>   "f [] = []\nf (x:y:xs) = x : xs" :
+>   "f (_, x:_) = x" : 
+>   "f [x,_] = x" : 
+>   "x = a b : c d : e f" :
+>   "f :: g (2 - 3)" :
+>   "f xs = case xs of\n      [] -> []\n      y:ys -> ys" :
+>   "a = \"hello\"" :
+>   "b = 'w' : 'o' : 'r' : ['l', 'd']" :
+>   "f (_:x) = x" :
+>   "f (_ : x) = x" :
+>   "x = y where y = 3" :
+>   "x = y\n  where\n    y = z\n    z = x" :
+>   "import A.B.C\nimport qualified B\nimport C (x, y)\nimport D as E hiding (z)\nimport F ()" :
+>   "f (n + 1) = n" :
+>   "(&&&) :: Bool -> Bool -> Bool\n(&&&) True x = x\n(&&&) False _ = False" :
+>   "(&&&) :: Bool -> Bool -> Bool\nTrue &&& x = x\nFalse &&& _ = False" :
+>   "f :: _a -> _a\nf x = x" :
+>   "x = (case xs of\n    [] -> []\n    (:) x ys -> scanl f (f q x) ys)" :
+>   "f :: forall (c :: Constraint) . c => Integer\nf = f" :
+>   "f :: Dict ((<=) 2 3) -> Dict (2 <= 3)\nf x = x" :
+>   "f :: Show a => a -> [Char]\nf x = show x" :
+>   "class T a => S a" :
+>   "class (T a) => S a" :
+>   "class (T a, B a a) => S a" :
+>   "class S a where\n  s :: a -> [Char]" :
+>   "class S a where\n  s :: a -> [Char]\n  t :: Integer -> a" :
+>   "instance S [Char] where\n  s x = x\n  f g = 0" :
+>   "x, y :: Integer" :
+>   "instance (S Integer, S a) => S [a] where" :
+>   "instance Monad [] where" :
+>   "type String = [Char]" :
+>   "type F a b = b a" :
+>   "type F (a :: *) (b :: * -> *) = b a" :
+>   "instance N a 0 where" :
+>   []
+
+
+
+> vecDecl, vec2Decl, vec3Decl, natDecl :: String
+
+> vecDecl = "data Vec :: Num -> * -> * where\n"
+>   ++ "  Nil :: forall a (n :: Num). n ~ 0 => Vec n a\n"
+>   ++ "  Cons :: forall a (m n :: Num). (0 <= m, n ~ (m + 1)) => a -> Vec m a -> Vec n a\n"
+>   ++ " deriving (Eq, Show)\n"
+
+> vec2Decl = "data Vec :: * -> Num -> * where\n"
+>   ++ "  Nil :: forall a (n :: Num). n ~ 0 => Vec a n\n"
+>   ++ "  Cons :: forall a (n :: Num). 1 <= n => a -> Vec a (n-1) -> Vec a n\n"
+
+> vec3Decl = "data Vec :: Num -> * -> * where\n"
+>   ++ "  Nil :: forall a . Vec 0 a\n"
+>   ++ "  Cons :: forall a (n :: Num). 0 <= n => a -> Vec n a -> Vec (n+1) a\n"
+
+> natDecl = "data Nat where\n Zero :: Nat\n Suc :: Nat -> Nat\n"
+
+> parseCheckTestData :: [(String, Bool)]
+> parseCheckTestData = 
+>   ("f x = x", True) :
+>   ("f = f", True) :
+>   ("f = \\ x -> x", True) :
+>   ("f = (\\ x -> x) :: forall a. a -> a", True) :
+>   ("f x = x :: forall a b. a -> b", False) :
+>   ("f = \\ x y z -> x y z", True) :
+>   ("f x y z = x (y z)", True) :
+>   ("f x y z = x y z", True) :
+>   ("f x = x :: Foo", False) :
+>   ("f :: a -> a\nf x = x", True) :
+>   ("f :: a\nf = f", True) :
+>   ("f :: forall a b. (a -> b) -> (a -> b)\nf = \\ x -> x", True) :
+>   ("f :: (a -> b -> c) -> a -> b -> c\nf = \\ x y z -> x y z", True) :
+>   ("f :: forall a b c. (b -> c) -> (a -> b) -> a -> c\nf x y z = x (y z)", True) :
+>   ("f :: forall a b c. (a -> b -> c) -> a -> b -> c\nf x y z = x y z", True) :
+>   (natDecl ++ "plus Zero n = n\nplus (Suc m) n = Suc (plus m n)\nf x = x :: Nat -> Nat", True) :
+>   (natDecl ++ "f Suc = Suc", False) :
+>   (natDecl ++ "f Zero = Zero\nf x = \\ y -> y", False) :
+>   ("data List :: * -> * where\n Nil :: forall a. List a\n Cons :: forall a. a -> List a -> List a\nsing = \\ x -> Cons x Nil\nsong x y = Cons x (Cons (sing y) Nil)\nappend Nil ys = ys\nappend (Cons x xs) ys = Cons x (append xs ys)", True) :
+>   ("f :: forall a b. (a -> b) -> (a -> b)\nf x = x", True) :
+>   ("f :: forall a. a\nf x = x", False) :
+>   ("f :: forall a. a -> a\nf x = x :: a", True) :
+>   ("f :: forall a. a -> (a -> a)\nf x y = y", True) :
+>   ("f :: (forall a. a) -> (forall b. b -> b)\nf x y = y", True) :
+>   ("f :: forall b. (forall a. a) -> (b -> b)\nf x y = y", True) :
+>   ("data One where A :: Two -> One\ndata Two where B :: One -> Two", True) :
+>   ("data Foo where Foo :: Foo\ndata Bar where Bar :: Bar\nf Foo = Foo\nf Bar = Foo", False) :
+>   ("data Foo where Foo :: Foo\ndata Bar where Bar :: Bar\nf :: Bar -> Bar\nf Foo = Foo\nf Bar = Foo", False) :
+>   ("f :: forall a (n :: Num) . n ~ n => a -> a\nf x = x", True) :
+>   ("f :: forall a (n :: Num) . n ~ m => a -> a\nf x = x", False) :
+>   (vecDecl ++ "vhead (Cons x xs) = x\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", False) :
+>   (vecDecl ++ "vhead :: forall (n :: Num) a. Vec (1+n) a -> a\nvhead (Cons x xs) = x\nid2 :: forall (n :: Num) a. Vec n a -> Vec n a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", True) :
+>   (vecDecl ++ "append :: forall a (m n :: Num) . (0 <= m, 0 <= n, 0 <= (m + n)) => Vec m a -> Vec n a -> Vec (m+n) a\nappend Nil ys = ys\nappend (Cons x xs) ys = Cons x (append xs ys)", True) :
+>   (vecDecl ++ "append :: forall a (m n :: Num) . 0 <= n => Vec m a -> Vec n a -> Vec (m+n) a\nappend Nil ys = ys\nappend (Cons x xs) ys = Cons x (append xs ys)", True) :
+>   (vecDecl ++ "vtail :: forall (n :: Num) a. Vec (n+1) a -> Vec n a\nvtail (Cons x xs) = xs", True) :
+>   (vecDecl ++ "lie :: forall a (n :: Num) . Vec n a\nlie = Nil", False) :
+>   (vecDecl ++ "vhead :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> a\nvhead (Cons x xs) = x", True) :
+>   (vecDecl ++ "silly :: forall a (m :: Num). m <= -1 => Vec m a -> a\nsilly (Cons x xs) = x", True) :
+>   (vecDecl ++ "silly :: forall a (m :: Num). m <= -1 => Vec m a -> a\nsilly (Cons x xs) = x\nbad = silly (Cons Nil Nil)", False) :
+>   (vecDecl ++ "vhead :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> a\nvhead (Cons x xs) = x\nwrong = vhead Nil", False) :
+>   (vecDecl ++ "vhead :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> a\nvhead (Cons x xs) = x\nright = vhead (Cons Nil Nil)", True) :
+>   (vecDecl ++ "vtail :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> Vec m a\nvtail (Cons x xs) = xs\ntwotails :: forall a (m :: Num). (0 <= m, 0 <= (m+1)) => Vec (m+2) a -> Vec m a \ntwotails xs = vtail (vtail xs)", True) :
+>   (vecDecl ++ "vtail :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> Vec m a\nvtail (Cons x xs) = xs\ntwotails xs = vtail (vtail xs)", True) :
+>   (vecDecl ++ "f :: forall a (n m :: Num). n ~ m => Vec n a -> Vec m a\nf x = x", True) :
+>   (vecDecl ++ "id2 :: forall a (n :: Num) . Vec n a -> Vec n a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", True) :
+>   (vecDecl ++ "id2 :: forall a (n m :: Num) . Vec n a -> Vec m a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", False) :
+>   (vecDecl ++ "id2 :: forall a (n m :: Num) . n ~ m => Vec n a -> Vec m a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", True) :
+>   (vec2Decl ++ "id2 :: forall a (n m :: Num) . n ~ m => Vec a n -> Vec a m\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", True) :
+>   ("f :: forall a. 0 ~ 1 => a\nf = f", False) :
+>   -- ("x = y\ny = x", True) :
+>   ("f :: forall a . pi (m :: Num) . a -> a\nf {0} x = x\nf {n} x = x", True) :
+>   ("f :: forall a . a -> (pi (m :: Num) . a)\nf x {m} = x", True) :
+>   (vecDecl ++ "vec :: forall a . pi (m :: Num) . 0 <= m => a -> Vec m a\nvec {0} x = Nil\nvec {n+1} x = Cons x (vec {n} x)", True) :
+>   (natDecl ++ "nat :: pi (n :: Num) . 0 <= n => Nat\nnat {0} = Zero\nnat{m+1} = Suc (nat {m})", True) :
+>   -- ("data T :: Num -> * where C :: pi (n :: Num) . T n\nf (C {j}) = C {j}", True) :
+>   -- ("data T :: Num -> * where C :: pi (n :: Num) . T n\nf :: forall (n :: Num) . T n -> T n\nf (C {i}) = C {i}", True) :
+>   ("data T :: Num -> * where C :: forall (m :: Num) . pi (n :: Num) . m ~ n => T m\nf :: forall (n :: Num) . T n -> T n\nf (C {i}) = C {i}", True) :
+>   -- ("data T :: Num -> * where C :: pi (n :: Num) . T n\nf :: forall (n :: Num) . T n -> T n\nf (C {0}) = C {0}\nf (C {n+1}) = C {n+1}", True) :
+>   ("data T :: Num -> * where C :: forall (m :: Num) . pi (n :: Num) . m ~ n => T m\nf :: forall (n :: Num) . T n -> T n\nf (C {0}) = C {0}\nf (C {n+1}) = C {n+1}", True) :
+>   ("f :: Integer -> Integer\nf x = x", True) :
+>   ("f :: pi (n :: Num) . Integer\nf {n} = n", True) :
+>   ("f :: pi (n :: Num) . Integer\nf {0} = 0\nf {n+1} = n", True) :
+>   ("f :: pi (n :: Num) . Integer\nf {n+1} = n", True) :
+>   (vecDecl ++ "vtake :: forall (n :: Num) a . pi (m :: Num) . (0 <= m, 0 <= n) => Vec (m + n) a -> Vec m a\nvtake {0}   _            = Nil\nvtake {i+1} (Cons x xs) = Cons x (vtake {i} xs)", True) :
+>   (vecDecl ++ "vfold :: forall (n :: Num) a (f :: Num -> *) . f 0 -> (forall (m :: Num) . 0 <= m => a -> f m -> f (m + 1)) -> Vec n a -> f n\nvfold n c Nil         = n\nvfold n c (Cons x xs) = c x (vfold n c xs)", True) :
+>   ("data One where One :: One\ndata Ex where Ex :: forall a. a -> (a -> One) -> Ex\nf (Ex s g) = g s", True) :
+>   ("data One where One :: One\ndata Ex where Ex :: forall a. a -> (a -> One) -> Ex\nf :: Ex -> One\nf (Ex s g) = g s", True) :
+>   ("data One where One :: One\ndata Ex where Ex :: forall a. a -> Ex\nf (Ex a) = a", False) :
+>   ("data One where One :: One\ndata Ex where Ex :: forall a. a -> Ex\nf (Ex One) = One", False) :
+>   ("data Ex where Ex :: pi (n :: Num) . Ex\nf (Ex {n}) = n", True) : 
+>   ("data Ex where Ex :: pi (n :: Num) . Ex\ndata T :: Num -> * where T :: pi (n :: Num) . T n\nf (Ex {n}) = T {n}", False) :
+>   ("data Ex where Ex :: pi (n :: Num) . Ex\ndata T :: Num -> * where T :: pi (n :: Num) . T n\nf (Ex {n+1}) = T {n}", False) : 
+>   ("f = let g = \\ x -> x\n in g g", True) :
+>   ("f = let x = x\n in x", True) :
+>   ("f = let x = 0\n in x", True) :
+>   ("f = let x = 0\n in f", True) :
+>   ("f = let g x y = y\n in g f", True) :
+>   ("f x = let y = x\n in y", True) :
+>   ("f x = let y z = x\n          a = a\n  in y (x a)", True) :
+>   ("f :: forall a. a -> a\nf x = x :: a", True) :
+>   ("f :: forall b. (forall a. a -> a) -> b -> b\nf c = c\ng = f (\\ x -> x)", True) :
+>   ("f :: forall b. (forall a. a -> a) -> b -> b\nf c = c\ng = f (\\ x y -> x)", False) :
+>   ("f :: forall b. (forall a. a -> a) -> b -> b\nf c = c c\ng = f (\\ x -> x) (\\ x y -> y)", True) :
+>   ("f :: forall b. (forall a. a -> a -> a) -> b -> b\nf c x = c x x\ng = f (\\ x y -> x)", True) :
+>   (vec2Decl ++ "vfold :: forall (n :: Num) a (f :: Num -> *) . f 0 -> (forall (m :: Num) . 1 <= m => a -> f (m-1) -> f m) -> Vec a n -> f n\nvfold = vfold\nvbuild :: forall (n :: Num) a . Vec a n -> Vec a n\nvbuild = vfold Nil Cons", True) :
+>   (vec2Decl ++ "vfold :: forall (n :: Num) a (f :: Num -> *) . f 0 -> (forall (m :: Num) . 1 <= m => a -> f (m-1) -> f m) -> Vec a n -> f n\nvfold = vfold\nvbuild = vfold Nil Cons", True) :
+>   ("f :: forall b. (forall a . pi (m :: Num) . 0 <= m => a -> a) -> b -> b\nf h = h {0}\ng :: forall a . pi (m :: Num) . a -> a\ng {m} = \\ x -> x\ny = f g", True) :
+>   ("f :: forall b. (forall a . pi (m :: Num) . (0 <= m, m <= 3) => a -> a) -> b -> b\nf h = h {0}\ng :: forall a . pi (m :: Num) . (0 <= m, m <= 3) => a -> a\ng {m} = \\ x -> x\ny = f g", True) :
+>   ("f :: forall b. (forall a . pi (m :: Num) . (0 <= m, m <= 3) => a -> a) -> b -> b\nf h = h {0}\ng :: forall a . pi (m :: Num) . (m <= 3, 0 <= m) => a -> a\ng {m} = \\ x -> x\ny = f g", True) :
+>   ("f :: forall (b :: Num -> *) (n :: Num) . (0 <= n, n <= 3) => (forall (a :: Num -> *) (m :: Num) . (0 <= m, m <= 3) => a m -> a m) -> b n -> b n\nf h = h\ng :: forall (a :: Num -> *) (m :: Num) . (m <= 3, 0 <= m) => a m -> a m\ng = \\ x -> x\ny = f g", True) :
+>   ("f :: ((Integer -> (forall a. a -> a)) -> Integer) -> (Integer -> (forall a . a)) -> Integer\nf g h = g h", True) : 
+>   ("f :: ((Integer -> (forall a. a -> a)) -> Integer) -> (Integer -> (forall a . a)) -> Integer\nf = f", True) : 
+>   ("f :: (Integer -> (forall a. a -> a)) -> (forall b . (b -> b) -> (b -> b))\nf x = x 0", True) :
+>   ("f :: (Integer -> Integer -> (pi (m :: Num) . forall a. a -> a)) -> Integer -> (pi (m :: Num) . forall d b . (b -> b) -> (b -> b))\nf x = x 0", True) :
+>   ("f :: (forall a. a) -> (forall a. a) -> (forall a.a)\nf x y = x\ng = let loop = loop\n    in f loop", True) :
+>   ("f :: (forall a. a) -> (forall a. a) -> (forall a.a)\nf x y = x\ng = let loop = loop\n    in f loop\nh :: Integer\nh = g 0", False) :
+>   ("loop :: forall a. a\nloop = loop\nf :: (forall a. a) -> (forall a. a) -> (forall a.a)\nf x y = x\ng = f loop\nh :: Integer\nh = g 0", False) :
+>   ("f :: (forall a. a) -> (forall a. a) -> (forall a.a)\nf x y = x\ng :: (forall x . x) -> (forall y. y -> y)\ng = let loop = loop\n    in f loop", True) :
+>   ("f :: (forall a. a) -> (forall a. a) -> (forall a.a)\nf x y = x\ng :: (forall x . x -> x) -> (forall y. y)\ng = let loop = loop\n    in f loop", False) :
+>   ("data High where High :: (forall a. a) -> High\nf (High x) = x", True) :
+>   ("data Higher where Higher :: ((forall a. a) -> Integer) -> Higher\nf (Higher x) = x", True) :
+>   ("data Higher where Higher :: ((forall a. a) -> Integer) -> Higher\nf :: Higher -> (forall a. a) -> Integer\nf (Higher x) = x", True) :
+>   ("data Higher where Higher :: ((forall a. a) -> Integer) -> Higher\nf (Higher x) = x\nx = f (Higher (\\ zzz -> 0)) 0", False) :
+>   ("tri :: forall a . pi (m n :: Num) . (m < n => a) -> (m ~ n => a) -> (m > n => a) -> a\ntri = tri\nf :: pi (m n :: Num) . m ~ n => Integer\nf = f\nloop = loop\ng :: pi (m n :: Num) . Integer\ng {m} {n} = tri {m} {n} loop (f {m} {n}) loop", True) :
+>   ("tri :: forall a . pi (m n :: Num) . (m < n => a) -> (m ~ n => a) -> (m > n => a) -> a\ntri = undefined\ntri2 :: forall a . pi (m n :: Num) . (m < n => a) -> (m ~ n => a) -> (m > n => a) -> a\ntri2 = tri", True) :
+>   ("tri :: forall a . pi (m n :: Num) . (m < n => a) -> (m ~ n => a) -> (m > n => a) -> a\ntri = tri\nf :: pi (m n :: Num) . m ~ n => Integer\nf = f\nloop = loop\ng :: pi (m n :: Num) . Integer\ng {m} {n} = tri {m} {n} loop loop (f {m} {n})", False) :
+>   ("f :: forall a. pi (m n :: Num) . m ~ n => a\nf = f\nid2 x = x\ny :: forall a . pi (m n :: Num) . a\ny {m} {n} = id2 (f {m} {n})", False) :
+>   ("data Eql :: Num -> Num -> * where Refl :: forall (m n :: Num) . m ~ n => Eql m n\ndata Ex :: (Num -> *) -> * where Ex :: forall (p :: Num -> *)(n :: Num) . p n -> Ex p\nf :: pi (n :: Num) . Ex (Eql n)\nf {0} = Ex Refl\nf {n+1} = Ex Refl", True) :
+>   ("data Eql :: Num -> Num -> * where Refl :: forall (m n :: Num) . m ~ n => Eql m n\ndata Ex :: (Num -> *) -> * where Ex :: forall (p :: Num -> *)(n :: Num) . p n -> Ex p\nf :: pi (n :: Num) . Ex (Eql n)\nf {0} = Ex Refl\nf {n+1} = f {n}", False) :
+>   ("data Eql :: Num -> Num -> * where Refl :: forall (m n :: Num) . m ~ n => Eql m n\ndata Ex :: (Num -> *) -> * where Ex :: forall (p :: Num -> *) . pi (n :: Num) . p n -> Ex p\nf :: pi (n :: Num) . Ex (Eql n)\nf {0} = Ex {0} Refl\nf {n+1} = Ex {n+1} Refl", True) :
+>   ("data Eql :: Num -> Num -> * where Refl :: forall (m n :: Num) . m ~ n => Eql m n\ndata Ex :: (Num -> *) -> * where Ex :: forall (p :: Num -> *) . pi (n :: Num) . p n -> Ex p\nf :: pi (n :: Num) . Ex (Eql n)\nf {0} = Ex {0} Refl\nf {n+1} = Ex {n} Refl", False) :
+>   ("data Eql :: Num -> Num -> * where Refl :: forall (m n :: Num) . m ~ n => Eql m n\ndata Ex :: (Num -> *) -> * where Ex :: forall (p :: Num -> *) . pi (n :: Num) . p n -> Ex p\nf :: pi (n :: Num) . Ex (Eql n)\nf {0} = Ex {0} Refl\nf {n+1} = f {n}", False) :
+>   ("data Eql :: Num -> Num -> * where Refl :: forall (m n :: Num) . m ~ n => Eql m n\ndata Ex :: (Num -> *) -> * where Ex :: forall (p :: Num -> *) . pi (n :: Num) . p n -> Ex p\nf :: pi (n :: Num) . Ex (Eql n)\nf {0} = Ex {0} Refl\nf {n+1} = f {n-1}", False) :
+>   ("tri :: forall (a :: Num -> Num -> *) . (forall (m n :: Num) . (0 <= m, m < n) => a m n) -> (forall (m   :: Num) . 0 <= m        => a m m) -> (forall (m n :: Num) . (0 <= n, n < m) => a m n) -> (pi (m n :: Num) . (0 <= m, 0 <= n) => a m n)\ntri a b c {0}   {n+1} = a\ntri a b c {0}   {0}   = b\ntri a b c {m+1} {0}   = c\ntri a b c {m+1} {n+1} = tri a b c {m} {n}", False) :
+>   ("tri :: forall (a :: Num -> Num -> *) . (forall (m n :: Num) . (0 <= m, m < n) => a m n) -> (forall (m   :: Num) . 0 <= m        => a m m) -> (forall (m n :: Num) . (0 <= n, n < m) => a m n) -> (forall (m n :: Num) . (0 <= m, 0 <= n) => a m n -> a (m+1) (n+1)) -> (pi (m n :: Num) . (0 <= m, 0 <= n) => a m n)\ntri a b c step {0}   {n+1} = a\ntri a b c step {0}   {0}   = b\ntri a b c step {m+1} {0}   = c\ntri a b c step {m+1} {n+1} = step (tri a b c step {m} {n})", True) :
+>   ("tri :: forall a . pi (m n :: Num) . (0 <= m, 0 <= n) => (pi (d :: Num) . (0 < d, d ~ m - n) => a) -> (n ~ m => a) -> (pi (d :: Num) . (0 < d, d ~ n - m) => a) -> a\ntri {0}   {0}   a b c = b\ntri {m+1} {0}   a b c = a {m+1}\ntri {0}   {n+1} a b c = c {n+1}\ntri {m+1} {n+1} a b c = tri {m} {n} a b c", True) :
+>   ("f :: forall a . pi (m n :: Num) . a\nf {m} {n} = let h :: m ~ n => a\n                h = h\n            in f {m} {n}", True) :
+>   ("f :: forall a (m n :: Num) . (m ~ n => a) -> a\nf x = x", False) :
+>   ("f :: forall a (m n :: Num) . ((m ~ n => a) -> a) -> (m ~ n => a) -> a\nf x y = x y", True) :
+>   ("f :: forall a (m n :: Num) . ((m ~ n => a) -> a) -> (m ~ n + 1 => a) -> a\nf x y = x y", False) :
+>   ("f :: forall a . pi (m n :: Num) . a\nf {m} {n} = let h :: m ~ n => a\n                h = h\n            in h", False) :
+>   ("f :: forall a . pi (m n :: Num) . ((m ~ 0 => a) -> a) -> a\nf {m} {n} x = let h :: m ~ n => a\n                  h = h\n            in x h", False) :
+>   ("f :: pi (n :: Num) . Integer\nf {n} | {n >= 0} = n\nf {n} | {n < 0} = 0", True) :
+>   ("f :: pi (n :: Num) . Integer\nf {n} | {m ~ 0} = n", False) : 
+>   ("f :: pi (n :: Num) . Integer\nf {n} | {n > 0, n < 0} = f {n}\nf {n} | True = 0", True) :
+>   ("f :: pi (n :: Num) . (n ~ 0 => Integer) -> Integer\nf {n} x | {n ~ 0} = x\nf {n} x = 0", True) : 
+>   ("f :: pi (n :: Num) . (n ~ 0 => Integer) -> Integer\nf {n} x | {n ~ 0} = x\nf {n} x = x", False) : 
+>   ("x = 0\nx = 1", False) : 
+>   ("x :: Integer\nx = 0\nx = 1", False) : 
+>   ("x = 0\ny = x\nx = 1", False) : 
+>   ("x = y\ny :: Integer\ny = x", True) : 
+>   ("x :: forall (a :: * -> *) . a\nx = x", False) : 
+>   (vec3Decl ++ "vhead (Cons x xs) = x\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", False) :
+>   (vec3Decl ++ "vhead :: forall (n :: Num) a. Vec (1+n) a -> a\nvhead (Cons x xs) = x\nid2 :: forall (n :: Num) a. Vec n a -> Vec n a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", True) :
+>   (vec3Decl ++ "append :: forall a (m n :: Num) . (0 <= m, 0 <= n, 0 <= (m + n)) => Vec m a -> Vec n a -> Vec (m+n) a\nappend Nil ys = ys\nappend (Cons x xs) ys = Cons x (append xs ys)", True) :
+>   (vec3Decl ++ "append :: forall a (m n :: Num) . 0 <= n => Vec m a -> Vec n a -> Vec (m+n) a\nappend Nil ys = ys\nappend (Cons x xs) ys = Cons x (append xs ys)", True) :
+>   (vec3Decl ++ "vtail :: forall (n :: Num) a. Vec (n+1) a -> Vec n a\nvtail (Cons x xs) = xs", True) :
+>   (vec3Decl ++ "lie :: forall a (n :: Num) . Vec n a\nlie = Nil", False) :
+>   (vec3Decl ++ "vhead :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> a\nvhead (Cons x xs) = x", True) :
+>   (vec3Decl ++ "silly :: forall a (m :: Num). m <= -1 => Vec m a -> a\nsilly (Cons x xs) = x", True) :
+>   (vec3Decl ++ "silly :: forall a (m :: Num). m <= -1 => Vec m a -> a\nsilly (Cons x xs) = x\nbad = silly (Cons Nil Nil)", False) :
+>   (vec3Decl ++ "vhead :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> a\nvhead (Cons x xs) = x\nwrong = vhead Nil", False) :
+>   (vec3Decl ++ "vhead :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> a\nvhead (Cons x xs) = x\nright = vhead (Cons Nil Nil)", True) :
+>   (vec3Decl ++ "vtail :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> Vec m a\nvtail (Cons x xs) = xs\ntwotails :: forall a (m :: Num). (0 <= m, 0 <= (m+1)) => Vec (m+2) a -> Vec m a \ntwotails xs = vtail (vtail xs)", True) :
+>   (vec3Decl ++ "vtail :: forall a (m :: Num). 0 <= m => Vec (m+1) a -> Vec m a\nvtail (Cons x xs) = xs\ntwotails xs = vtail (vtail xs)", True) :
+>   (vec3Decl ++ "f :: forall a (n m :: Num). n ~ m => Vec n a -> Vec m a\nf x = x", True) :
+>   (vec3Decl ++ "id2 :: forall a (n :: Num) . Vec n a -> Vec n a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", True) :
+>   (vec3Decl ++ "id2 :: forall a (n m :: Num) . Vec n a -> Vec m a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", False) :
+>   (vec3Decl ++ "id2 :: forall a (n m :: Num) . n ~ m => Vec n a -> Vec m a\nid2 Nil = Nil\nid2 (Cons x xs) = Cons x xs", True) :
+>   (vec3Decl ++ "data Pair :: * -> * -> * where Pair :: forall a b. a -> b -> Pair a b\nvsplit2 :: forall (n :: Num) a . pi (m :: Num) . Vec (m + n) a -> Pair (Vec m a) (Vec n a)\nvsplit2 {0}   xs           = Pair Nil xs\nvsplit2 {n+1} (Cons x xs) = let  f (Pair ys zs)  = Pair (Cons x ys) zs\n                                 xs'             = vsplit2 {n} xs\n                             in f xs'", True) :
+>   ("data Max :: Num -> Num -> Num -> * where\n  Less :: forall (m n :: Num) . m < n => Max m n n\n  Same :: forall (m :: Num) . Max m m m\n  More :: forall (m n :: Num) . m > n => Max m n m", True) :
+>   ("data In :: Num -> * where\nint :: pi (n :: Num) . In n\nint = int\ndata Even :: Num -> * where\n  Twice :: pi (n :: Num) . Even (2 * n)\nunEven (Twice {n}) = int {n}", False) :
+>   ("data In :: Num -> * where\nint :: pi (n :: Num) . In n\nint = int\ndata Even :: Num -> * where\n  Twice :: pi (n :: Num) . Even (2 * n)\nunEven :: forall (n :: Num). Even (2 * n) -> In n\nunEven (Twice {n}) = int {n}", True) :
+>   ("f :: Boo -> Boo\nf x = x\ndata Boo where Boo :: Boo", True) :
+>   ("data Ex where Ex :: pi (n :: Num) . Ex\nf :: forall a . (pi (n :: Num) . a) -> Ex -> a\nf g (Ex {n}) = g {n}", True) :
+>   ("y = 2\ny :: Integer", True) :
+>   ("y = 2\nx = 3\ny :: Integer", True) :
+>   ("data UNat :: Num -> * where\ndata Bad :: (Num -> Num) -> * where Eek :: forall (f :: Num -> Num) . UNat (f 0) -> Bad f\nbadder :: forall (g :: Num -> Num -> Num) . Bad (g 1) -> UNat (g (2-1) 0)\nbadder (Eek n) = n", False) :
+>   ("narg {n} = n", True) :
+>   ("data UNat :: Num -> * where\nunat :: pi (n :: Num) . UNat n\nunat = unat\nnarg {n} = unat {n}", True) :
+>   ("data UNat :: Num -> * where\nunat :: pi (n :: Num) . 0 <= n => UNat n\nunat = unat\nnarg {n} = unat {n}", True) :
+>   ("data UNat :: Num -> * where\nunat :: pi (n :: Num) . UNat n\nunat = unat\nf :: UNat 0 -> UNat 0\nf x = x\nnarg {n} = f (unat {n})", True) :
+>   ("f :: pi (m :: Nat) . Integer\nf {m} = m", True) :
+>   ("bad :: forall (m n :: Num) . Integer\nbad | {m ~ n} = 0\nbad | True    = 1", False) :
+>   ("worse :: forall (n :: Num) . Integer\nworse = n", False) :
+>   ("f :: pi (m :: Num) . Integer\nf = f\nworse :: forall (n :: Num) . Integer\nworse = f {n}", False) :
+>   ("f = \\ {x} -> x", True) :
+>   ("f = \\ {x} y {z} -> x", True) :
+>   ("f = \\ {x} y {z} -> x y", False) :
+>   ("f = \\ {x} y {z} -> y x", True) :
+>   ("f = \\ {x} y {z} -> y {x}", False) :
+>   ("f :: pi (n :: Num) . Integer\nf = \\ {x} -> x", True) :
+>   ("f :: forall a . pi (m :: Num) . (Integer -> a) -> a\nf = \\ {x} y -> y x", True) :
+>   ("f :: forall a . pi (m :: Num) . (pi (n :: Num) . a) -> a\nf = \\ {x} y -> y {x}", True) :
+>   ("f = \\ a -> a\ng = \\ {x} -> f (\\ {y} -> y) {x}", True) :
+>   ("f :: (pi (n :: Num) . Integer) -> (pi (n :: Num) . Integer)\nf = \\ a -> a\ng = \\ {x} -> f (\\ {y} -> y) {x}", True) :
+>   ("f :: pi (n :: Num) . forall a . a -> a\nf = \\ {n} x -> x", True) :
+>   ("f g {n} = g {n}", True) :
+>   ("f :: forall a. (pi (n :: Num) . a) -> (pi (n :: Num) . a)\nf g {n} = g {n}", True) :
+>   ("f :: pi (n :: Num) . Integer\nf = \\ {n} -> n\ng = \\ {n} -> f {n}", True) :
+>   ("f :: pi (n :: Nat) . Integer\nf = \\ {n} -> n\ng = \\ {n} -> f {n}", True) :
+>   ("f :: pi (n :: Nat) . Integer\nf = \\ {n} -> n\ng :: pi (n :: Num) . Integer\ng = \\ {n} -> f {n}", False) :
+>   ("f :: pi (n :: Nat) . Integer\nf = \\ {n} -> n\ng :: pi (n :: Nat) . Integer\ng = \\ {n} -> f {n}", True) :
+>   ("f :: (pi (n :: Nat) . Integer) -> Integer\nf g = g {3}", True):
+>   ("f :: (pi (n :: Nat) . Integer) -> Integer\nf h = h {3}\ny :: pi (n :: Nat) . Integer\ny {n} = 3\ng = f (\\ {n} -> y {n})", True):
+>   ("data D :: Num -> * where\n  Zero :: D 0\n  NonZero :: forall (n :: Num) . D n\nisZ :: forall a . pi (n :: Num) . (n ~ 0 => a) -> a -> a\nisZ = isZ\nx :: pi (n :: Num) . D n\nx {n} = isZ {n} Zero Zero", False) :
+>   ("data D :: Num -> * where\n  Zero :: D 0\n  NonZero :: forall (n :: Num) . D n\nisZ :: forall a . pi (n :: Num) . (n ~ 0 => a) -> a -> a\nisZ = isZ\nx :: pi (n :: Num) . D n\nx {n} = isZ {n} Zero NonZero", True) :
+>   -- ("f :: forall (n :: Num) . n <= 42 => Integer\nf = f", True) :
+>   ("f :: forall (t :: Num -> *)(n :: Num) . n <= 42 => t n -> Integer\nf = f\ng :: forall (s :: Num -> *) . (forall (n :: Num) . n <= 42 => s n -> Integer) -> Integer\ng = g\nh = g f", True) :
+>   ("a :: forall (x :: Num) . Integer\na =\n  let f :: forall (t :: Num -> *)(n :: Num) . n <= x => t n -> Integer\n      f = f\n      g :: forall (s :: Num -> *) . (forall (n :: Num) . n <= x => s n -> Integer) -> Integer\n      g = g\n  in g f", True) :
+>   ("noo :: Bool -> Bool\nnoo x = case x of\n  True -> False\n  False -> True", True) :
+>   ("noo :: Bool -> Bool\nnoo x = case x of\n  True -> False\n  False -> 3", False) :
+>   (vecDecl ++ "f :: forall (n :: Num) a . Vec n a -> Vec n a\nf x = case x of\n  Nil -> Nil\n  Cons x xs -> Cons x xs", True) :
+>   ("noo x = case x of\n  True -> False\n  False -> True", True) :
+>   ("noo x = case x of\n  True -> False\n  False -> 3", False) :
+>   (vecDecl ++ "f x = case x of\n  Nil -> Nil\n  Cons x xs -> Cons x xs", False) :
+>   ("f :: forall (t :: Num -> *)(m n :: Num) . t (m * n) -> t (m * n)\nf x = x", True) :
+>   ("f :: forall (t :: Num -> *)(m n :: Num) . t (m * n) -> t (n * m)\nf x = x", True) :
+>   ("f :: forall (t :: Num -> *)(m n :: Num) . t (m * n) -> t (m + n)\nf x = x", False) :
+>   ("f :: forall (f :: Num -> *) . f (min 2 3) -> f (min 3 2)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *) . f (min 2 3) -> f (min 1 2)\nf x = x", False) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (max a 3) -> f (max a 3)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (max a 3) -> f (max 3 a)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (max a 3) -> f (max 2 a)\nf x = x", False) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . f (min a b) -> f (min b a)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a b c :: Num) . (a <= b, b <= c) => f (min a b) -> f (min c a)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a b c :: Num) . (a >= b, b <= c) => f (min a b) -> f (min c a)\nf x = x", False) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . a > 99 => f a -> f (abs a)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *) . f (signum (-6)) -> f (abs (-1) - 2)\nf x = x", True) :
+>   ("f :: pi (m :: Num) . Integer\nf {m} = f {abs m}", True) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (2 ^ a) -> f (2 ^ a)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (a ^ 2) -> f (a ^ 3)\nf x = x", False) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (3 ^ 2) -> f 9\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . a ~ b => f (a ^ 1) -> f b\nf x = x", True) :
+>   ("f :: pi (m :: Num) . Integer\nf {m} = f {6 ^ 2 + m}", True) :
+>   (vec2Decl ++ "append :: forall a (m n :: Num) . Vec a m -> Vec a n -> Vec a (m+n)\nappend = append\nflat :: forall a (m n :: Num). Vec (Vec a m) n -> Vec a (m*n)\nflat Nil = Nil\nflat (Cons xs xss) = append xs (flat xss)", True) :
+>   ("f :: pi (x :: Num) . Bool\nf {x} | {x > 0} = True\n      | otherwise = False", True) :
+>   ("f {x} | {x > 0} = True\n      | otherwise = False", True) :
+>   ("needPos :: pi (x :: Num) . x > 0 => Integer\nneedPos = needPos\nf :: pi (x :: Num) . Integer\nf {x} | {x > 0} = needPos {x}\n      | otherwise = -1", True) :
+>   ("needPos :: pi (x :: Num) . x > 0 => Integer\nneedPos = needPos\nf :: pi (x :: Num) . Integer\nf {x} | {x > 0} = needPos {x}\n      | otherwise = needPos {x}", False) :
+>   ("needPos :: pi (x :: Num) . x > 0 => Integer\nneedPos = needPos\nf {x} | {x > 0} = needPos {x}\n      | otherwise = -1", True) :
+>   ("needPos :: pi (x :: Num) . x > 0 => Integer\nneedPos = needPos\nf {x} | {x > 0} = needPos {x}\n      | otherwise = needPos {x}", True) :
+>   ("f x | (case x of True -> False\n                 False -> True\n            ) = 1\n    | otherwise = 0", True) :
+>   ("f x | True = 1\n    | False = True", False) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . f ((a + 2) * b) -> f (b + b + b * a)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . 0 <= a * b => f a -> f b\nf = f\ng :: forall (f :: Num -> *)(a b :: Num) . (0 <= a, 0 <= b) => f a -> f b\ng = f", True) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . 0 <= a * b + a => f a -> f b\nf = f\ng :: forall (f :: Num -> *)(a b :: Num) . (0 <= a, 0 <= b + 1) => f a -> f b\ng = f", True) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . 0 <= b + 1 => f a -> f b\nf = f\ng :: forall (f :: Num -> *)(a b :: Num) . (0 <= a, 0 <= a * b + a) => f a -> f b\ng = f", True) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (a ^ (-1)) -> f (a ^ (-1))\nf x = x", False) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . f (a * a ^ (-1)) -> f 1\nf x = x", False) :
+>   ("data Fin :: Num -> * where\ndata Tm :: Num -> * where A :: forall (m :: Num) . 0 <= m => Tm m -> Tm m -> Tm m\nsubst :: forall (m n :: Num) . 0 <= n => (pi (w :: Num) . 0 <= w => Fin (w+m) -> Tm (w + n)) -> Tm m -> Tm n\nsubst s (A f a) = A (subst s f) (subst s a)", True) :
+>   ("x = 2 + 3", True) :
+>   ("x = 2 - 3", True) :
+>   ("x = - 3", True) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . f (2 ^ (a + b)) -> f (2 ^ a * 2 ^ b)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a b :: Num) . f (2 ^ (2 * a)) -> f ((2 ^ a) ^ 2)\nf x = x", True) :
+>   ("f :: forall (f :: (Num -> Num) -> *) . f (min 2) -> f (min 2)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> *)(a :: Num) . a ~ 0 => f (0 ^ a) -> f 1\nf x = x", True) :
+>   ("f :: forall (f :: * -> Num)(g :: Num -> *) . g (f Integer) -> g (f Integer)\nf x = x", True) :
+>   ("f :: forall (f :: Num -> Num -> Num -> Num)(g :: Num -> *) . g (f 1 2 3) -> g (f 1 2 2)\nf x = x", False) :
+>   ("f :: Integer", False) :
+>   ("x :: forall a . [a]\nx = []", True) :
+>   ("y :: [Integer]\ny = 1 : 2 : [3, 4]", True) :
+>   ("x = [[]]", True) :
+>   ("x = 'a' : [] : []", False) :
+>   ("x = 1 + 3 : [6]", True) : 
+>   ("x :: ()\nx = ()", True) : 
+>   ("x :: (Integer, Integer)\nx = ()", False) : 
+>   ("x = ((), ())", True) :
+>   ("f () = ()\ng (x, y) = (y, x)", True) : 
+>   ("f () = ()\nf (x, y) = (y, x)", False) : 
+>   ("f xs = case xs of\n      [] -> []\n      y:ys -> y : f ys", True) :
+>   ("scanl'            :: (a -> b -> a) -> a -> [b] -> [a]\nscanl' f q xs     =  q : (case xs of\n                            []   -> []\n                            x:ys -> scanl' f (f q x) ys\n                        )", True) :
+>   ("a = \"hello\"", True) :
+>   ("b w = w : 'o' : 'r' : ['l', 'd']", True) :
+>   ("x = y\n  where y = 3", True) :
+>   ("f x | z = 3\n   | otherwise = 2\n  where z = x", True) :
+>   ("f = case True of True -> 3", True) :
+>   ("f :: Integer\nf = case True of True -> 3", True) :
+>   ("x :: Bool\nx = (<) 2 3", True) :
+>   ("data Empty where", True) :
+>   ("(&&&) :: Bool -> Bool -> Bool\nTrue &&& x = x\nFalse &&& _ = False", True) :
+>   (vecDecl ++ "vsplit :: forall (n :: Nat) a . pi (m :: Nat) . Vec (m + n) a -> (Vec m a, Vec n a)\nvsplit {0}   xs           = (Nil, xs)\nvsplit {m+1} (Cons x xs) = case vsplit {m} xs of\n                                (ys, zs) -> (Cons x ys, zs)", True) :
+>   (vecDecl ++ "vsplit :: forall (n :: Nat) a . pi (m :: Nat) . Vec (m + n) a -> (Vec m a, Vec n a)\nvsplit {0}   xs           = (Nil, xs)\nvsplit {m+1} (Cons x xs) = case vsplit {m} xs of\n                                (ys, zs) | True -> (Cons x ys, zs)", True) :
+>   (vecDecl ++ "foo :: forall a (n m :: Nat) . Vec (m + n) a -> Vec (n + m) a\nfoo = foo", True) :
+>   (vecDecl ++ "foo :: forall a (n m :: Nat) . Vec (m + n) a -> Vec (n + m) a\nfoo x = x\ngoo = foo", True) :
+>   (vecDecl ++ "foo :: forall a (n m :: Nat) . Vec (m + n) a -> Vec (n + m) a\nfoo x = x\ngoo :: forall a (n m :: Nat) . Vec (m + n) a -> Vec (n + m) a\ngoo = foo", True) :
+>   (vecDecl ++ "foo :: forall a (n m :: Nat) . Vec (m + n) a -> Vec (n + m) a\nfoo x = x\ngoo :: forall a (i :: Integer)(n :: Nat) . 0 <= i - n => Vec i a -> Vec i a\ngoo = foo", True) :
+>   ("foo :: forall (f :: Num -> Num -> Num) a (p :: Num -> *) . (forall (m n :: Num) a . p m -> p n -> (f m n ~ f n m => a) -> a) -> (f 1 3 ~ f 3 1 => a) -> a\nfoo comm x = comm (undefined :: p 1) (undefined :: p 3) x", True) :
+>   ("f :: forall (p :: Constraint -> *)(c :: Constraint) . c => p c -> Integer\nf = f", True) :
+>   ("f :: forall (p :: Constraint -> *) . p (2 + 3 <= 7)\nf = f", True) :
+>   ("class S a where\n  s :: a -> [Char]\nx = s", True) :
+>   ("class T a (b :: Integer) where\n  s :: forall (p :: Integer -> *) . a -> p b -> Integer\nx = s", True) :
+>   ("class S a where\n  s :: 6", False) :
+>   ("f :: forall (p :: Integer -> *) . pi (x :: Integer) . p x\nf {y} = undefined :: p y", True) : 
+>   ("f :: forall (p :: Integer -> *) . pi (x :: Integer) . p x\nf {y} = undefined :: p x", False) : 
+>   ("f :: Show a => a -> [Char]\nf x = show x\nz :: [Char]\nz = show (3 :: Integer)", True) :
+>   ("f :: Show a => a -> [Char]\nf x = show x\nz :: [Char]\nz = show 3", True) :
+>   ("class Foo a where\n foo :: b -> a", True) :
+>   (vecDecl ++ "class N a where n :: pi (x :: Nat) . a -> Vec x a\ninstance N Char where n {0} c = Nil", True) :
+>   ("class X a where x :: a\ninstance X Integer where x = 3", True) : 
+>   ("class X a where x :: a\ninstance X Integer where x = 'a'", False) : 
+>   ("class X a where x :: a\ninstance X Integer where x = 3\ny :: Integer\ny = x", True) : 
+>   ("class Comm (f :: Integer -> Integer -> Integer) where comm :: forall (m n :: Integer) a . (f m n ~ f n m => a) -> a\ninstance Comm (+) where comm x = x", True) :
+>   ("class X a where x :: a\ninstance X a => X [a] where x = [x]", True) : 
+>   ("class X a where x :: a\ninstance (X Integer, X a) => X [a] where x = [x]", True) : 
+>   ("class X a where x :: a\ninstance X a => X [a] where x = []\ny :: X a => [a]\ny = x", True) : 
+>   ("class (a ~ b) => X (a :: Integer) (b :: Integer) where coe :: forall (p :: Integer -> *) . p a -> p b\ninstance X a a where coe x = x", True) : 
+>   ("class X a where x :: a\nclass (X a) => Y a\ny :: Y a => a\ny = x", True) : 
+>   ("elimNat :: forall a . pi (n :: Nat) . (n ~ 0 => a) -> (pi (m :: Nat) . n ~ m + 1 => a) -> a\nelimNat {0}   z s = z\nelimNat {m+1} z s = s {m}\nnatToInt p {n} = elimNat {n} 0 (\\ {m} -> p m 1)", True) :
+>   ("data Foo :: * -> * where\n  X :: forall a. Foo a\n  deriving Show\nf :: Foo a -> [Char]\nf = show", True) :
+>   ("data Foo where\n  X :: Foo\n  deriving Show\nf :: Foo -> [Char]\nf = show", True) :
+>   ("f :: Show a => b -> [Char]\nf = show", False) :
+>   ("f :: Eq a => (a,a) -> (a,a) -> Bool\nf = (==)", True) :
+>   ("badexp :: (Num a, Num b, Eq b, Ord b, Integral b) => a -> b -> a\nbadexp x n | (>) n 0 = f x ((-) n 1) x where\n  f :: forall _s _s' . (Num _s, Integral _s', Num _s', Eq _s') => _s -> (_s' -> (_s -> _s))\n  f _ 0 y = y\n  f x n y = g x n where\n    g x n | even n = g ((*) x x) (quot n 2)\n           | otherwise = f x ((-) n 1) ((*) x y)", False) :
+>   ("type Strung = [Char]\nx = [] :: Strung", True) :
+>   ("type F (a :: *) (b :: * -> *) = b a\nfoo :: a -> F a []\nfoo = return", True) :
+>   (vecDecl ++ "type Suc (n :: Integer) = n + 1\ntype Vect a (n :: Integer) = Vec n a\ncons :: forall a (n :: Nat) . a -> Vect a n -> Vect a (Suc n)\ncons = Cons", True) :
+>   ("type One = 1\nf :: forall (p :: Integer -> *) (n :: Integer) . n ~ One => p n -> p 1\nf x = x", True) :
+>   ("type A = Integer\ntype B = A\nf :: B -> Integer\nf x = x", True) :
+>   (vecDecl ++ "instance Show (Vec 0 a) where\n  show Nil = \"Nil\"", True) :
+>   (vecDecl ++ "instance (0 ~ 1) => Show (Vec 0 a) where\n  show Nil = \"Nil\"", True) :
+>   (vec2Decl ++ "class Nummy (n :: Integer) where num :: (pi (m :: Integer) . m ~ n => a) -> a\ninstance Nummy 0 where num f = f {0}\nclass Applicative (f :: * -> *) where\n  pure :: a -> f a\n  (<*>) :: f (a -> b) -> f a -> f b\ninstance (Nummy n, n > 0) => Applicative (Vec n) where", True) :
+>   []