packages feed

inch (empty) → 0.1.0

raw patch · 35 files changed

+8167/−0 lines, 35 filesdep +IndentParserdep +basedep +containerssetup-changed

Dependencies added: IndentParser, base, containers, directory, filepath, mtl, parsec, presburger, pretty

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data/Prelude.inch view
@@ -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
+ examples/Cost.hs view
@@ -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))
+ examples/MergeSort.hs view
@@ -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
+ examples/NonlinearCost.hs view
@@ -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'))))))
+ examples/Queue.hs view
@@ -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))
+ examples/RedBlack.hs view
@@ -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)
+ examples/RedBlackCost.hs view
@@ -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))
+ examples/Units.hs view
@@ -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
+ examples/Vectors.hs view
@@ -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)
+ examples/Wires.hs view
@@ -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)))
+ inch.cabal view
@@ -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
+ src/Language/Inch/BwdFwd.lhs view
@@ -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
+ src/Language/Inch/Check.lhs view
@@ -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"
+ src/Language/Inch/Context.lhs view
@@ -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
+ src/Language/Inch/Erase.lhs view
@@ -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
+ src/Language/Inch/Error.lhs view
@@ -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, [])
+ src/Language/Inch/File.lhs view
@@ -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
+ src/Language/Inch/Kind.lhs view
@@ -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+> -}
+ src/Language/Inch/KindCheck.lhs view
@@ -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)
+ src/Language/Inch/Kit.lhs view
@@ -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 []
+ src/Language/Inch/Main.lhs view
@@ -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
+ src/Language/Inch/ModuleSyntax.lhs view
@@ -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
+ src/Language/Inch/Parser.lhs view
@@ -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
+ src/Language/Inch/PrettyPrinter.lhs view
@@ -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
+ src/Language/Inch/ProgramCheck.lhs view
@@ -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
+ src/Language/Inch/Solver.lhs view
@@ -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)
+ src/Language/Inch/Syntax.lhs view
@@ -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
+ src/Language/Inch/TyNum.lhs view
@@ -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!
+ src/Language/Inch/Type.lhs view
@@ -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)
+ src/Language/Inch/TypeCheck.lhs view
@@ -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
+ src/Language/Inch/Unify.lhs view
@@ -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)
+ tests/Main.lhs view
@@ -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) :+>   []