packages feed

liquidhaskell 0.3.1.0 → 0.4.0.0

raw patch · 558 files changed

+17726/−2403 lines, 558 filesdep ~liquid-fixpoint

Dependency ranges changed: liquid-fixpoint

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

Liquid.hs view
@@ -2,10 +2,10 @@  import           Data.Maybe import           Data.Monoid      (mconcat, mempty)-import           System.Exit +import           System.Exit import           Control.Applicative ((<$>)) import           Control.DeepSeq-import           Text.PrettyPrint.HughesPJ    +import           Text.PrettyPrint.HughesPJ import           CoreSyn import           Var import           System.Console.CmdArgs.Verbosity (whenLoud)@@ -20,10 +20,10 @@ import           Language.Haskell.Liquid.Errors import           Language.Haskell.Liquid.CmdLine import           Language.Haskell.Liquid.GhcInterface-import           Language.Haskell.Liquid.Constraint.Generate       -import           Language.Haskell.Liquid.Constraint.ToFixpoint      +import           Language.Haskell.Liquid.Constraint.Generate+import           Language.Haskell.Liquid.Constraint.ToFixpoint import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.TransformRec   +import           Language.Haskell.Liquid.TransformRec import           Language.Haskell.Liquid.Annotate (mkOutput)  main :: IO b@@ -38,25 +38,26 @@   where     errOut r    = exitWithResult cfg0 t $ mempty { o_result = r} -liquidOne :: FilePath -> GhcInfo -> IO (Output Doc) -liquidOne target info = +liquidOne :: FilePath -> GhcInfo -> IO (Output Doc)+liquidOne target info =   do donePhase Loud "Extracted Core using GHC"-     let cfg   = config $ spec info +     let cfg   = config $ spec info      whenLoud  $ do putStrLn "**** Config **************************************************"                     print cfg-     whenLoud  $ do putStrLn $ showpp info -                    putStrLn "*************** Original CoreBinds ***************************" +     whenLoud  $ do putStrLn $ showpp info+                    putStrLn "*************** Original CoreBinds ***************************"                     putStrLn $ showpp (cbs info)      let cbs' = transformScope (cbs info)      whenLoud  $ do donePhase Loud "transformRecExpr"-                    putStrLn "*************** Transform Rec Expr CoreBinds *****************" +                    putStrLn "*************** Transform Rec Expr CoreBinds *****************"                     putStrLn $ showpp cbs'-                    putStrLn "*************** Slicing Out Unchanged CoreBinds *****************" +                    putStrLn "*************** Slicing Out Unchanged CoreBinds *****************"      dc <- prune cfg cbs' target info      let cbs'' = maybe cbs' DC.newBinds dc-     let cgi   = {-# SCC "generateConstraints" #-} generateConstraints $! info {cbs = cbs''}+     let info' = maybe info (\z -> info {spec = DC.newSpec z}) dc+     let cgi   = {-# SCC "generateConstraints" #-} generateConstraints $! info' {cbs = cbs''}      cgi `deepseq` donePhase Loud "generateConstraints"-     out      <- solveCs cfg target cgi info dc+     out      <- solveCs cfg target cgi info' dc      donePhase Loud "solve"      let out'  = mconcat [maybe mempty DC.oldOutput dc, out]      DC.saveResult target out'@@ -72,28 +73,31 @@  -- prune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Maybe Diff) prune cfg cbs target info-  | not (null vs) = return . Just $ DC.DC (DC.thin cbs vs) mempty-  | diffcheck cfg = DC.slice target cbs+  | not (null vs) = return . Just $ DC.DC (DC.thin cbs vs) mempty sp+  | diffcheck cfg = DC.slice target cbs sp   | otherwise     = return Nothing-  where -    vs            = tgtVars $ spec info+  where+    vs            = tgtVars sp+    sp            = spec info -solveCs cfg target cgi info dc -  = do let finfo = cgInfoFInfo info cgi-       (r, sol) <- solve fx target (hqFiles info) finfo+solveCs cfg target cgi info dc+  = do finfo    <- cgInfoFInfo info cgi+       (r, sol) <- solve fx finfo        let names = checkedNames dc        let warns = logErrors cgi        let annm  = annotMap cgi        let res   = ferr sol r        let out0  = mkOutput cfg res sol annm        return    $ out0 { o_vars = names } { o_errors  = warns} { o_result = res }-    where -       fx        = def { FC.solver = fromJust (smtsolver cfg), FC.real = real cfg }+    where+       fx        = def { FC.solver  = fromJust (smtsolver cfg)+                       , FC.real    = real   cfg+                       , FC.native  = native cfg+                       , FC.srcFile = target+                       }        ferr s r  = fmap (tidyError s) $ result $ sinfo <$> r   -- writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str---   where +--   where --     str          = {-# SCC "PPcgi" #-} showpp cgi--
include/Control/Exception.spec view
@@ -1,5 +1,5 @@ module spec Control.Exception where --- Useless as compiled into GHC primitive, which is ignored+// Useless as compiled into GHC primitive, which is ignored assume assert :: {v:Bool | Prop v } -> a -> a
include/CoreToLogic.lg view
@@ -5,6 +5,9 @@ define Data.Set.Base.empty            = (Set_empty 0) define Data.Set.Base.member x xs      = (Set_mem x xs) define Data.Set.Base.isSubsetOf x y   = (Set_sub x y)+define Data.Set.Base.elems xs         = (listElts xs)++define GHC.Types.True                 = (true)   define Data.Map.Base.insert k v m     = (Map_store m k v) define Data.Map.Base.select k v       = (Map_select m k)
include/Data/Bits.spec view
@@ -1,6 +1,6 @@ module spec Data.Bits where --- TODO: cannot use this because `Bits` is not a `Num`--- Data.Bits.shiftR :: (Data.Bits.Bits a) => x:a -> d:Nat ---                  -> {v:a | ((d=1) => (x <= 2*v + 1 && 2*v <= x)) }+// TODO: cannot use this because `Bits` is not a `Num`+// Data.Bits.shiftR :: (Data.Bits.Bits a) => x:a -> d:Nat +//                  -> {v:a | ((d=1) => (x <= 2*v + 1 && 2*v <= x)) }
include/Data/List.spec view
@@ -7,15 +7,15 @@  assume transpose :: [[a]] -> [{v:[a] | (len v) > 0}] --- assume GHC.List.concat :: x:[[a]] -> {v:[a] | (len v) = (sumLens x)}--- --- measure sumLens :: [[a]] -> GHC.Types.Int---     sumLens ([])   = 0---     sumLens (c:cs) = (len c) + (sumLens cs)--- --- invariant {v:[[a]] | (sumLens v) >= 0}--- qualif SumLensEq(v:List List a, x:List List a): (sumLens v) = (sumLens x)--- qualif SumLensEq(v:List List a, x:List a): (sumLens v) = (len x)--- qualif SumLensLe(v:List List a, x:List List a): (sumLens v) <= (sumLens x)+// assume GHC.List.concat :: x:[[a]] -> {v:[a] | (len v) = (sumLens x)}+//+// measure sumLens :: [[a]] -> GHC.Types.Int+//     sumLens ([])   = 0+//     sumLens (c:cs) = (len c) + (sumLens cs)+//+// invariant {v:[[a]] | (sumLens v) >= 0}+// qualif SumLensEq(v:List List a, x:List List a): (sumLens v) = (sumLens x)+// qualif SumLensEq(v:List List a, x:List a): (sumLens v) = (len x)+// qualif SumLensLe(v:List List a, x:List List a): (sumLens v) <= (sumLens x)
include/Data/Set.spec view
@@ -2,38 +2,38 @@  embed Data.Set.Set as Set_Set -------------------------------------------------------------------------------------------------- | Logical Set Operators: Interpreted "natively" by the SMT solver ------------------------------------------------------------------------------------------------------------------------+// ----------------------------------------------------------------------------------------------+// -- | Logical Set Operators: Interpreted "natively" by the SMT solver -------------------------+// ---------------------------------------------------------------------------------------------- --- | union+// union measure Set_cup  :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a) --- | intersection+// intersection measure Set_cap  :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a) --- | difference+// difference measure Set_dif   :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a) --- | singleton+// singleton measure Set_sng   :: a -> (Data.Set.Set a) --- | emptiness test+// emptiness test measure Set_emp   :: (Data.Set.Set a) -> Prop --- | empty set +// empty set measure Set_empty :: forall a. GHC.Types.Int -> (Data.Set.Set a)  --- | membership test+// membership test measure Set_mem  :: a -> (Data.Set.Set a) -> Prop --- | inclusion test-measure Set_sub  :: (Data.Set.Set a) -> (Data.Set.Set a) -> Prop +// inclusion test+measure Set_sub  :: (Data.Set.Set a) -> (Data.Set.Set a) -> Prop ------------------------------------------------------------------------------------------------- | Refined Types for Data.Set Operations ------------------------------------------------------------------------------------------------------------------------------------------------+// ---------------------------------------------------------------------------------------------+// -- | Refined Types for Data.Set Operations --------------------------------------------------+// ---------------------------------------------------------------------------------------------  isSubsetOf    :: (GHC.Classes.Ord a) => x:(Data.Set.Set a) -> y:(Data.Set.Set a) -> {v:Bool | ((Prop v) <=> (Set_sub x y))} member        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:Bool | ((Prop v) <=> (Set_mem x xs))}@@ -49,10 +49,10 @@  fromList :: GHC.Classes.Ord a => xs:[a] -> {v:Data.Set.Set a | v = (listElts xs)} ------------------------------------------------------------------------------------------------- | The set of elements in a list --------------------------------------------------------------------------------------------------------------------------------------------------------+// ---------------------------------------------------------------------------------------------+// -- | The set of elements in a list ----------------------------------------------------------+// --------------------------------------------------------------------------------------------- -measure listElts :: [a] -> (Data.Set.Set a) +measure listElts :: [a] -> (Data.Set.Set a) listElts([])   = {v | (Set_emp v)} listElts(x:xs) = {v | v = (Set_cup (Set_sng x) (listElts xs)) }
+ include/Data/Tuple.spec view
@@ -0,0 +1,4 @@+module spec Data.Tuple where++fst :: x:(a,b) -> {v:a | v = (fst x)}+snd :: x:(a,b) -> {v:b | v = (snd x)}
include/Data/Vector.hquals view
@@ -1,3 +1,13 @@-qualif VecEmpty(v: Vector a)              : vlen([v]) [ = ; > ; >= ]  0 -qualif Vlen(v:int, ~A: Vector a)          : v [ = ; <= ; < ]  vlen([~A]) -qualif CmpVlen(v: Vector a, ~A: Vector b) : vlen([v]) [ < ; <= ; > ; >= ; = ] vlen([~A]) +qualif VecEmpty(v: Vector a)             : (vlen v)  =  0 +qualif VecEmpty(v: Vector a)             : (vlen v)  >  0 +qualif VecEmpty(v: Vector a)             : (vlen v)  >= 0 ++qualif Vlen(v:int, x: Vector a)          : (v  =  vlen x)+qualif Vlen(v:int, x: Vector a)          : (v <=  vlen x) +qualif Vlen(v:int, x: Vector a)          : (v  <  vlen x) ++qualif CmpVlen(v: Vector a, x: Vector b) : (vlen v <  vlen x) +qualif CmpVlen(v: Vector a, x: Vector b) : (vlen v <= vlen x) +qualif CmpVlen(v: Vector a, x: Vector b) : (vlen v >  vlen x) +qualif CmpVlen(v: Vector a, x: Vector b) : (vlen v >= vlen x) +qualif CmpVlen(v: Vector a, x: Vector b) : (vlen v =  vlen x)
include/Foreign/ForeignPtr.spec view
@@ -9,5 +9,5 @@  Foreign.ForeignPtr.newForeignPtr :: Foreign.ForeignPtr.FinalizerPtr a -> p:(PtrV a) -> (GHC.Types.IO (ForeignPtrN a (plen p))) --- this uses `sizeOf (undefined :: a)`, so the ForeignPtr does not necessarily have length `n`--- Foreign.ForeignPtr.Imp.mallocForeignPtrArray :: (Foreign.Storable.Storable a) => n:Nat -> IO (ForeignPtrN a n)+// this uses `sizeOf (undefined :: a)`, so the ForeignPtr does not necessarily have length `n`+// Foreign.ForeignPtr.Imp.mallocForeignPtrArray :: (Foreign.Storable.Storable a) => n:Nat -> IO (ForeignPtrN a n)
include/Foreign/Storable.spec view
@@ -1,8 +1,9 @@ module spec Foreign.Storable where  import Foreign.Ptr--- DON'T do this, we can't import HS files from SPEC files--- import Language.Haskell.Liquid.Foreign++// DON'T do this, we can't import HS files from SPEC files+// import Language.Haskell.Liquid.Foreign  predicate PValid P N         = ((0 <= N) && (N < (plen P)))
include/GHC/Base.hquals view
@@ -2,10 +2,29 @@ //qualif Null(v: [a])           : (~ (? (nonnull([v])))) //qualif EqNull(v:Bool, ~A: [a]): (Prop(v) <=> (? (nonnull([~A])))) -qualif IsEmp(v:GHC.Types.Bool, ~A: [a]) : (Prop(v) <=> len([~A]) [ > ;  = ] 0)-qualif ListZ(v: [a])          : len([v]) [ = ; >= ; > ] 0 -qualif CmpLen(v:[a], ~A:[b])  : len([v]) [= ; >=; >; <=; <] len([~A]) -qualif EqLen(v:int, ~A: [a])  : v = len([~A]) -qualif LenEq(v:[a], ~A: int)  : ~A = len([v]) -qualif LenAcc(v:int, ~A:[a], ~B: int): v = len([~A]) + ~B-qualif LenDiff(v:[a], ~A:int): len([v]) = (~A [ +; - ] 1)+// qualif IsEmp(v:GHC.Types.Bool, ~A: [a]) : (Prop(v) <=> len([~A]) [ > ;  = ] 0)+// qualif ListZ(v: [a])          : len([v]) [ = ; >= ; > ] 0 +// qualif CmpLen(v:[a], ~A:[b])  : len([v]) [= ; >=; >; <=; <] len([~A]) +// qualif EqLen(v:int, ~A: [a])  : v = len([~A]) +// qualif LenEq(v:[a], ~A: int)  : ~A = len([v]) +// qualif LenAcc(v:int, ~A:[a], ~B: int): v = len([~A]) + ~B+// qualif LenDiff(v:[a], ~A:int): len([v]) = (~A [ +; - ] 1)++qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (Prop(v) <=> len([xs]) > 0)+qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (Prop(v) <=> len([xs]) = 0)++qualif ListZ(v: [a])          : (len([v]) =  0) +qualif ListZ(v: [a])          : (len([v]) >= 0) +qualif ListZ(v: [a])          : (len([v]) >  0) ++qualif CmpLen(v:[a], xs:[b])  : (len([v]) =  len([xs])) +qualif CmpLen(v:[a], xs:[b])  : (len([v]) >= len([xs])) +qualif CmpLen(v:[a], xs:[b])  : (len([v]) >  len([xs])) +qualif CmpLen(v:[a], xs:[b])  : (len([v]) <= len([xs])) +qualif CmpLen(v:[a], xs:[b])  : (len([v]) <  len([xs])) ++qualif EqLen(v:int, xs: [a])  : (v = len([xs])) +qualif LenEq(v:[a], x: int)   : (x = len([v])) +qualif LenDiff(v:[a], x:int)  : (len([v]) = x + 1)+qualif LenDiff(v:[a], x:int)  : (len([v]) = x - 1)+qualif LenAcc(v:int, xs:[a], n: int): (v = len([xs]) + n)
include/GHC/CString.spec view
@@ -2,6 +2,4 @@  import GHC.Prim  --- The equality is untyped, but there is an implicit logic cast-GHC.CString.unpackCString# :: x:GHC.Prim.Addr# -> {v:String | v = x}-+GHC.CString.unpackCString# :: x:GHC.Prim.Addr# -> {v:String | v ~~ x}
include/GHC/Real.spec view
@@ -1,21 +1,25 @@ module spec GHC.Real where - GHC.Real.fromIntegral    :: (GHC.Real.Integral a, GHC.Num.Num b) => x:a -> {v:b|v=x} +class (GHC.Num.Num a) => GHC.Real.Fractional a where+  (GHC.Real./)   :: x:a -> y:{v:a | v /= 0} -> {v:a | v == x / y}+  GHC.Real.recip :: a -> a+  GHC.Real.fromRational :: GHC.Real.Rational -> a+ class (GHC.Real.Real a, GHC.Enum.Enum a) => GHC.Real.Integral a where   GHC.Real.quot :: a -> {v:a | v /= 0} -> a   GHC.Real.rem :: a -> {v:a | v /= 0} -> a   GHC.Real.mod :: x:a -> y:{v:a | v /= 0} -> {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))}-  GHC.Real.div :: x:a -> y:{v:a | v /= 0} -> {v:a | ((v = (x / y))-                                     && (((x>=0) && (y>=0)) => (v>=0))-                                     && (((x>=0) && (y>=1)) => (v<=x))) }-  GHC.Real.quotRem :: x:a -> y:{v:a | v /= 0} -> ({v:a | ((v = (x / y))-                                          && (((x>=0) && (y>=0)) => (v>=0))-                                          && (((x>=0) && (y>=1)) => (v<=x)))}-                                    ,{v:a | ((v >= 0) && (v < y))})+  GHC.Real.div :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&+                                                    ((x >= 0 && y >= 0) => v >= 0) &&+                                                    ((x >= 0 && y >= 1) => v <= x) }+  GHC.Real.quotRem :: x:a -> y:{v:a | v /= 0} -> ( {v:a | (v = (x / y)) &&+                                                          ((x >= 0 && y >= 0) => v >= 0) &&+                                                          ((x >= 0 && y >= 1) => v <= x)}+                                                 , {v:a | ((v >= 0) && (v < y))})   GHC.Real.divMod :: a -> {v:a | v /= 0} -> (a, a)   GHC.Real.toInteger :: x:a -> {v:GHC.Integer.Type.Integer | v = x} --- fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here--- mod :: x:a -> y:a -> {v:a | v = (x mod y) }+// fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here+// mod :: x:a -> y:a -> {v:a | v = (x mod y) }
include/GHC/Types.spec view
@@ -1,6 +1,6 @@ module spec GHC.Types where --- TODO: Drop prefix below+// TODO: Drop prefix below GHC.Types.EQ :: {v:GHC.Types.Ordering | v = (cmp v) } GHC.Types.LT :: {v:GHC.Types.Ordering | v = (cmp v) } GHC.Types.GT :: {v:GHC.Types.Ordering | v = (cmp v) }
include/Language/Haskell/Liquid/Prelude.hs view
@@ -128,3 +128,12 @@ safeZipWith _ _ _ = error "safeZipWith: cannot happen!"        +++{-@ (==>) :: p:Bool -> q:Bool -> {v:Bool | Prop v <=> (Prop p =>  Prop q)} @-}+infixr 8 ==>+(==>) :: Bool -> Bool -> Bool+False ==> False = True+False ==> True  = True+True  ==> True  = True+True  ==> False = False
include/Prelude.hquals view
@@ -1,30 +1,47 @@ //BOT: Do not delete EVER! -qualif Bot(v:@(0))    : 0 = 1 -qualif Bot(v:obj)     : 0 = 1 -qualif Bot(v:a)       : 0 = 1 -qualif Bot(v:bool)    : 0 = 1 -qualif Bot(v:int)     : 0 = 1 -qualif CmpZ(v:a)      : v [ < ; <= ; > ; >= ; = ; != ] 0-qualif Cmp(v:a,~A:a)  : v [ < ; <= ; > ; >= ; = ; != ] ~A-qualif Cmp(v:int,~A:int)  : v [ < ; <= ; > ; >= ; = ; != ] ~A+qualif Bot(v:@(0))    : (0 = 1) +qualif Bot(v:obj)     : (0 = 1) +qualif Bot(v:a)       : (0 = 1) +qualif Bot(v:bool)    : (0 = 1) +qualif Bot(v:int)     : (0 = 1) ++qualif CmpZ(v:a)      : (v <  0) +qualif CmpZ(v:a)      : (v <= 0)+qualif CmpZ(v:a)      : (v >  0)+qualif CmpZ(v:a)      : (v >= 0)+qualif CmpZ(v:a)      : (v  = 0)+qualif CmpZ(v:a)      : (v != 0)++qualif Cmp(v:a, x:a)  : (v <  x) +qualif Cmp(v:a, x:a)  : (v <= x)+qualif Cmp(v:a, x:a)  : (v >  x)+qualif Cmp(v:a, x:a)  : (v >= x)+qualif Cmp(v:a, x:a)  : (v  = x)+qualif Cmp(v:a, x:a)  : (v != x)++// qualif CmpZ(v:a)        : v [ < ; <= ; > ; >= ; = ; != ] 0+// qualif Cmp(v:a,x:a)     : v [ < ; <= ; > ; >= ; = ; != ] x+// qualif Cmp(v:int,x:int) : v [ < ; <= ; > ; >= ; = ; != ] x++ qualif One(v:int)     : v = 1 qualif True(v:bool)   : (? v)  qualif False(v:bool)  : ~ (? v) -qualif True1(v:GHC.Types.Bool)   : Prop(v)-qualif False1(v:GHC.Types.Bool)  : ~ Prop(v)+qualif True1(v:GHC.Types.Bool)   : (Prop(v))+qualif False1(v:GHC.Types.Bool)  : (~ Prop(v))  -qualif Papp(v:a,~P:Pred a) : papp1(~P, v)+qualif Papp(v:a,p:Pred a) : (papp1(p, v)) constant papp1 : func(1, [Pred @(0); @(0); bool]) -qualif Papp2(v:a,~X:b,~P:Pred a b) : papp2(~P, v, ~X)+qualif Papp2(v:a,x:b,p:Pred a b) : (papp2(p, v, x)) constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool]) -qualif Papp3(v:a,~X:b, ~Y:c, ~P:Pred a b c) : papp3(~P, v, ~X, ~Y)+qualif Papp3(v:a,x:b, y:c, p:Pred a b c) : (papp3(p, v, x, y)) constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool]) -// qualif Papp4(v:a,~X:b, ~Y:c, ~Z:d, ~P:Pred a b c d) : papp4(~P, v, ~X, ~Y, ~Z)+// qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d) : papp4(p, v, x, y, z) constant papp4 : func(8, [Pred @(0) @(1) @(2) @(6); @(3); @(4); @(5); @(7); bool])
include/Prelude.spec view
@@ -13,12 +13,11 @@  GHC.Exts.D# :: x:_ -> {v:_ | v = x} -assume GHC.Base..               :: forall< p :: xx:b -> c -> Prop-                                         , q :: yy:a -> b -> Prop>.-                                      f:(x:b -> c<p x>) ->-                                      g:(y:a -> b<q y>) ->-                                      x:a ->-                                      exists[z:b<q x>].c<p z>+assume GHC.Base.. :: forall <p :: b -> c -> Prop, q :: a -> b -> Prop, r :: a -> c -> Prop>. +                     {xcmp::a, wcmp::b<q xcmp> |- c<p wcmp> <: c<r xcmp>}+                     (ycmp:b -> c<p ycmp>)+                  -> (zcmp:a -> b<q zcmp>)+                  ->  xcmp:a -> c<r xcmp> assume GHC.Integer.smallInteger :: x:GHC.Prim.Int#                                 -> { v:GHC.Integer.Type.Integer |                                      v = (x :: int) }
include/len.hquals view
@@ -1,5 +1,7 @@ -//Qualifiers about complex length relationships+// Qualifiers about complex length relationships+// qualif LenSum(v:[a], ~A:[b], ~B:[c]): len([v]) = (len([~A]) [ +; - ] len([~B])) -qualif LenSum(v:[a], ~A:[b], ~B:[c]): len([v]) = (len([~A]) [ +; - ] len([~B]))+qualif LenSum(v:[a], xs:[b], ys:[c]): len([v]) = (len([xs]) + len([ys]))+qualif LenSum(v:[a], xs:[b], ys:[c]): len([v]) = (len([xs]) - len([ys]))
liquidhaskell.cabal view
@@ -1,5 +1,5 @@ Name:                liquidhaskell-Version:             0.3.1.0+Version:             0.4.0.0 Copyright:           2010-15 Ranjit Jhala, University of California, San Diego. build-type:          Simple Synopsis:            Liquid Types for Haskell @@ -34,13 +34,17 @@           , include/System/*.spec           , syntax/liquid.css +extra-source-files: tests/pos/*.hs+                  , tests/neg/*.hs+                  , tests/crash/*.hs+ Source-Repository head   Type:        git   Location:    https://github.com/ucsd-progsys/liquidhaskell/  --Flag devel --  Description: turn on stricter error reporting for development---  Default:     False+--  Default:     True  Executable liquid   default-language: Haskell98@@ -79,9 +83,9 @@                , liquidhaskell    Main-is: Liquid.hs-  ghc-options: -W-  -- if flag(devel)-  --   ghc-options: -Werror+--  ghc-options: -W+--  if flag(devel)+--    ghc-options: -Werror   Default-Extensions: PatternGuards  -- Executable liquid-count-binders@@ -150,7 +154,7 @@                 , vector                 , hashable                 , unordered-containers-                , liquid-fixpoint >= 0.2.3.0+                , liquid-fixpoint >= 0.3                 , aeson                 , bytestring                 , fingertree@@ -171,6 +175,7 @@                     Language.Haskell.Liquid.GhcInterface,                      Language.Haskell.Liquid.World,                      Language.Haskell.Liquid.RefType, +                    Language.Haskell.Liquid.RefSplit,                      Language.Haskell.Liquid.Errors,                      Language.Haskell.Liquid.PredType,                      Language.Haskell.Liquid.ACSS, @@ -184,6 +189,7 @@                     Language.Haskell.Liquid.Misc,                      Language.Haskell.Liquid.CoreToLogic,                     Language.Haskell.Liquid.Variance,+                    Language.Haskell.Liquid.Bounds,                     Language.Haskell.Liquid.Dictionaries,                     Language.Haskell.Liquid.Qualifier,                      Language.Haskell.Liquid.TransformRec, @@ -231,10 +237,10 @@                     Language.Haskell.Liquid.Desugar.DsBinds,                     Language.Haskell.Liquid.Desugar.DsGRHSs,                     Language.Haskell.Liquid.Desugar.HscMain-   ghc-options: -W-   -- if flag(devel)-   --   ghc-options: -Werror-   ghc-prof-options: -fprof-auto+--   ghc-options: -W+--   if flag(devel)+--     ghc-options: -Werror+--   ghc-prof-options: -fprof-auto    Default-Extensions: PatternGuards  test-suite test
src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -5,7 +5,6 @@ module Language.Haskell.Liquid.Bare.Check (     checkGhcSpec -  , checkDefAsserts   , checkTerminationExpr   , checkTy   ) where@@ -22,22 +21,19 @@ import Control.Monad.Writer import Data.Maybe import Text.PrettyPrint.HughesPJ-import Text.Printf  import qualified Data.List           as L import qualified Data.HashMap.Strict as M-import qualified Data.HashSet        as S -import Language.Fixpoint.Misc (applyNonNull, group, mapSnd, snd3, errorstar, safeHead)-import Language.Fixpoint.Names (isPrefixOfSym, stripParensSym)+import Language.Fixpoint.Misc (applyNonNull, group, mapSnd, errorstar, safeHead) import Language.Fixpoint.Sort (checkSorted, checkSortedReftFull, checkSortFull) import Language.Fixpoint.Types hiding (R) -import Language.Haskell.Liquid.GhcMisc (showPpr, sourcePosSrcSpan)-import Language.Haskell.Liquid.Misc (dropThd3, firstDuplicate)+import Language.Haskell.Liquid.GhcMisc (realTcArity, showPpr, sourcePosSrcSpan)+import Language.Haskell.Liquid.Misc (firstDuplicate, snd4) import Language.Haskell.Liquid.PredType (pvarRType, wiredSortedSyms) import Language.Haskell.Liquid.PrettyPrint (pprintSymbol)-import Language.Haskell.Liquid.RefType (classBinds, ofType, rTypeSort, rTypeSortedReft, subsTyVars_meet)+import Language.Haskell.Liquid.RefType (classBinds, ofType, rTypeSort, rTypeSortedReft, subsTyVars_meet, toType) import Language.Haskell.Liquid.Types  import qualified Language.Haskell.Liquid.Measure as Ms@@ -56,7 +52,7 @@              -> Either [Error] GhcSpec  checkGhcSpec specs env sp =  applyNonNull (Right sp) Left errors-  where +  where     errors           =  mapMaybe (checkBind "constructor" emb tcEnv env) (dcons      sp)                      ++ mapMaybe (checkBind "measure"     emb tcEnv env) (meas       sp)                      ++ mapMaybe (checkInv  emb tcEnv env)               (invariants sp)@@ -67,17 +63,18 @@                      ++ checkDuplicate                             (asmSigs sp)                      ++ checkDupIntersect                          (tySigs sp) (asmSigs sp)                      ++ checkRTAliases "Type Alias" env            tAliases-                     ++ checkRTAliases "Pred Alias" env            pAliases +                     ++ checkRTAliases "Pred Alias" env            pAliases                      ++ checkDuplicateFieldNames                   (dconsP sp)                      ++ checkRefinedClasses                        (concatMap (Ms.classes . snd) specs) (concatMap (Ms.rinstance . snd) specs)       tAliases         =  concat [Ms.aliases sp  | (_, sp) <- specs]     pAliases         =  concat [Ms.paliases sp | (_, sp) <- specs]-    dcons spec       =  [(v, Loc l t) | (v,t)   <- dataConSpec (dconsP spec) -                                      | (_,dcp) <- dconsP spec-                                      , let l = dc_loc dcp-                                      ]+    dcons spec       =  [(v, Loc l l' t) | (v,t)   <- dataConSpec (dconsP spec)+                                         | (_,dcp) <- dconsP spec+                                         , let l    = dc_loc  dcp+                                         , let l'   = dc_locE dcp+                                         ]     emb              =  tcEmbeds sp     tcEnv            =  tyconEnv sp     ms               =  measures sp@@ -86,7 +83,7 @@ checkRefinedClasses :: [RClass BareType] -> [RInstance BareType] -> [Error] checkRefinedClasses definitions instances   = mkError <$> duplicates-  where +  where     duplicates       = mapMaybe checkCls (rcName <$> definitions)     checkCls cls@@ -107,63 +104,68 @@ checkDuplicateFieldNames = catMaybes . map go   where     go (d, dts)        = checkNoDups (dc_loc dts) d (fst <$> tyArgs dts)-    checkNoDups l d xs = mkErr l d <$> firstDuplicate xs +    checkNoDups l d xs = mkErr l d <$> firstDuplicate xs -    mkErr l d x = ErrBadData (sourcePosSrcSpan l) -                             (pprint d) +    mkErr l d x = ErrBadData (sourcePosSrcSpan l)+                             (pprint d)                              (text "Multiple declarations of record selector" <+> pprintSymbol x)  checkInv :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> Located SpecType -> Maybe Error-checkInv emb tcEnv env t   = checkTy err emb tcEnv env (val t) -  where -    err              = ErrInvt (sourcePosSrcSpan $ loc t) (val t) +checkInv emb tcEnv env t   = checkTy err emb tcEnv env (val t)+  where+    err              = ErrInvt (sourcePosSrcSpan $ loc t) (val t)  checkIAl :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> [(Located SpecType, Located SpecType)] -> [Error] checkIAl emb tcEnv env ials = catMaybes $ concatMap (checkIAlOne emb tcEnv env) ials  checkIAlOne emb tcEnv env (t1, t2) = checkEq : (tcheck <$> [t1, t2])-  where +  where     tcheck t = checkTy (err t) emb tcEnv env (val t)-    err    t = ErrIAl (sourcePosSrcSpan $ loc t) (val t) -    t1'      :: RSort +    err    t = ErrIAl (sourcePosSrcSpan $ loc t) (val t)+    t1'      :: RSort     t1'      = toRSort $ val t1-    t2'      :: RSort +    t2'      :: RSort     t2'      = toRSort $ val t2     checkEq  = if (t1' == t2') then Nothing else Just errmis     errmis   = ErrIAlMis (sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg-    emsg     = pprint t1 <+> text "does not match with" <+> pprint t2 +    emsg     = pprint t1 <+> text "does not match with" <+> pprint t2   -- FIXME: Should _ be removed if it isn't used? checkRTAliases msg _ as = err1s-  where +  where     err1s                  = checkDuplicateRTAlias msg as -checkBind :: (PPrint v) => String -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error -checkBind s emb tcEnv env (v, Loc l t) = checkTy msg emb tcEnv env' t-  where -    msg                      = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t +checkBind :: (PPrint v) => String -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error+checkBind s emb tcEnv env (v, Loc l _ t) = checkTy msg emb tcEnv env' t+  where+    msg                      = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t     env'                     = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms -checkTerminationExpr :: (Eq v, PPrint v) => TCEmb TyCon -> SEnv SortedReft -> (v, Located SpecType, [Expr])-> Maybe Error -checkTerminationExpr emb env (v, Loc l t, es) = (mkErr <$> go es) <|> (mkErr' <$> go' es)-  where +checkTerminationExpr :: (Eq v, PPrint v) => TCEmb TyCon -> SEnv SortedReft -> (v, Located SpecType, [Expr])-> Maybe Error+checkTerminationExpr emb env (v, Loc l _ t, es) = (mkErr <$> go es) <|> (mkErr' <$> go' es)+  where     mkErr   = uncurry (ErrTermSpec (sourcePosSrcSpan l) (text "termination expression" <+> pprint v))     mkErr'  = uncurry (ErrTermSpec (sourcePosSrcSpan l) (text "termination expression is not numeric"))     go      = foldl (\err e -> err <|> fmap (e,) (checkSorted env' e)) Nothing     go'     = foldl (\err e -> err <|> fmap (e,) (checkSorted env' (cmpZero e))) Nothing     env'    = foldl (\e (x, s) -> insertSEnv x s e) env'' wiredSortedSyms-    env''   = mapSEnv sr_sort $ foldl (\e (x,s) -> insertSEnv x s e) env xss-    xss     = mapSnd rSort <$> (uncurry zip $ dropThd3 $ bkArrowDeep t)+    env''   = sr_sort <$> foldl (\e (x,s) -> insertSEnv x s e) env xts+    xts     = concatMap mkClass $ zip (ty_binds trep) (ty_args trep)+    trep    = toRTypeRep t++    mkClass (_, (RApp c ts _ _)) | isClass c = classBinds (rRCls c ts)+    mkClass (x, t)                           = [(x, rSort t)]+     rSort   = rTypeSortedReft emb-    cmpZero = PAtom Le zero +    cmpZero = PAtom Le $ expr (0 :: Int) -- zero  checkTy :: (Doc -> Error) -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> SpecType -> Maybe Error checkTy mkE emb tcEnv env t = mkE <$> checkRType emb env (txRefSort tcEnv emb t)  checkDupIntersect     :: [(Var, Located SpecType)] -> [(Var, Located SpecType)] -> [Error] checkDupIntersect xts mxts = concatMap mkWrn dups-  where +  where     mkWrn (x, t)     = pprWrn x (sourcePosSrcSpan $ loc t)     dups             = L.intersectBy (\x y -> (fst x == fst y)) mxts xts     pprWrn v l       = trace ("WARNING: Assume Overwrites Specifications for "++ show v ++ " : " ++ showPpr l) []@@ -177,9 +179,9 @@ checkDuplicateRTAlias :: String -> [RTAlias s a] -> [Error] checkDuplicateRTAlias s tas = mkErr <$> dups   where-    mkErr xs@(x:_)          = ErrDupAlias (sourcePosSrcSpan $ rtPos x) -                                          (text s) -                                          (pprint $ rtName x) +    mkErr xs@(x:_)          = ErrDupAlias (sourcePosSrcSpan $ rtPos x)+                                          (text s)+                                          (pprint $ rtName x)                                           (sourcePosSrcSpan . rtPos <$> xs)     mkErr []                = error "mkError: called on empty list"     dups                    = [z | z@(_:_:_) <- L.groupBy (\x y -> rtName x == rtName y) tas]@@ -188,32 +190,79 @@  checkMismatch        :: (Var, Located SpecType) -> Maybe Error checkMismatch (x, t) = if ok then Nothing else Just err-  where +  where     ok               = tyCompat x (val t)     err              = errTypeMismatch x t  tyCompat x t         = lhs == rhs-  where +  where     lhs :: RSort     = toRSort t     rhs :: RSort     = ofType $ varType x  errTypeMismatch     :: Var -> Located SpecType -> Error-errTypeMismatch x t = ErrMismatch (sourcePosSrcSpan $ loc t) (pprint x) (varType x) (val t)+errTypeMismatch x t = ErrMismatch (sourcePosSrcSpan $ loc t) (pprint x) (varType x) (toType $ val t)  ------------------------------------------------------------------------------------------------ -- | @checkRType@ determines if a type is malformed in a given environment --------------------- -------------------------------------------------------------------------------------------------checkRType :: (PPrint r, Reftable r) => TCEmb TyCon -> SEnv SortedReft -> RRType (UReft r) -> Maybe Doc +checkRType :: (PPrint r, Reftable r) => TCEmb TyCon -> SEnv SortedReft -> RRType (UReft r) -> Maybe Doc ------------------------------------------------------------------------------------------------ -checkRType emb env t         = checkAbstractRefs t <|> efoldReft cb (rTypeSortedReft emb) f insertPEnv env Nothing t -  where +checkRType emb env t         = checkAppTys t <|> checkFunRefs t <|> checkAbstractRefs t <|> efoldReft cb (rTypeSortedReft emb) f insertPEnv env Nothing t+  where     cb c ts                  = classBinds (rRCls c ts)     f env me r err           = err <|> checkReft env emb me r-    insertPEnv p γ           = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p) -    pbinds p                 = (pname p, pvarRType p :: RSort) +    insertPEnv p γ           = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p)+    pbinds p                 = (pname p, pvarRType p :: RSort)                               : [(x, t) | (t, x, _) <- pargs p] +checkAppTys t = go t+  where+    go (RAllT _ t)      = go t+    go (RAllP _ t)      = go t+    go (RAllS _ t)      = go t+    go (RApp rtc ts _ _)+      = checkTcArity rtc (length ts) <|>+        foldl (\merr t -> merr <|> go t) Nothing ts+    go (RFun _ t1 t2 _) = go t1 <|> go t2+    go (RVar _ _)       = Nothing+    go (RAllE _ t1 t2)  = go t1 <|> go t2+    go (REx _ t1 t2)    = go t1 <|> go t2+    go (RAppTy t1 t2 _) = go t1 <|> go t2+    go (RRTy _ _ _ t)   = go t+    go (RExprArg _)     = Just $ text "Logical expressions cannot appear inside a Haskell type"+    go (RHole _)        = Nothing++checkTcArity (RTyCon { rtc_tc = tc }) givenArity+  | expectedArity < givenArity+    = Just $ text "Type constructor" <+> pprint tc+        <+> text "expects a maximum" <+> pprint expectedArity+        <+> text "arguments but was given" <+> pprint givenArity+        <+> text "arguments"+  | otherwise+    = Nothing+  where expectedArity = realTcArity tc+++checkFunRefs t = go t+  where+    go (RAllT _ t)      = go t+    go (RAllP _ t)      = go t+    go (RAllS _ t)      = go t+    go (RApp _ ts _ _)  = foldl (\merr t -> merr <|> go t) Nothing ts+    go (RVar _ _)       = Nothing+    go (RAllE _ t1 t2)  = go t1 <|> go t2+    go (REx _ t1 t2)    = go t1 <|> go t2+    go (RAppTy t1 t2 _) = go t1 <|> go t2+    go (RRTy _ _ _ t)   = go t+    go (RExprArg _)     = Nothing+    go (RHole _)        = Nothing+    go (RFun _ t1 t2 r)+      | isTauto r+        = go t1 <|> go t2+      | otherwise+        = Just $ text "Function types cannot have refinements:" <+> (pprint r)+ checkAbstractRefs t = go t   where     penv = mkPEnv t@@ -233,37 +282,42 @@      go' c rs = foldl (\acc (x, y) -> acc <|> checkOne' x y) Nothing (zip rs (rTyConPVs c)) -    checkOne' (RProp xs t) p -      | pvType p /= toRSort t +    checkOne' (RProp xs t) p+      | pvType p /= toRSort t       = Just $ text "Unexpected Sort in" <+> pprint p-      | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]  +      | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]       = Just $ text "Wrong Arguments in" <+> pprint p-      | length xs /= length (pargs p) +      | length xs /= length (pargs p)       = Just $ text "Wrong Number of Arguments in" <+> pprint p-      | otherwise  +      | otherwise       = go t-    checkOne' (RPropP xs _) p -      | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]  +    checkOne' (RPropP xs _) p+      | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]       = Just $ text "Wrong Arguments in" <+> pprint p-      | length xs /= length (pargs p) +      | length xs /= length (pargs p)       = Just $ text "Wrong Number of Arguments in" <+> pprint p-      | otherwise  -      = Nothing -    checkOne' _ _ = errorstar "This cannot happen"  +      | otherwise+      = Nothing+    checkOne' _ _ = errorstar "This cannot happen" -    efold f = foldl (\acc x -> acc <|> f x) Nothing +    efold f = foldl (\acc x -> acc <|> f x) Nothing      check s (U _ (Pr ps) _) = foldl (\acc pp -> acc <|> checkOne s pp) Nothing ps -    checkOne s p | pvType' p /= s                          -                 = Just $ text "Incorrect Sort"        <+> pprint p-                 | or [x == y | (_, x, EVar y) <- pargs p] +    checkOne s p | pvType' p /= s+                 = Just $ text "Incorrect Sort:\n\t"+                       <+> text "Abstract refinement with type"+                       <+> pprint (pvType' p)+                       <+> text "is applied to"+                       <+> pprint s+                       <+> text "\n\t In" <+> pprint p+                 | or [x == y | (_, x, EVar y) <- pargs p]                  = Just $ text "Missing arguments on " <+> pprint p-                 | otherwise                               -                 = Nothing +                 | otherwise+                 = Nothing      mkPEnv (RAllT _ t) = mkPEnv t-    mkPEnv (RAllP p t) = p:mkPEnv t +    mkPEnv (RAllP p t) = p:mkPEnv t     mkPEnv _           = []      pvType' p = safeHead (showpp p ++ " not in env of " ++ showpp t) [pvType q | q <- penv, pname p == pname q]@@ -271,23 +325,23 @@   -checkReft                    :: (PPrint r, Reftable r) => SEnv SortedReft -> TCEmb TyCon -> Maybe (RRType (UReft r)) -> (UReft r) -> Maybe Doc -checkReft _   _   Nothing _  = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.  -checkReft env emb (Just t) _ = (dr $+$) <$> checkSortedReftFull env' r -  where +checkReft                    :: (PPrint r, Reftable r) => SEnv SortedReft -> TCEmb TyCon -> Maybe (RRType (UReft r)) -> (UReft r) -> Maybe Doc+checkReft _   _   Nothing _  = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.+checkReft env emb (Just t) _ = (dr $+$) <$> checkSortedReftFull env' r+  where     r                        = rTypeSortedReft emb t-    dr                       = text "Sort Error in Refinement:" <+> pprint r +    dr                       = text "Sort Error in Refinement:" <+> pprint r     env'                     = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms  -- DONT DELETE the below till we've added pred-checking as well--- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t) ---    where xs                  = fromMaybe [] $ params <$> stripRTypeBase t +-- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t)+--    where xs                  = fromMaybe [] $ params <$> stripRTypeBase t --- checkSig env (x, t) +-- checkSig env (x, t) --   = case filter (not . (`S.member` env)) (freeSymbols t) of --       [] -> TrueNGUAGE ScopedTypeVariables #-}---       ys -> errorstar (msg ys) ---     where +--       ys -> errorstar (msg ys)+--     where --       msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t)  ---------------------------------------------------------------------------------------------------@@ -298,17 +352,19 @@ checkMeasures emb env = concatMap (checkMeasure emb env)  checkMeasure :: M.HashMap TyCon FTycon -> SEnv SortedReft -> Measure SpecType DataCon -> [Error]-checkMeasure emb γ (M name@(Loc src n) sort body)+checkMeasure emb γ (M name@(Loc src _ n) sort body)   = [txerror e | Just e <- checkMBody γ emb name sort <$> body]-  where +  where     txerror = ErrMeas (sourcePosSrcSpan src) n -checkMBody γ emb _ sort (Def _ c bs body) = checkMBody' emb sort γ' body+checkMBody γ emb _ sort (Def _ as c _ bs body) = checkMBody' emb sort γ' body   where -    γ'   = L.foldl' (\γ (x, t) -> insertSEnv x t γ) γ xts-    xts  = zip bs $ rTypeSortedReft emb . subsTyVars_meet su <$> ty_args trep+    γ'   = L.foldl' (\γ (x, t) -> insertSEnv x t γ) γ (ats ++ xts)+    ats  = (mapSnd (rTypeSortedReft emb) <$> as)+    xts  = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVars_meet su <$> ty_args trep     trep = toRTypeRep ct-    su   = checkMBodyUnify (ty_res trep) (head $ snd3 $ bkArrowDeep sort)+    su   = checkMBodyUnify (ty_res trep) (last txs) +    txs  = snd4 $ bkArrowDeep sort     ct   = ofType $ dataConUserType c :: SpecType  checkMBodyUnify                 = go@@ -323,32 +379,9 @@     R s p -> checkSortFull (insertSEnv s sty γ) psort p   where     psort = FApp propFTyCon []-    sty   = rTypeSortedReft emb sort' +    sty   = rTypeSortedReft emb sort'     sort' = fromRTypeRep $ trep' { ty_vars  = [], ty_preds = [], ty_labels = []                                  , ty_binds = tail $ ty_binds trep'-                                 , ty_args  = tail $ ty_args trep'             }+                                 , ty_args  = tail $ ty_args trep'+                                 , ty_refts = tail $ ty_refts trep'            }     trep' = toRTypeRep sort---checkDefAsserts :: BareEnv -> [(Var, LocSymbol, BareType)] -> [(LocSymbol, BareType)] -> BareM ()-checkDefAsserts env vbs xbs   = applyNonNull (return ()) grumble  undefSigs-  where-    undefSigs                 = [x | (x, _) <- assertSigs, not (x `S.member` definedSigs)]-    assertSigs                = filter isTarget xbs-    definedSigs               = S.fromList $ snd3 <$> vbs-    grumble                   = mapM_ (warn . berrUnknownVar)-    moduleName                = symbol $ modName env-    isTarget                  = isPrefixOfSym moduleName . stripParensSym . val . fst--warn x = tell [x]------------------------------------------------------------------------------------------ | Tasteful Error Messages ------------------------------------------------------------------------------------------------------------------------------------------------berrUnknownVar       = berrUnknown "Variable"--berrUnknown :: (PPrint a) => String -> Located a -> String -berrUnknown thing x  = printf "[%s]\nSpecification for unknown %s : %s"  -                         thing (showpp $ loc x) (showpp $ val x)-
src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -43,58 +43,48 @@  makeConTypes' :: [DataDecl] -> [(LocSymbol, [Variance])] -> BareM ([(TyCon, TyConP)], [[(DataCon, Located DataConP)]]) makeConTypes' dcs vdcs = unzip <$> mapM (uncurry ofBDataDecl) (group dcs vdcs)-  where -        group ds vs = merge (L.sort ds) (L.sortBy (\x y -> compare (fst x) (fst y)) vs) +  where+        group ds vs = merge (L.sort ds) (L.sortBy (\x y -> compare (fst x) (fst y)) vs) -        merge (d:ds) (v:vs) +        merge (d:ds) (v:vs)           | tycName d == fst v = (Just d, Just v)  : merge ds vs           | tycName d <  fst v = (Just d, Nothing) : merge ds (v:vs)-          | otherwise          = (Nothing, Just v) : merge (d:ds) vs +          | otherwise          = (Nothing, Just v) : merge (d:ds) vs         merge []     vs  = ((Nothing,) . Just) <$> vs-        merge ds     []  = ((,Nothing) . Just) <$> ds  +        merge ds     []  = ((,Nothing) . Just) <$> ds    dataConSpec :: [(DataCon, DataConP)]-> [(Var, (RType RTyCon RTyVar RReft))] dataConSpec dcs = concatMap mkDataConIdsTy [(dc, dataConPSpecType dc t) | (dc, t) <- dcs] -meetDataConSpec xts dcs  = M.toList $ L.foldl' upd dcm xts -  where +meetDataConSpec xts dcs  = M.toList $ L.foldl' upd dcm xts+  where     dcm                  = M.fromList $ dataConSpec dcs-    upd dcm (x, t)       = M.insert x (maybe t (meetPad t) (M.lookup x dcm)) dcm--meetPad t1 t2 = -- traceShow ("meetPad: " ++ msg) $-  case (bkUniv t1, bkUniv t2) of-    ((_, π1s, ls1, _), (α2s, [], ls2, t2')) -> meet t1 (mkUnivs α2s π1s (ls1 ++ ls2) t2')-    ((α1s, [], ls1, t1'), (_, π2s, ls2, _)) -> meet (mkUnivs α1s π2s (ls1 ++ ls2) t1') t2-    _                             -> errorstar $ "meetPad: " ++ msg-  where msg = "\nt1 = " ++ showpp t1 ++ "\nt2 = " ++ showpp t2----+    upd dcm (x, t)       = M.insert x (maybe t (meet t) (M.lookup x dcm)) dcm  ofBDataDecl :: Maybe DataDecl  -> (Maybe (LocSymbol, [Variance])) -> BareM ((TyCon, TyConP), [(DataCon, Located DataConP)]) ofBDataDecl (Just (D tc as ps ls cts _ sfun)) maybe_invariance_info   = do πs         <- mapM ofBPVar ps        tc'        <- lookupGhcTyCon tc-       cts'       <- mapM (ofBDataCon lc tc' αs ps ls πs) cts+       cts'       <- mapM (ofBDataCon lc lc' tc' αs ps ls πs) cts        let tys     = [t | (_, dcp) <- cts', (_, t) <- tyArgs dcp]        let initmap = zip (uPVar <$> πs) [0..]        let varInfo = L.nub $  concatMap (getPsSig initmap True) tys-       let defaultPs = varSignToVariance varInfo <$> [0 .. (length πs - 1)]  +       let defaultPs = varSignToVariance varInfo <$> [0 .. (length πs - 1)]        let (tvarinfo, pvarinfo) = f defaultPs-       return ((tc', TyConP αs πs ls tvarinfo pvarinfo sfun), (mapSnd (Loc lc) <$> cts'))-    where -       αs             = RTV . symbolTyVar <$> as-       n              = length αs-       lc             = loc tc-       f defaultPs = case maybe_invariance_info of -           {Nothing -> ([], defaultPs); -            Just (_,is) -> (take n is, if null (drop n is) then defaultPs else (drop n is))} +       return ((tc', TyConP αs πs ls tvarinfo pvarinfo sfun), (mapSnd (Loc lc lc') <$> cts'))+    where+       αs          = RTV . symbolTyVar <$> as+       n           = length αs+       lc          = loc  tc+       lc'         = locE tc+       f defaultPs = case maybe_invariance_info of+           {Nothing -> ([], defaultPs);+            Just (_,is) -> (take n is, if null (drop n is) then defaultPs else (drop n is))}  -       varSignToVariance varsigns i = case filter (\p -> fst p == i) varsigns of +       varSignToVariance varsigns i = case filter (\p -> fst p == i) varsigns of                                 []       -> Invariant                                 [(_, b)] -> if b then Covariant else Contravariant                                 _        -> Bivariant@@ -102,26 +92,26 @@ ofBDataDecl Nothing (Just (tc, is))   = do tc'        <- lookupGhcTyCon tc        return ((tc', TyConP [] [] [] tcov tcontr Nothing), [])-  where -    (tcov, tcontr) = (is, []) +  where+    (tcov, tcontr) = (is, [])  ofBDataDecl Nothing Nothing   = errorstar $ "Bare.DataType.ofBDataDecl called on invalid inputs" -getPsSig m pos (RAllT _ t) +getPsSig m pos (RAllT _ t)   = getPsSig m pos t-getPsSig m pos (RApp _ ts rs r) -  = addps m pos r ++ concatMap (getPsSig m pos) ts +getPsSig m pos (RApp _ ts rs r)+  = addps m pos r ++ concatMap (getPsSig m pos) ts     ++ concatMap (getPsSigPs m pos) rs-getPsSig m pos (RVar _ r) +getPsSig m pos (RVar _ r)   = addps m pos r-getPsSig m pos (RAppTy t1 t2 r) +getPsSig m pos (RAppTy t1 t2 r)   = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2-getPsSig m pos (RFun _ t1 t2 r) +getPsSig m pos (RFun _ t1 t2 r)   = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1 getPsSig m pos (RHole r)-  = addps m pos r -getPsSig _ _ z +  = addps m pos r+getPsSig _ _ z   = error $ "getPsSig" ++ show z  getPsSigPs m pos (RPropP _ r) = addps m pos r@@ -132,13 +122,13 @@   where f = fromMaybe (error "Bare.addPs: notfound") . (`L.lookup` m) . uPVar  -- TODO:EFFECTS:ofBDataCon-ofBDataCon l tc αs ps ls πs (c, xts)+ofBDataCon l l' tc αs ps ls πs (c, xts)   = do c'      <- lookupGhcDataCon c        ts'     <- mapM (mkSpecType' l ps) ts        let cs   = map ofType (dataConStupidTheta c')-       let t0   = rApp tc rs (RPropP [] . pdVarReft <$> πs) mempty -       return   $ (c', DataConP l αs πs ls cs (reverse (zip xs ts')) t0)-    where +       let t0   = rApp tc rs (RPropP [] . pdVarReft <$> πs) mempty+       return   $ (c', DataConP l αs πs ls cs (reverse (zip xs ts')) t0 l')+    where        (xs, ts) = unzip xts        rs       = [rVar α | RTV α <- αs] @@ -148,6 +138,5 @@  makeTyConEmbeds' :: TCEmb (Located Symbol) -> BareM (TCEmb TyCon) makeTyConEmbeds' z = M.fromList <$> mapM tx (M.toList z)-  where +  where     tx (c, y) = (, y) <$> lookupGhcTyCon c-
src/Language/Haskell/Liquid/Bare/Env.hs view
@@ -25,13 +25,14 @@ import Control.Monad.State import Control.Monad.Writer -import qualified Control.Exception   as Ex +import qualified Control.Exception   as Ex import qualified Data.HashMap.Strict as M  import Language.Fixpoint.Types (Expr(..), Symbol, symbol, Pred)  import Language.Haskell.Liquid.Errors () import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Bounds   -----------------------------------------------------------------------------------@@ -48,7 +49,7 @@ type InlnEnv = M.HashMap Symbol TInline  data TInline = TI { tiargs :: [Symbol]-                  , tibody :: Either Pred Expr +                  , tibody :: Either Pred Expr                   } deriving (Show)  @@ -57,9 +58,10 @@                   , tcEnv    :: !TCEnv                   , rtEnv    :: !RTEnv                   , varEnv   :: ![(Symbol,Var)]-                  , hscEnv   :: HscEnv +                  , hscEnv   :: HscEnv                   , logicEnv :: LogicMap                   , inlines  :: InlnEnv+                  , bounds   :: RBEnv                   }  @@ -74,15 +76,15 @@   modify $ setModule old   return res -withVArgs l vs act = do+withVArgs l l' vs act = do   old <- gets rtEnv-  mapM_ (mkExprAlias l . symbol . showpp) vs+  mapM_ (mkExprAlias l l' . symbol . showpp) vs   res <- act   modify $ \be -> be { rtEnv = old }   return res -mkExprAlias l v-  = setRTAlias v (RTA v [] [] (RExprArg (EVar $ symbol v)) l)+mkExprAlias l l' v+  = setRTAlias v (RTA v [] [] (RExprArg (Loc l l' $ EVar $ symbol v)) l l')  setRTAlias s a =   modify $ \b -> b { rtEnv = mapRT (M.insert s a) $ rtEnv b }@@ -96,10 +98,9 @@ ------------------------------------------------------------------ execBare :: BareM a -> BareEnv -> IO (Either Error a) -------------------------------------------------------------------execBare act benv = +execBare act benv =    do z <- evalStateT (runErrorT (runWriterT act)) benv `Ex.catch` (return . Left)       case z of         Left s        -> return $ Left s-        Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++) +        Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++)                             return $ Right x-
src/Language/Haskell/Liquid/Bare/Existential.hs view
@@ -10,7 +10,7 @@  import Language.Fixpoint.Misc (errorstar, fst3) import Language.Fixpoint.Names (headSym)-import Language.Fixpoint.Types (Brel(..), Expr(..), Pred(..), Refa(..), Reft(..), Symbol, symbol, vv)+import Language.Fixpoint.Types (Expr(..), Symbol, symbol, exprReft)  import Language.Haskell.Liquid.RefType (strengthen, uTop) import Language.Haskell.Liquid.Types@@ -21,10 +21,10 @@  data ExSt = ExSt { fresh :: Int                  , emap  :: M.HashMap Symbol (RSort, Expr)-                 , pmap  :: M.HashMap Symbol RPVar +                 , pmap  :: M.HashMap Symbol RPVar                  } --- | Niki: please write more documentation for this, maybe an example? +-- | Niki: please write more documentation for this, maybe an example? -- I can't really tell whats going on... (RJ)  txExpToBind   :: SpecType -> SpecType@@ -32,19 +32,19 @@   where πs = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]  expToBindT :: SpecType -> State ExSt SpecType-expToBindT (RVar v r) +expToBindT (RVar v r)   = expToBindRef r >>= addExists . RVar v-expToBindT (RFun x t1 t2 r) +expToBindT (RFun x t1 t2 r)   = do t1' <- expToBindT t1        t2' <- expToBindT t2        expToBindRef r >>= addExists . RFun x t1' t2'-expToBindT (RAllT a t) +expToBindT (RAllT a t)   = liftM (RAllT a) (expToBindT t) expToBindT (RAllP p t)   = liftM (RAllP p) (expToBindT t) expToBindT (RAllS s t)   = liftM (RAllS s) (expToBindT t)-expToBindT (RApp c ts rs r) +expToBindT (RApp c ts rs r)   = do ts' <- mapM expToBindT ts        rs' <- mapM expToBindReft rs        expToBindRef r >>= addExists . RApp c ts' rs'@@ -58,7 +58,7 @@        t'   <- expToBindT t        return $ RRTy xts' r' o t'   where-     (xs, ts) = unzip xts +     (xs, ts) = unzip xts expToBindT t   = return t @@ -68,16 +68,16 @@ expToBindReft (RHProp _ _) = errorstar "TODO:EFFECTS:expToBindReft"  getBinds :: State ExSt (M.HashMap Symbol (RSort, Expr))-getBinds +getBinds   = do bds <- emap <$> get        modify $ \st -> st{emap = M.empty}        return bds  addExists t = liftM (M.foldlWithKey' addExist t) getBinds -addExist t x (tx, e) = RAllE x t' t+addExist t x (tx, e) = REx x t' t   where t' = (ofRSort tx) `strengthen` uTop r-        r  = Reft (vv Nothing, [RConc (PAtom Eq (EVar (vv Nothing)) e)])+        r  = exprReft e   expToBindRef :: UReft r -> State ExSt (UReft r) expToBindRef (U r (Pr p) l)@@ -96,14 +96,13 @@ expToBindExpr :: Expr ->  RSort -> State ExSt Expr expToBindExpr e@(EVar s) _ | isLower $ headSym $ symbol s   = return e-expToBindExpr e t         +expToBindExpr e t   = do s <- freshSymbol        modify $ \st -> st{emap = M.insert s (t, e) (emap st)}        return $ EVar s  freshSymbol :: State ExSt Symbol-freshSymbol +freshSymbol   = do n <- fresh <$> get        modify $ \s -> s{fresh = n+1}        return $ symbol $ "ex#" ++ show n-
src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -27,17 +27,17 @@ expandReft = txPredReft expandPred expandExpr  txPredReft :: (Pred -> BareM Pred) -> (Expr -> BareM Expr) -> RReft -> BareM RReft-txPredReft f fe (U r p l) = (\r -> U r p l) <$> txPredReft' f r-  where -    txPredReft' f (Reft (v, ras)) = Reft . (v,) <$> mapM (txPredRefa f) ras-    txPredRefa  f (RConc p)       = fmap RConc $ (f <=< mapPredM fe) p-    txPredRefa  _ z               = return z+txPredReft f fe u = (\r -> u {ur_reft = r}) <$> txPredReft' (ur_reft u)+  where+    txPredReft' (Reft (v, ra)) = Reft . (v,) <$> txPredRefa ra+    txPredRefa  (Refa p)       = Refa        <$> (f <=< mapPredM fe) p  mapPredM :: (Expr -> BareM Expr) -> Pred -> BareM Pred mapPredM f = go   where     go PTrue           = return PTrue     go PFalse          = return PFalse+    go p@(PKVar _ _)   = return p     go (PAnd ps)       = PAnd <$> mapM go ps     go (POr ps)        = POr  <$> mapM go ps     go (PNot p)        = PNot <$> go p@@ -46,6 +46,7 @@     go (PBexp e)       = PBexp <$> f e     go (PAtom b e1 e2) = PAtom b <$> f e1 <*> f e2     go (PAll xs p)     = PAll xs <$> go p+    -- go (PExist xs p)   = PExist xs <$> go p     go PTop            = return PTop  --------------------------------------------------------------------------------@@ -54,7 +55,7 @@  expandPred :: Pred -> BareM Pred -expandPred p@(PBexp (EApp (Loc l f') es))+expandPred p@(PBexp (EApp (Loc l _ f') es))   = do env <- gets (predAliases.rtEnv)        return $          case M.lookup f' env of@@ -64,39 +65,30 @@              p expandPred p@(PBexp _)   = return p- expandPred (PAnd ps)   = PAnd <$> mapM expandPred ps expandPred (POr ps)   = POr <$> mapM expandPred ps- expandPred (PNot p)   = PNot <$> expandPred p-expandPred (PAll xts p)-  = PAll xts <$> expandPred p- expandPred (PImp p q)   = PImp <$> expandPred p <*> expandPred q expandPred (PIff p q)   = PIff <$> expandPred p <*> expandPred q--expandPred p@(PAtom _ _ _)+expandPred (PAll xs p)+  = PAll xs <$> expandPred p+-- expandPred (PExist xs p)+--   = PExist xs <$> expandPred p+expandPred p   = return p -expandPred PTrue-  = return PTrue-expandPred PFalse-  = return PFalse-expandPred PTop-  = return PTop- -------------------------------------------------------------------------------- -- Expand Exprs ---------------------------------------------------------------- --------------------------------------------------------------------------------  expandExpr :: Expr -> BareM Expr -expandExpr (EApp f@(Loc l f') es)+expandExpr (EApp f@(Loc l _ f') es)   = do env <- gets (exprAliases.rtEnv)        case M.lookup f' env of          Just re ->@@ -133,8 +125,7 @@   = subst su $ rtBody re   where su  = mkSubst $ safeZipWithError msg (rtVArgs re) es         msg = "Malformed alias application at " ++ show l ++ "\n\t"-               ++ show (rtName re) +               ++ show (rtName re)                ++ " defined at " ++ show (rtPos re)                ++ "\n\texpects " ++ show (length $ rtVArgs re)                ++ " arguments but it is given " ++ show (length es)-
src/Language/Haskell/Liquid/Bare/GhcSpec.hs view
@@ -13,7 +13,7 @@ import NameSet import TyCon import Var-import TysWiredIn +import TysWiredIn  import Control.Applicative ((<$>)) import Control.Monad.Reader@@ -22,17 +22,17 @@ import Data.Maybe import Data.Monoid -import qualified Control.Exception   as Ex +import qualified Control.Exception   as Ex import qualified Data.List           as L import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S  import Language.Fixpoint.Misc-import Language.Fixpoint.Names (takeWhileSym)-import Language.Fixpoint.Types (Expr(..), SEnv, SortedReft, Symbol, TCEmb, fromListSEnv, insertSEnv, mkSubst, subst, substa, symbol)+import Language.Fixpoint.Names (takeWhileSym, nilName, consName)+import Language.Fixpoint.Types  import Language.Haskell.Liquid.Dictionaries-import Language.Haskell.Liquid.GhcMisc (getSourcePos, sourcePosSrcSpan)+import Language.Haskell.Liquid.GhcMisc (getSourcePosE, getSourcePos, sourcePosSrcSpan) import Language.Haskell.Liquid.PredType (makeTyConInfo) import Language.Haskell.Liquid.RefType import Language.Haskell.Liquid.Types@@ -62,19 +62,28 @@             -> [(ModName,Ms.BareSpec)]             -> IO GhcSpec makeGhcSpec cfg name cbs vars defVars exports env lmap specs-  +   = do sp <- throwLeft =<< execBare act initEnv-       let renv = ghcSpecEnv sp cbs +       let renv = ghcSpecEnv sp cbs        throwLeft $ checkGhcSpec specs renv $ postProcess cbs renv sp   where     act       = makeGhcSpec' cfg cbs vars defVars exports specs     throwLeft = either Ex.throw return-    initEnv   = BE name mempty mempty mempty env lmap' mempty-    lmap'     = case lmap of {Left e -> Ex.throw e; Right x -> x}-    +    initEnv   = BE name mempty mempty mempty env lmap' mempty mempty+    lmap'     = case lmap of {Left e -> Ex.throw e; Right x -> x `mappend` listLMap}++listLMap = toLogicMap [(nilName, [], hNil),+                       (consName, [x, xs], hCons (EVar <$> [x,xs]))+                      ]+  where+    x  = symbol "x"+    xs = symbol "xs"+    hNil    = EApp (dummyLoc $ symbol nilDataCon ) []+    hCons   = EApp (dummyLoc $ symbol consDataCon) + postProcess :: [CoreBind] -> SEnv SortedReft -> GhcSpec -> GhcSpec postProcess cbs specEnv sp@(SP {..}) = sp { tySigs = tySigs', texprs = ts, asmSigs = asmSigs', dicts = dicts' }-  -- HEREHEREHEREHERE (addTyConInfo stuff) +  -- HEREHEREHEREHERE (addTyConInfo stuff)   where     (sigs, ts) = replaceLocalBinds tcEmbeds tyconEnv tySigs texprs specEnv cbs     tySigs'  = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> sigs@@ -82,18 +91,18 @@     dicts'   = dmapty (addTyConInfo tcEmbeds tyconEnv) dicts  ghcSpecEnv sp cbs    = fromListSEnv binds-  where +  where     emb              = tcEmbeds sp-    binds            =  [(x,        rSort t) | (x, Loc _ t) <- meas sp]-                     ++ [(symbol v, rSort t) | (v, Loc _ t) <- ctors sp]+    binds            =  [(x,        rSort t) | (x, Loc _ _ t) <- meas sp]+                     ++ [(symbol v, rSort t) | (v, Loc _ _ t) <- ctors sp]                      ++ [(x,        vSort v) | (x, v) <- freeSyms sp, isConLikeId v]                      ++ [(val x   , rSort stringrSort) | Just (ELit x s) <- mkLit <$> lconsts, isString s]-    rSort            = rTypeSortedReft emb -    vSort            = rSort . varRSort +    rSort            = rTypeSortedReft emb+    vSort            = rSort . varRSort     varRSort         :: Var -> RSort     varRSort         = ofType . varType     lconsts          = literals cbs-    stringrSort      :: RSort +    stringrSort      :: RSort     stringrSort      = ofType stringTy     isString s       = rTypeSort emb stringrSort == s @@ -101,21 +110,22 @@ makeGhcSpec' :: Config -> [CoreBind] -> [Var] -> [Var] -> NameSet -> [(ModName, Ms.BareSpec)] -> BareM GhcSpec ------------------------------------------------------------------------------------------------ makeGhcSpec' cfg cbs vars defVars exports specs-  = do name                                    <- gets modName-       makeRTEnv specs+  = do name          <- modName <$> get+       makeBounds name defVars cbs specs+       makeRTEnv  specs        (tycons, datacons, dcSs, tyi, embs)     <- makeGhcSpecCHOP1 specs        modify                                   $ \be -> be { tcEnv = tyi }-       (cls, mts)                              <- second mconcat . unzip . mconcat <$> mapM (makeClasses cfg vars) specs+       (cls, mts)                              <- second mconcat . unzip . mconcat <$> mapM (makeClasses name cfg vars) specs        (measures, cms', ms', cs', xs')         <- makeGhcSpecCHOP2 cbs specs dcSs datacons cls embs        (invs, ialias, sigs, asms)              <- makeGhcSpecCHOP3 cfg vars defVars specs name mts embs        syms                                    <- makeSymbols (vars ++ map fst cs') xs' (sigs ++ asms ++ cs') ms' (invs ++ (snd <$> ialias))        let su  = mkSubst [ (x, mkVarExpr v) | (x, v) <- syms]        return (emptySpec cfg)          >>= makeGhcSpec0 cfg defVars exports name-         >>= makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su -         >>= makeGhcSpec2 invs ialias measures su                     -         >>= makeGhcSpec3 datacons tycons embs syms             -         >>= makeGhcSpec4 defVars specs name su +         >>= makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su+         >>= makeGhcSpec2 invs ialias measures su+         >>= makeGhcSpec3 datacons tycons embs syms+         >>= makeGhcSpec4 defVars specs name su          >>= makeSpecDictionaries embs vars specs  emptySpec     :: Config -> GhcSpec@@ -124,15 +134,15 @@  makeGhcSpec0 cfg defVars exports name sp   = do targetVars <- makeTargetVars name defVars $ binders cfg-       return      $ sp { config = cfg         -                        , exports = exports    +       return      $ sp { config = cfg+                        , exports = exports                         , tgtVars = targetVars }  makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su sp   = do tySigs      <- makePluggedSigs name embs tyi exports $ tx sigs        asmSigs     <- makePluggedAsmSigs embs tyi $ tx asms        ctors       <- makePluggedAsmSigs embs tyi $ tx cs'-       lmap        <- logicEnv <$> get +       lmap        <- logicEnv <$> get        inlmap      <- inlines  <$> get        let ctors'   = [ (x, txRefToLogic lmap inlmap <$> t) | (x, t) <- ctors ]        return $ sp { tySigs     = tySigs@@ -144,19 +154,19 @@       tx'  = fmap (mapSnd $ fmap uRType)  makeGhcSpec2 invs ialias measures su sp-  = return $ sp { invariants = subst su invs -                , ialiases   = subst su ialias +  = return $ sp { invariants = subst su invs+                , ialiases   = subst su ialias                 , measures   = subst su <$> M.elems $ Ms.measMap measures }  makeGhcSpec3 datacons tycons embs syms sp   = do tcEnv       <- gets tcEnv-       lmap        <- logicEnv <$> get +       lmap        <- logicEnv <$> get        inlmap      <- inlines  <$> get        let dcons'   = mapSnd (txRefToLogic lmap inlmap) <$> datacons        return  $ sp { tyconEnv   = tcEnv                     , dconsP     = dcons'                     , tconsP     = tycons-                    , tcEmbeds   = embs +                    , tcEmbeds   = embs                     , freeSyms   = [(symbol v, v) | (_, v) <- syms] }  makeGhcSpec4 defVars specs name su sp@@ -167,31 +177,31 @@        hmeas   <- mkThing makeHIMeas        quals   <- mconcat <$> mapM makeQualifiers specs        let sigs = strengthenHaskellMeasures hmeas ++ tySigs sp-       lmap    <- logicEnv <$> get +       lmap    <- logicEnv <$> get        inlmap  <- inlines  <$> get        let tx   = mapSnd (fmap $ txRefToLogic lmap inlmap)-       let mtx  = txRefToLogic lmap inlmap +       let mtx  = txRefToLogic lmap inlmap        return   $ sp { qualifiers = subst su quals                      , decr       = decr'                      , texprs     = texprs'                      , lvars      = lvars'-                     , lazy       = lazies +                     , lazy       = lazies                      , tySigs     = tx  <$> sigs                      , asmSigs    = tx  <$> (asmSigs sp)                      , measures   = mtx <$> (measures sp)-                     }        +                     }     where        mkThing mk = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs, m == name ]   makeGhcSpecCHOP1 specs   = do (tcs, dcs)      <- mconcat <$> mapM makeConTypes specs-       let tycons       = tcs        ++ wiredTyCons +       let tycons       = tcs        ++ wiredTyCons        let tyi          = makeTyConInfo tycons        embs            <- mconcat <$> mapM makeTyConEmbeds specs        datacons        <- makePluggedDataCons embs tyi (concat dcs ++ wiredDataCons)        let dcSelectors  = concat $ map makeMeasureSelectors datacons-       return           $ (tycons, second val <$> datacons, dcSelectors, tyi, embs) +       return           $ (tycons, second val <$> datacons, dcSelectors, tyi, embs)  makeGhcSpecCHOP3 cfg vars defVars specs name mts embs   = do sigs'   <- mconcat <$> mapM (makeAssertSpec name cfg vars defVars) specs@@ -207,15 +217,15 @@ makeGhcSpecCHOP2 cbs specs dcSelectors datacons cls embs   = do measures'       <- mconcat <$> mapM makeMeasureSpec specs        tyi             <- gets tcEnv-       name            <- gets modName +       name            <- gets modName        mapM_ (makeHaskellInlines  cbs name) specs        hmeans          <- mapM (makeHaskellMeasures cbs name) specs        let measures     = mconcat (measures':Ms.mkMSpec' dcSelectors:hmeans)        let (cs, ms)     = makeMeasureSpec' measures        let cms          = makeClassMeasureSpec measures-       let cms'         = [ (x, Loc l $ cSort t) | (Loc l x, t) <- cms ]-       let ms'          = [ (x, Loc l t) | (Loc l x, t) <- ms, isNothing $ lookup x cms' ]-       let cs'          = [ (v, Loc (getSourcePos v) (txRefSort tyi embs t)) | (v, t) <- meetDataConSpec cs (datacons ++ cls)]+       let cms'         = [ (x, Loc l l' $ cSort t) | (Loc l l' x, t) <- cms ]+       let ms'          = [ (x, Loc l l' t) | (Loc l l' x, t) <- ms, isNothing $ lookup x cms' ]+       let cs'          = [ (v, Loc (getSourcePos v) (getSourcePosE v) (txRefSort tyi embs t)) | (v, t) <- meetDataConSpec cs (datacons ++ cls)]        let xs'          = val . fst <$> ms        return (measures, cms', ms', cs', xs') @@ -278,7 +288,7 @@   = do mt <- gets (M.lookup v . fst)        case mt of          Nothing -> return ()-         Just (Loc l (toRTypeRep -> t@(RTypeRep {..}))) -> do+         Just (Loc l l' (toRTypeRep -> t@(RTypeRep {..}))) -> do            (RE env' fenv emb tyi) <- ask            let f m k = M.lookupDefault k k m            let (env,args) = L.mapAccumL (\e (v,t) -> (M.insert v v e, substa (f e) t))@@ -288,13 +298,12 @@            let msg  = ErrTySpec (sourcePosSrcSpan l) (pprint v) t'            case checkTy msg emb tyi fenv t' of              Just err -> Ex.throw err-             Nothing -> modify (first $ M.insert v (Loc l t'))+             Nothing -> modify (first $ M.insert v (Loc l l' t'))            mes <- gets (M.lookup v . snd)            case mes of              Nothing -> return ()              Just es -> do                let es'  = substa (f env) es-               case checkTerminationExpr emb fenv (v, Loc l t', es') of+               case checkTerminationExpr emb fenv (v, Loc l l' t', es') of                  Just err -> Ex.throw err                  Nothing  -> modify (second $ M.insert v es')-
src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -4,6 +4,7 @@ module Language.Haskell.Liquid.Bare.Measure (     makeHaskellMeasures   , makeHaskellInlines+  , makeHaskellBounds    , makeMeasureSpec   , makeMeasureSpec'@@ -23,32 +24,40 @@ import Type hiding (isFunTy) import Var +import Prelude hiding (mapM) import Control.Applicative ((<$>), (<*>))-import Control.Monad hiding (forM)-import Control.Monad.Error hiding (Error, forM)-import Control.Monad.State hiding (forM)+import Control.Monad hiding (forM, mapM)+import Control.Monad.Error hiding (Error, forM, mapM)+import Control.Monad.State hiding (forM, mapM) import Data.Bifunctor import Data.Maybe+import Data.Char (toUpper) import Data.Monoid-import Data.Traversable (forM)+import Data.Traversable (forM, mapM) import Text.PrettyPrint.HughesPJ (text) import Text.Parsec.Pos (SourcePos) +import qualified Data.List as L+ import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S -import Language.Fixpoint.Misc (hashMapMapKeys, mapFst, mapSnd, mlookup, sortNub)-import Language.Fixpoint.Names (dropModuleNames, dummySymbol)-import Language.Fixpoint.Types (Expr(..), Symbol, symbol)+import Language.Fixpoint.Misc+import Language.Fixpoint.Names+import Language.Fixpoint.Types (Expr(..))+import qualified Language.Fixpoint.Types as F  import Language.Haskell.Liquid.CoreToLogic-import Language.Haskell.Liquid.GhcMisc (getSourcePos, sourcePosSrcSpan)+import Language.Haskell.Liquid.Misc    (mapSndM)+import Language.Haskell.Liquid.GhcMisc (getSourcePos, getSourcePosE, sourcePosSrcSpan, isDataConId) import Language.Haskell.Liquid.RefType (dataConSymbol, generalize, ofType, uRType) import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Bounds  import qualified Language.Haskell.Liquid.Measure as Ms  import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Misc       (simpleSymbolVar, hasBoolResult) import Language.Haskell.Liquid.Bare.Expand import Language.Haskell.Liquid.Bare.Lookup import Language.Haskell.Liquid.Bare.OfType@@ -56,69 +65,69 @@ import Language.Haskell.Liquid.Bare.RefToLogic  makeHaskellMeasures :: [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM (Ms.MSpec SpecType DataCon)-makeHaskellMeasures _   name' (name, _   ) | name /= name' +makeHaskellMeasures _   name' (name, _   ) | name /= name'   = return mempty-makeHaskellMeasures cbs _     (_   , spec) +makeHaskellMeasures cbs _     (_   , spec)   = do lmap <- gets logicEnv        Ms.mkMSpec' <$> mapM (makeMeasureDefinition lmap cbs') (S.toList $ Ms.hmeas spec)-  where +  where     cbs'                  = concatMap unrec cbs     unrec cb@(NonRec _ _) = [cb]     unrec (Rec xes)       = [NonRec x e | (x, e) <- xes]   makeHaskellInlines :: [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM ()-makeHaskellInlines _   name' (name, _   ) | name /= name' +makeHaskellInlines _   name' (name, _   ) | name /= name'   = return mempty-makeHaskellInlines cbs _     (_   , spec) +makeHaskellInlines cbs _     (_   , spec)   = do lmap <- gets logicEnv-       mapM_ (makeMeasureInline lmap cbs') (S.toList $ Ms.inlines spec) -  where +       mapM_ (makeMeasureInline lmap cbs') (S.toList $ Ms.inlines spec)+  where     cbs'                  = concatMap unrec cbs     unrec cb@(NonRec _ _) = [cb]     unrec (Rec xes)       = [NonRec x e | (x, e) <- xes]   makeMeasureInline :: LogicMap -> [CoreBind] ->  LocSymbol -> BareM ()-makeMeasureInline lmap cbs  x +makeMeasureInline lmap cbs  x   = case (filter ((val x `elem`) . (map (dropModuleNames . simplesymbol)) . binders) cbs) of     (NonRec v def:_)   -> do {e <- coreToFun' x v def; updateInlines x e}     (Rec [(v, def)]:_) -> do {e <- coreToFun' x v def; updateInlines x e}     _                  -> throwError $ mkError "Cannot inline haskell function"   where     binders (NonRec x _) = [x]-    binders (Rec xes)    = fst <$> xes  +    binders (Rec xes)    = fst <$> xes -    coreToFun' x v def = case (runToLogic lmap mkError $ coreToFun x v def) of -                           Left (xs, e)  -> return (TI xs e)+    coreToFun' x v def = case (runToLogic lmap mkError $ coreToFun x v def) of+                           Left (xs, e)  -> return (TI (symbol <$> xs) e)                            Right e -> throwError e      mkError :: String -> Error-    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)         +    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)   -updateInlines x v = modify $ \s -> let iold  = M.insert (val x) v (inlines s) in +updateInlines x v = modify $ \s -> let iold  = M.insert (val x) v (inlines s) in                                    s{inlines = M.map (f iold) iold }-  where f imap = txRefToLogic mempty imap +  where f imap = txRefToLogic mempty imap   makeMeasureDefinition :: LogicMap -> [CoreBind] -> LocSymbol -> BareM (Measure SpecType DataCon)-makeMeasureDefinition lmap cbs x +makeMeasureDefinition lmap cbs x   = case (filter ((val x `elem`) . (map (dropModuleNames . simplesymbol)) . binders) cbs) of     (NonRec v def:_)   -> (Ms.mkM x (logicType $ varType v)) <$> coreToDef' x v def     (Rec [(v, def)]:_) -> (Ms.mkM x (logicType $ varType v)) <$> coreToDef' x v def     _                  -> throwError $ mkError "Cannot extract measure from haskell function"   where     binders (NonRec x _) = [x]-    binders (Rec xes)    = fst <$> xes  +    binders (Rec xes)    = fst <$> xes -    coreToDef' x v def = case (runToLogic lmap mkError $ coreToDef x v def) of +    coreToDef' x v def = case (runToLogic lmap mkError $ coreToDef x v def) of                            Left l  -> return  l                            Right e -> throwError e      mkError :: String -> Error-    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)         +    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)  simplesymbol = symbol . getName @@ -126,17 +135,17 @@ strengthenHaskellMeasures hmeas = (\v -> (val v, fmap strengthenResult v)) <$> (S.toList hmeas)  makeMeasureSelectors :: (DataCon, Located DataConP) -> [Measure SpecType DataCon]-makeMeasureSelectors (dc, (Loc loc (DataConP _ vs _ _ _ xts r))) = catMaybes (go <$> zip (reverse xts) [1..])+makeMeasureSelectors (dc, (Loc l l' (DataConP _ vs _ _ _ xts r _))) = catMaybes (go <$> zip (reverse xts) [1..])   where     go ((x,t), i)       | isFunTy t = Nothing-      | True      = Just $ makeMeasureSelector (Loc loc x) (dty t) dc n i-        +      | True      = Just $ makeMeasureSelector (Loc l l' x) (dty t) dc n i+     dty t         = foldr RAllT  (RFun dummySymbol r (fmap mempty t) mempty) vs     n             = length xts  makeMeasureSelector x s dc n i = M {name = x, sort = s, eqns = [eqn]}-  where eqn   = Def x dc (mkx <$> [1 .. n]) (E (EVar $ mkx i)) +  where eqn   = Def x [] dc Nothing (((, Nothing) . mkx) <$> [1 .. n]) (E (EVar $ mkx i))          mkx j = symbol ("xx" ++ show j)  @@ -162,7 +171,7 @@  mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(Symbol, DataCon)] -> Ms.MSpec t DataCon mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}-  where +  where     m'  = fmap (tx.val) m     cm' = hashMapMapKeys (tx' . tx) $ Ms.ctorMap m'     tx  = mlookup (M.fromList ndcs)@@ -171,20 +180,72 @@ measureCtors ::  Ms.MSpec t LocSymbol -> [LocSymbol] measureCtors = sortNub . fmap ctor . concat . M.elems . Ms.ctorMap --- mkMeasureSort :: (PVarable pv, Reftable r) => Ms.MSpec (BRType pv r) bndr-> BareM (Ms.MSpec (RRType pv r) bndr)+mkMeasureSort ::  Ms.MSpec BareType LocSymbol -> BareM (Ms.MSpec SpecType LocSymbol) mkMeasureSort (Ms.MSpec c mm cm im)-  = Ms.MSpec c <$> forM mm tx <*> forM cm tx <*> forM im tx+  = Ms.MSpec <$> forM c (mapM txDef) <*> forM mm tx <*> forM cm tx <*> forM im tx     where-      tx m = liftM (\s' -> m {sort = s'}) (ofMeaSort (sort m))+      tx :: Measure BareType ctor -> BareM (Measure SpecType ctor)+      tx (M n s eqs) = M n <$> (ofMeaSort s) <*> (mapM txDef eqs) +      txDef :: Def BareType ctor -> BareM (Def SpecType ctor)+      txDef def = liftM3 (\xs t bds-> def{ dparams = xs, dsort = t, binds = bds}) +                  (mapM (mapSndM ofMeaSort) (dparams def))+                  (mapM ofMeaSort $ dsort def)+                  (mapM (mapSndM $ mapM ofMeaSort) (binds def))  -varMeasures vars   = [ (symbol v, varSpecType v)  | v <- vars, isDataConWorkId v, isSimpleType $ varType v ]-varSpecType v      = Loc (getSourcePos v) (ofType $ varType v)-isSimpleType t     = null tvs && isNothing (splitFunTy_maybe tb) where (tvs, tb) = splitForAllTys t +varMeasures vars = [ (symbol v, varSpecType v)  | v <- vars, isDataConId v, isSimpleType $ varType v ] +isSimpleType t   = null tvs && isNothing (splitFunTy_maybe tb)+  where+    (tvs, tb)    = splitForAllTys t +varSpecType v    = Loc l l' (ofType $ varType v)+  where+    l            = getSourcePos  v+    l'           = getSourcePosE v ++makeHaskellBounds :: CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv+makeHaskellBounds cbs xs+  = do lmap <- gets logicEnv+       M.fromList <$> mapM (makeHaskellBound lmap cbs) (S.toList xs)+++makeHaskellBound lmap  cbs (v, x) = case filter ((v  `elem`) . binders) cbs of+    (NonRec v def:_)   -> do {e <- coreToFun' x v def; return $ toBound v x e}+    (Rec [(v, def)]:_) -> do {e <- coreToFun' x v def; return $ toBound v x e}+    _                  -> throwError $ mkError "Cannot make bound of haskell function"++  where+    binders (NonRec x _) = [x]+    binders (Rec xes)    = fst <$> xes++    coreToFun' x v def = case (runToLogic lmap mkError $ coreToFun x v def) of+                           Left (xs, e) -> return (xs, e)+                           Right e      -> throwError e++    mkError :: String -> Error+    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)+++toBound :: Var -> LocSymbol -> ([Var], Either F.Pred F.Expr) -> (LocSymbol, RBound)+toBound v x (vs, Left p) = (x', Bound x' fvs ps xs p)+  where+    x'         = capitalizeBound x+    (ps', xs') = L.partition (hasBoolResult . varType) vs+    (ps , xs)  = (txp <$> ps', txx <$> xs')+    txp v      = (dummyLoc $ simpleSymbolVar v, ofType $ varType v)+    txx v      = (dummyLoc $ symbol v,          ofType $ varType v)+    fvs        = (((`RVar` mempty) . RTV) <$> (fst $ splitForAllTys $ varType v)) :: [RSort]++toBound v x (vs, Right e) = toBound v x (vs, Left $ F.PBexp e)++capitalizeBound = fmap (symbol . toUpperHead . symbolString)+  where+    toUpperHead []     = []+    toUpperHead (x:xs) = toUpper x:xs+ -------------------------------------------------------------------------------- -- Expand Measures ------------------------------------------------------------- --------------------------------------------------------------------------------@@ -194,7 +255,7 @@        return $ m { sort = generalize (sort m)                   , eqns = eqns } -expandMeasureDef :: Def LocSymbol -> BareM (Def LocSymbol)+expandMeasureDef :: Def t LocSymbol -> BareM (Def t LocSymbol) expandMeasureDef d   = do body <- expandMeasureBody (loc $ measure d) $ body d        return $ d { body = body }@@ -203,4 +264,3 @@ expandMeasureBody l (P p)   = P   <$> (resolve l =<< expandPred p) expandMeasureBody l (R x p) = R x <$> (resolve l =<< expandPred p) expandMeasureBody l (E e)   = E   <$> resolve l e-
src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -11,8 +11,15 @@   , mapTyVars    , symbolRTyVar+  , simpleSymbolVar++  , hasBoolResult   ) where ++import TysWiredIn+import Name+ import Id import Type import TypeRep@@ -25,10 +32,11 @@  import qualified Data.List as L -import Language.Fixpoint.Misc (sortDiff, sortNub)-import Language.Fixpoint.Types (Expr(..), Reft(..), Reftable(..), emptySEnv, memberSEnv, symbol, syms, toReft)+import Language.Fixpoint.Names (dropModuleNames)+import Language.Fixpoint.Misc  (sortDiff, sortNub)+import Language.Fixpoint.Types (Symbol, Expr(..), Reft(..), Reftable(..), emptySEnv, memberSEnv, symbol, syms, toReft) -import Language.Haskell.Liquid.GhcMisc (showPpr)+import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.RefType import Language.Haskell.Liquid.Types @@ -115,7 +123,7 @@  varFunSymbol = dummyLoc . dataConSymbol . idDataCon  -isFunVar v   = isDataConWorkId v && not (null αs) && isNothing tf+isFunVar v   = isDataConId v && not (null αs) && isNothing tf   where     (αs, t)  = splitForAllTys $ varType v      tf       = splitFunTy_maybe t@@ -129,6 +137,11 @@                        Nothing -> (v,s,t)  -+simpleSymbolVar :: Var -> Symbol+simpleSymbolVar  = dropModuleNames . symbol . showPpr . getName +hasBoolResult (ForAllTy _ t) = hasBoolResult t+hasBoolResult (FunTy _ t)    | eqType boolTy t = True +hasBoolResult (FunTy _ t)    = hasBoolResult t+hasBoolResult _              = False
src/Language/Haskell/Liquid/Bare/OfType.hs view
@@ -12,6 +12,7 @@   ) where  import BasicTypes+import Name import TyCon import Type (expandTypeSynonyms) import TysWiredIn@@ -25,16 +26,17 @@ import Text.Parsec.Pos import Text.Printf -import qualified Control.Exception as Ex +import qualified Control.Exception as Ex import qualified Data.HashMap.Strict as M  import Language.Fixpoint.Misc (errorstar) import Language.Fixpoint.Types (Expr(..), Reftable, Symbol, meet, mkSubst, subst, symbol) -import Language.Haskell.Liquid.GhcMisc (sourcePosSrcSpan)+import Language.Haskell.Liquid.GhcMisc (realTcArity, sourcePosSrcSpan, tyConTyVarsDef) import Language.Haskell.Liquid.Misc (secondM) import Language.Haskell.Liquid.RefType import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Bounds  import Language.Haskell.Liquid.Bare.Env import Language.Haskell.Liquid.Bare.Expand@@ -54,7 +56,7 @@  ofBSort :: BSort -> BareM RSort ofBSort-  = ofBRType failRTAliasApp return +  = ofBRType failRTAliasApp return  -------------------------------------------------------------------------------- @@ -63,9 +65,9 @@   = mapM_pvar ofBSort  mapM_pvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b)-mapM_pvar f (PV x t v txys) -  = do t'    <- forM t f -       txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys +mapM_pvar f (PV x t v txys)+  = do t'    <- forM t f+       txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys        return $ PV x t' v txys'  --------------------------------------------------------------------------------@@ -84,7 +86,7 @@  txParam f πs t = f (txPvar (predMap πs t)) -txPvar :: M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar +txPvar :: M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar txPvar m π = π { pargs = args' }   where args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)               | otherwise            = pargs π'@@ -97,7 +99,7 @@  -------------------------------------------------------------------------------- -ofBRType :: (PPrint r, Reftable r)+ofBRType :: (PPrint r, UReftable r)          => (SourcePos -> RTAlias RTyVar SpecType -> [BRType r] -> r -> BareM (RRType r))          -> (r -> BareM r)          -> BRType r@@ -105,20 +107,14 @@ ofBRType appRTAlias resolveReft   = go   where-    go (RApp lc@(Loc l c) ts rs r)-      = do env <- gets (typeAliases.rtEnv)-           r'  <- resolveReft r-           case M.lookup c env of-             Just rta ->-               appRTAlias l rta ts r'-             Nothing ->-               do c' <- matchTyCon lc (length ts)-                  bareTCApp r' c' <$> mapM go_ref rs <*> mapM go ts-+    go t@(RApp _ _ _ _)+      = do aliases <- (typeAliases . rtEnv) <$> get+           goRApp aliases t     go (RAppTy t1 t2 r)       = RAppTy <$> go t1 <*> go t2 <*> resolveReft r-    go (RFun x t1 t2 _)-      = rFun x <$> go t1 <*> go t2+    go (RFun x t1 t2 r)+      =  do env <- get+            goRFun (bounds env) x t1 t2 r     go (RVar a r)       = RVar (symbolRTyVar a) <$> resolveReft r     go (RAllT a t)@@ -135,8 +131,8 @@       = RRTy <$> mapM (secondM go) e <*> resolveReft r <*> pure o <*> go t     go (RHole r)       = RHole <$> resolveReft r-    go (RExprArg e)-      = return $ RExprArg e+    go (RExprArg (Loc l l' e))+      = RExprArg . Loc l l' <$> resolve l e      go_ref (RPropP ss r)       = RPropP <$> mapM go_syms ss <*> resolveReft r@@ -148,8 +144,27 @@     go_syms       = secondM ofBSort +    goRFun bounds _ (RApp c ps' _ _) t _ | Just bnd <- M.lookup c bounds+      = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'+           ts <- mapM go ts'+           makeBound bnd ts [x | RVar x _ <- ps] <$> go t+    goRFun _ x t1 t2 r+      = RFun x <$> go t1 <*> go t2 <*> resolveReft r++    goRApp aliases (RApp (Loc l _ c) ts _ r) | Just rta <- M.lookup c aliases+      = appRTAlias l rta ts =<< resolveReft r+    goRApp _ (RApp lc ts rs r)+      =  do let l = loc lc+            r'  <- resolveReft r+            lc' <- Loc l l <$> matchTyCon lc (length ts)+            rs' <- mapM go_ref rs+            ts' <- mapM go ts+            bareTCApp r' lc' rs' ts'+    goRApp _ _ = errorstar "This cannot happen"++ matchTyCon :: LocSymbol -> Int -> BareM TyCon-matchTyCon lc@(Loc _ c) arity+matchTyCon lc@(Loc _ _ c) arity   | isList c && arity == 1     = return listTyCon   | isTuple c@@ -178,45 +193,50 @@     = Ex.throw err   where     su        = mkSubst $ zip (symbol <$> εs) es-    αs        = rtTArgs rta +    αs        = rtTArgs rta     εs        = rtVArgs rta     es_       = drop (length αs) args     es        = map (exprArg $ show err) es_     err       :: Error-    err       = ErrAliasApp (sourcePosSrcSpan l) (length args) (pprint $ rtName rta) (sourcePosSrcSpan $ rtPos rta) (length αs + length εs) +    err       = ErrAliasApp (sourcePosSrcSpan l) (length args) (pprint $ rtName rta) (sourcePosSrcSpan $ rtPos rta) (length αs + length εs) --- | exprArg converts a tyVar to an exprVar because parser cannot tell +-- | exprArg converts a tyVar to an exprVar because parser cannot tell -- HORRIBLE HACK To allow treating upperCase X as value variables X -- e.g. type Matrix a Row Col = List (List a Row) Col -exprArg _   (RExprArg e)     -  = e-exprArg _   (RVar x _)       +exprArg _   (RExprArg e)+  = val e+exprArg _   (RVar x _)   = EVar (symbol x)-exprArg _   (RApp x [] [] _) +exprArg _   (RApp x [] [] _)   = EVar (symbol x)-exprArg msg (RApp f ts [] _) +exprArg msg (RApp f ts [] _)   = EApp (symbol <$> f) (exprArg msg <$> ts)-exprArg msg (RAppTy (RVar f _) t _)   +exprArg msg (RAppTy (RVar f _) t _)   = EApp (dummyLoc $ symbol f) [exprArg msg t]-exprArg msg z -  = errorstar $ printf "Unexpected expression parameter: %s in %s" (show z) msg +exprArg msg z+  = errorstar $ printf "Unexpected expression parameter: %s in %s" (show z) msg  -------------------------------------------------------------------------------- -bareTCApp r c rs ts | Just (SynonymTyCon rhs) <- synTyConRhs_maybe c-   = tyApp (subsTyVars_meet su $ ofType rhs) (drop nts ts) rs r -   where tvs = tyConTyVars  c-         su  = zipWith (\a t -> (rTyVar a, toRSort t, t)) tvs ts-         nts = length tvs+bareTCApp r (Loc l _ c) rs ts | Just (SynonymTyCon rhs) <- synTyConRhs_maybe c+  = do when (realTcArity c < length ts) (Ex.throw err)+       return $ tyApp (subsTyVars_meet su $ ofType rhs) (drop nts ts) rs r+    where+       tvs = tyConTyVarsDef c+       su  = zipWith (\a t -> (rTyVar a, toRSort t, t)) tvs ts+       nts = length tvs +       err :: Error+       err = ErrAliasApp (sourcePosSrcSpan l) (length ts) (pprint c) (getSrcSpan c) (realTcArity c)+ -- TODO expandTypeSynonyms here to-bareTCApp r c rs ts | isFamilyTyCon c && isTrivial t-  = expandRTypeSynonyms $ t `strengthen` r +bareTCApp r (Loc _ _ c) rs ts | isFamilyTyCon c && isTrivial t+  = return $ expandRTypeSynonyms $ t `strengthen` r   where t = rApp c ts rs mempty -bareTCApp r c rs ts -  = rApp c ts rs r+bareTCApp r (Loc _ _ c) rs ts+  = return $ rApp c ts rs r  tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `meet` r') tyApp t                []  []  r  = t `strengthen` r@@ -224,4 +244,3 @@  expandRTypeSynonyms :: (PPrint r, Reftable r) => RRType r -> RRType r expandRTypeSynonyms = ofType . expandTypeSynonyms . toType-
src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -25,7 +25,8 @@ import qualified Data.HashMap.Strict as M  import Language.Fixpoint.Names (dummySymbol)-import Language.Fixpoint.Types (Reft(..), TCEmb)+import Language.Fixpoint.Types (mapPredReft, pAnd, conjuncts, Refa (..), TCEmb)+-- import Language.Fixpoint.Types (traceFix, showFix)  import Language.Haskell.Liquid.GhcMisc (sourcePosSrcSpan) import Language.Haskell.Liquid.RefType (addTyConInfo, ofType, rVar, rTyVar, subts, toType, uReft)@@ -47,19 +48,19 @@       (x,) <$> plugHoles embs tcEnv x r τ t  makePluggedDataCons embs tcEnv dcs-  = forM dcs $ \(dc, Loc l dcp) -> do+  = forM dcs $ \(dc, Loc l l' dcp) -> do        let (das, _, dts, dt) = dataConSig dc-       tyArgs <- zipWithM (\t1 (x,t2) -> -                   (x,) . val <$> plugHoles embs tcEnv (dataConName dc) killHoles t1 (Loc l t2)) +       tyArgs <- zipWithM (\t1 (x,t2) ->+                   (x,) . val <$> plugHoles embs tcEnv (dataConName dc) killHoles t1 (Loc l l' t2))                  dts (reverse $ tyArgs dcp)-       tyRes <- val <$> plugHoles embs tcEnv (dataConName dc) killHoles dt (Loc l (tyRes dcp))-       return (dc, Loc l dcp { freeTyVars = map rTyVar das-                             , freePred = map (subts (zip (freeTyVars dcp) (map (rVar :: TyVar -> RSort) das))) (freePred dcp)-                             , tyArgs = reverse tyArgs-                             , tyRes = tyRes})+       tyRes <- val <$> plugHoles embs tcEnv (dataConName dc) killHoles dt (Loc l l' (tyRes dcp))+       return (dc, Loc l l' dcp { freeTyVars = map rTyVar das+                                , freePred   = map (subts (zip (freeTyVars dcp) (map (rVar :: TyVar -> RSort) das))) (freePred dcp)+                                , tyArgs     = reverse tyArgs+                                , tyRes      = tyRes})  -plugHoles tce tyi x f t (Loc l st) +plugHoles tce tyi x f t (Loc l l' st)   = do tyvsmap <- case runMapTyVars (mapTyVars (toType rt') st'') initvmap of                     Left e -> throwError e                     Right s -> return $ vmap s@@ -67,7 +68,7 @@            st''' = subts su st''            ps'   = fmap (subts su') <$> ps            su'   = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]-       Loc l . mkArrow αs ps' (ls1 ++ ls2) [] . pushCls cs' <$> go rt' st'''+       Loc l l' . mkArrow αs ps' (ls1 ++ ls2) [] . makeCls cs' <$> go rt' st'''   where     (αs, _, ls1, rt)  = bkUniv (ofType t :: SpecType)     (cs, rt')         = bkClass rt@@ -75,13 +76,13 @@     (_, ps, ls2, st') = bkUniv st     (_, st'')         = bkClass st'     cs'               = [(dummySymbol, RApp c t [] mempty) | (c,t) <- cs]-    initvmap          = initMapSt $ ErrMismatch (sourcePosSrcSpan l) (pprint x) t st+    initvmap          = initMapSt $ ErrMismatch (sourcePosSrcSpan l) (pprint x) t (toType st)      go :: SpecType -> SpecType -> BareM SpecType     go t                (RHole r)          = return $ (addHoles t') { rt_reft = f r }       where         t'       = everywhere (mkT $ addRefs tce tyi) t-        addHoles = fmap (const $ f $ uReft ("v", [hole]))+        addHoles = fmap (const $ f $ uReft ("v", Refa hole))     go (RVar _ _)       v@(RVar _ _)       = return v     go (RFun _ i o _)   (RFun x i' o' r)   = RFun x <$> go i i' <*> go o o' <*> return r     go (RAllT _ t)      (RAllT a t')       = RAllT a <$> go t t'@@ -98,8 +99,7 @@     -- problem to the user.     go _                st                 = return st -    pushCls cs (RRTy e r o t) = RRTy e r o (pushCls cs t)-    pushCls cs t              = foldr (uncurry rFun) t cs +    makeCls cs t              = foldr (uncurry rFun) t cs  addRefs :: TCEmb TyCon      -> M.HashMap TyCon RTyCon@@ -122,5 +122,11 @@     name        = getName x     notExported = not $ getName x `elemNameSet` exports -killHoles r@(U (Reft (v,rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) }+-- killHoles r@(U (Reft (v, rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) }++killHoles ur = ur { ur_reft = tx $ ur_reft ur }+  where+    tx r = {- traceFix ("killholes: r = " ++ showFix r) $ -} mapPredReft dropHoles r+    dropHoles    = pAnd . filter (not . isHole) . conjuncts+
src/Language/Haskell/Liquid/Bare/RTEnv.hs view
@@ -42,27 +42,30 @@   = graphExpand buildTypeEdges expBody   where     expBody (mod, xt)-      = inModule mod $ -          do let l = rtPos xt-             body <- withVArgs l (rtVArgs xt) $ ofBareType l $ rtBody xt+      = inModule mod $+          do let l  = rtPos  xt+             let l' = rtPosE xt+             body  <- withVArgs l l' (rtVArgs xt) $ ofBareType l $ rtBody xt              setRTAlias (rtName xt) $ mapRTAVars symbolRTyVar $ xt { rtBody = body}  makeRPAliases   = graphExpand buildPredEdges expBody-  where +  where     expBody (mod, xt)       = inModule mod $-          do let l = rtPos xt-             body <- withVArgs l (rtVArgs xt) $ resolve l =<< (expandPred $ rtBody xt)+          do let l  = rtPos  xt+             let l' = rtPosE xt+             body  <- withVArgs l l' (rtVArgs xt) $ resolve l =<< (expandPred $ rtBody xt)              setRPAlias (rtName xt) $ xt { rtBody = body }  makeREAliases   = graphExpand buildExprEdges expBody-  where +  where     expBody (mod, xt)       = inModule mod $-          do let l = rtPos xt-             body <- withVArgs l (rtVArgs xt) $ resolve l =<< (expandExpr $ rtBody xt)+          do let l  = rtPos  xt+             let l' = rtPosE xt+             body  <- withVArgs l l' (rtVArgs xt) $ resolve l =<< (expandExpr $ rtBody xt)              setREAlias (rtName xt) $ xt { rtBody = body }  @@ -128,7 +131,7 @@   genExpandOrder :: AliasTable t -> Graph Symbol -> [(ModName, RTAlias Symbol t)]-genExpandOrder table graph +genExpandOrder table graph   = map (fromAliasSymbol table) symOrder   where     (digraph, lookupVertex, _)@@ -139,113 +142,66 @@ --------------------------------------------------------------------------------  buildTypeEdges :: AliasTable BareType -> BareType -> [Symbol]-buildTypeEdges table-  = ordNub . go-  where go :: BareType -> [Symbol]-        go (RApp (Loc _ c) ts rs _)-          = go_alias c ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)--        go (RFun _ t1 t2 _)-          = go t1 ++ go t2-        go (RAppTy t1 t2 _)-          = go t1 ++ go t2-        go (RAllE _ t1 t2)-          = go t1 ++ go t2-        go (REx _ t1 t2)-          = go t1 ++ go t2-        go (RAllT _ t)-          = go t-        go (RAllP _ t)-          = go t-        go (RAllS _ t)-          = go t--        go (RVar _ _)-          = []-        go (RExprArg _)-          = []-        go (RHole _)-          = []--        go (RRTy env _ _ t)-          = concatMap (go . snd) env ++ go t--        go_alias c-          = case M.lookup c table of-              Just _  -> [c]-              Nothing -> [ ]+buildTypeEdges table = ordNub . go+  where+    go :: BareType -> [Symbol]+    go (RApp c ts rs _) = go_alias (val c) ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)+    go (RFun _ t1 t2 _) = go t1 ++ go t2+    go (RAppTy t1 t2 _) = go t1 ++ go t2+    go (RAllE _ t1 t2)  = go t1 ++ go t2+    go (REx _ t1 t2)    = go t1 ++ go t2+    go (RAllT _ t)      = go t+    go (RAllP _ t)      = go t+    go (RAllS _ t)      = go t+    go (RVar _ _)       = []+    go (RExprArg _)     = []+    go (RHole _)        = []+    go (RRTy env _ _ t) = concatMap (go . snd) env ++ go t+    go_alias c          = [c | M.member c table]+    -- case M.lookup c table of+    --                         Just _  -> [c]+    --                         Nothing -> [ ] -        go_ref (RPropP _ _) = Nothing-        go_ref (RProp  _ t) = Just t-        go_ref (RHProp _ _) = errorstar "TODO:EFFECTS:buildTypeEdges"+    go_ref (RPropP _ _) = Nothing+    go_ref (RProp  _ t) = Just t+    go_ref (RHProp _ _) = errorstar "TODO:EFFECTS:buildTypeEdges"  buildPredEdges :: AliasTable Pred -> Pred -> [Symbol]-buildPredEdges table-  = ordNub . go-  where go :: Pred -> [Symbol]-        go (PBexp (EApp (Loc _ f) _))-          = case M.lookup f table of-              Just _  -> [f]-              Nothing -> [ ]-        go (PBexp _)-          = []--        go (PAnd ps)-          = concatMap go ps-        go (POr ps)-          = concatMap go ps--        go (PNot p)-          = go p--        go (PImp p q)-          = go p ++ go q-        go (PIff p q)-          = go p ++ go q--        go (PAll _ p)-          = go p--        go (PAtom _ _ _)-          = []--        go PTrue-          = []-        go PFalse-          = []-        go PTop-          = []--buildExprEdges table-  = ordNub . go-  where go :: Expr -> [Symbol]-        go (EApp (Loc _ f) es)-          = go_alias f ++ concatMap go es--        go (ENeg e)-          = go e-        go (EBin _ e1 e2)-          = go e1 ++ go e2-        go (EIte _ e1 e2)-          = go e1 ++ go e2--        go (ECst e _)-          = go e+buildPredEdges table = ordNub . go+  where+    go :: Pred -> [Symbol]+    go (PBexp (EApp lf _)) = [ f | let f = val lf, M.member f table]+    go (PAnd ps)           = concatMap go ps+    go (POr ps)            = concatMap go ps+    go (PNot p)            = go p+    go (PImp p q)          = go p ++ go q+    go (PIff p q)          = go p ++ go q+    go (PAll _ p)          = go p+    go _                   = [] -        go (ELit _ _)-          = []-        go (ESym _)-          = []-        go (ECon _)-          = []-        go (EVar _)-          = []+    -- go (PBexp _)           = []+    -- go (PAtom _ _ _)       = []+    -- go PTrue               = []+    -- go PFalse              = []+    -- go PTop                = [] -        go EBot-          = []+buildExprEdges table  = ordNub . go+  where+    go :: Expr -> [Symbol]+    go (EApp lf es)   = go_alias (val lf) ++ concatMap go es+    go (ENeg e)       = go e+    go (EBin _ e1 e2) = go e1 ++ go e2+    go (EIte _ e1 e2) = go e1 ++ go e2+    go (ECst e _)     = go e+    go _              = [] -        go_alias f-          = case M.lookup f table of-              Just _  -> [f]-              Nothing -> [ ]+    -- go (ELit _ _)     = []+    -- go (ESym _)       = []+    -- go (ECon _)       = []+    -- go (EVar _)       = []+    -- go EBot           = [] +    go_alias f           = [f | M.member f table ]+    --   = case M.lookup f table of+    --       Just _  -> [f]+    --       Nothing -> [ ]
src/Language/Haskell/Liquid/Bare/RefToLogic.hs view
@@ -2,139 +2,145 @@ {-# LANGUAGE FlexibleInstances    #-}  module Language.Haskell.Liquid.Bare.RefToLogic (-    txRefToLogic, Transformable+    Transformable+   , txRefToLogic+   ) where  import Language.Haskell.Liquid.Types-- import Language.Haskell.Liquid.Bare.Env -import Language.Fixpoint.Types hiding (Def, R)     -import Language.Fixpoint.Misc      -import Language.Fixpoint.Names      (dropModuleNames)+import Language.Fixpoint.Types hiding (Def, R)+import Language.Fixpoint.Misc+import Language.Fixpoint.Names  import qualified Data.HashMap.Strict as M  import Control.Applicative                      ((<$>))  txRefToLogic :: (Transformable r) => LogicMap -> InlnEnv -> r -> r-txRefToLogic lmap imap t =  tx' lmap imap t-+txRefToLogic = tx'  class Transformable a where-	tx  :: Symbol -> (Either LMap TInline) -> a -> a +  tx  :: Symbol -> (Either LMap TInline) -> a -> a -	tx' :: LogicMap -> InlnEnv -> a -> a-	tx' lmap imap x = M.foldrWithKey tx x limap-	  where limap = M.fromList ((mapSnd Left <$> M.toList lmap) ++ (mapSnd Right <$> M.toList imap))   +  tx' :: LogicMap -> InlnEnv -> a -> a+  tx' lmap imap x = M.foldrWithKey tx x limap+    where+      limap       = M.fromList ((mapSnd Left <$> M.toList lmap) ++ (mapSnd Right <$> M.toList imap))   instance (Transformable a) => (Transformable [a]) where-	tx s m xs = tx s m <$> xs +  tx s m xs = tx s m <$> xs  instance Transformable DataConP where-	tx s m x = x{ tyConsts = tx s m (tyConsts x)-                , tyArgs   = mapSnd (tx s m) <$> (tyArgs x)-                , tyRes    = tx s m (tyRes x)-                }+  tx s m x = x { tyConsts = tx s m (tyConsts x)+               , tyArgs   = mapSnd (tx s m) <$> (tyArgs x)+               , tyRes    = tx s m (tyRes x)+               }  instance Transformable TInline where-  tx s m (TI xs e) = TI xs (tx s m e) +  tx s m (TI xs e) = TI xs (tx s m e) -instance (Transformable r) => Transformable (RType c v r) where -	tx s m = fmap (tx s m)+instance (Transformable r) => Transformable (RType c v r) where+  tx s m = fmap (tx s m) -instance Transformable RReft where -	tx s m = fmap (tx s m)+instance Transformable RReft where+  tx s m = fmap (tx s m) -instance Transformable Reft where -	tx s m (Reft(v, refas))-		= if v == s -			then errorstar "Transformable: this should not happen"-			else Reft(v, tx s m <$> refas)+instance Transformable Reft where+  tx s m (Reft (v, Refa p)) = if v == s+                              then errorstar "Transformable: this should not happen"+			      else Reft(v, Refa $ tx s m p) -instance Transformable Refa where-	tx s m (RConc p)     = RConc $ tx s m p -	tx _ _ (RKvar x sub) = RKvar x sub+-- OLD instance Transformable Refa where+-- OLD   tx s m (RConc p)     = RConc $ tx s m p+-- OLD   tx _ _ (RKvar x sub) = RKvar x sub  instance (Transformable a, Transformable b) => Transformable (Either a b) where-	tx s m (Left  x) = Left  (tx s m x)-	tx s m (Right x) = Right (tx s m x)+  tx s m (Left  x) = Left  (tx s m x)+  tx s m (Right x) = Right (tx s m x)  instance Transformable Pred where-	tx _ _ PTrue           = PTrue-	tx _ _ PFalse          = PFalse-	tx _ _ PTop            = PTop-	tx s m (PAnd ps)       = PAnd (tx s m <$> ps)-	tx s m (POr ps)        = POr (tx s m <$> ps)-	tx s m (PNot p)        = PNot (tx s m p)-	tx s m (PImp p1 p2)    = PImp (tx s m p1) (tx s m p2)-	tx s m (PIff p1 p2)    = PIff (tx s m p1) (tx s m p2)-	tx s m (PBexp (EApp f es)) = txPApp (s, m) f es-	tx s m (PBexp e)       = PBexp (tx s m e)-	tx s m (PAtom r e1 e2) = PAtom r (tx s m e1) (tx s m e2)-	tx s m (PAll xss p) -	    = if (s `elem` (fst <$> xss)) -	    	then errorstar "Transformable.tx on Pred: this should not happen" -		    else PAll xss (tx s m p) +  tx _ _ PTrue           = PTrue+  tx _ _ PFalse          = PFalse+  tx _ _ PTop            = PTop+  tx s m (PAnd ps)       = PAnd (tx s m <$> ps)+  tx s m (POr ps)        = POr (tx s m <$> ps)+  tx s m (PNot p)        = PNot (tx s m p)+  tx s m (PImp p1 p2)    = PImp (tx s m p1) (tx s m p2)+  tx s m (PIff p1 p2)    = PIff (tx s m p1) (tx s m p2)+  tx s m (PBexp (EApp f es)) = txPApp (s, m) f (tx s m <$> es)+  tx s m (PBexp e)       = PBexp (tx s m e)+  tx s m (PAtom r e1 e2) = PAtom r (tx s m e1) (tx s m e2)+  tx s m (PAll xss p)    = PAll xss $ txQuant xss s m p+ --  tx s m (PExist xss p)  = PExist xss $ txQuant xss s m p+  tx _ _ p@(PKVar _ _)   = p +txQuant xss s m p+  | s `elem` (fst <$> xss) = errorstar "Transformable.tx on Pred: this should not happen"+  | otherwise              = tx s m p++ instance Transformable Expr where-	tx s m (EVar s') -	   | cmpSymbol s s'   = mexpr m-	   | otherwise        = EVar s'-	tx s m (EApp f es)    = txEApp (s, m) f es-	tx _ _ (ESym c)       = ESym c-	tx _ _ (ECon c)       = ECon c-	tx _ _ (ELit l s')    = ELit l s'-	tx s m (ENeg e)       = ENeg (tx s m e)-	tx s m (EBin o e1 e2) = EBin o (tx s m e1) (tx s m e2)-	tx s m (EIte p e1 e2) = EIte (tx s m p) (tx s m e1) (tx s m e2)-	tx s m (ECst e s')    = ECst (tx s m e) s'-	tx _ _ EBot           = EBot+  tx s m (EVar s')+    | cmpSymbol s s'    = mexpr m+    | otherwise         = EVar s'+  tx s m (EApp f es)    = txEApp (s, m) f (tx s m <$> es)+  tx _ _ (ESym c)       = ESym c+  tx _ _ (ECon c)       = ECon c+  tx _ _ (ELit l s')    = ELit l s'+  tx s m (ENeg e)       = ENeg (tx s m e)+  tx s m (EBin o e1 e2) = EBin o (tx s m e1) (tx s m e2)+  tx s m (EIte p e1 e2) = EIte (tx s m p) (tx s m e1) (tx s m e2)+  tx s m (ECst e s')    = ECst (tx s m e) s'+  tx _ _ EBot           = EBot  instance Transformable (Measure t c) where-	tx s m x = x{eqns = tx s m <$> (eqns x)}+  tx s m x = x{eqns = tx s m <$> (eqns x)} -instance Transformable (Def c) where+instance Transformable (Def t c) where 	tx s m x = x{body = tx s m (body x)}   instance Transformable Body where-   tx s m (E e)   = E $ tx s m e-   tx s m (P p)   = P $ tx s m p-   tx s m (R v p) = R v $ tx s m p+  tx s m (E e)   = E $ tx s m e+  tx s m (P p)   = P $ tx s m p+  tx s m (R v p) = R v $ tx s m p  mexpr (Left  (LMap _ _ e)) = e mexpr (Right (TI _ (Right e))) = e mexpr _ = errorstar "mexpr" -txEApp (s, (Left (LMap _ xs e))) f es -  | cmpSymbol s (val f) +txEApp (s, (Left (LMap _ xs e))) f es+  | cmpSymbol s (val f)   = subst (mkSubst $ zip xs es) e-  | otherwise  +  | otherwise   = EApp f es -txEApp (s, (Right (TI xs (Right e)))) f es -  | cmpSymbol s (val f) +txEApp (s, (Right (TI xs (Right e)))) f es+  | cmpSymbol s (val f)   = subst (mkSubst $ zip xs es) e-  | otherwise  +  | otherwise   = EApp f es  -txEApp (s, (Right (TI _ (Left _)))) f es -  | cmpSymbol s (val f) +txEApp (s, (Right (TI _ (Left _)))) f es+  | cmpSymbol s (val f)   = errorstar "txEApp: deep internal error"-  | otherwise  +  | otherwise   = EApp f es  -txPApp (s, (Right (TI xs (Left e)))) f es -  | cmpSymbol s (val f) +txPApp (s, (Right (TI xs (Left e)))) f es+  | cmpSymbol s (val f)   = subst (mkSubst $ zip xs es) e-  | otherwise  +  | otherwise   = PBexp $ EApp f es  txPApp (s, m) f es = PBexp $ txEApp (s, m) f es  cmpSymbol s1 {- symbol in Core -} s2 {- logical Symbol-}-  = (dropModuleNames s1) == s2+  = (dropModuleNamesAndUnique s1) == (dropModuleNamesAndUnique s2)+++dropModuleNamesAndUnique = dropModuleUnique {- . dropModuleNames -}
src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-}  +{-# LANGUAGE TypeSynonymInstances #-}  module Language.Haskell.Liquid.Bare.Resolve (     Resolvable(..)@@ -25,7 +25,7 @@ import Language.Haskell.Liquid.Bare.Lookup  class Resolvable a where-  resolve     :: SourcePos -> a -> BareM a+  resolve :: SourcePos -> a -> BareM a  instance Resolvable a => Resolvable [a] where   resolve = mapM . resolve@@ -42,6 +42,7 @@   resolve l (PBexp b)       = PBexp   <$> resolve l b   resolve l (PAtom r e1 e2) = PAtom r <$> resolve l e1 <*> resolve l e2   resolve l (PAll vs p)     = PAll    <$> mapM (secondM (resolve l)) vs <*> resolve l p+  -- resolve l (PExist vs p)   = PExist  <$> mapM (secondM (resolve l)) vs <*> resolve l p   resolve _ p               = return p  instance Resolvable Expr where@@ -54,49 +55,49 @@   resolve _ x              = return x  instance Resolvable LocSymbol where-  resolve _ ls@(Loc l s)-    | s `elem` prims +  resolve _ ls@(Loc l l' s)+    | s `elem` prims     = return ls-    | otherwise +    | otherwise     = do env <- gets (typeAliases . rtEnv)          case M.lookup s env of-           Nothing | isCon s -> do v <- lookupGhcVar $ Loc l s+           Nothing | isCon s -> do v <- lookupGhcVar ls -- $ Loc l s                                    let qs = symbol v-                                   addSym (qs,v)-                                   return $ Loc l qs+                                   addSym (qs, v)+                                   return $ Loc l l' qs            _                 -> return ls  addSym x = modify $ \be -> be { varEnv = (varEnv be) `L.union` [x] } -isCon c +isCon c   | Just (c,_) <- T.uncons $ symbolText c = isUpper c   | otherwise                             = False  instance Resolvable Symbol where-  resolve l x = fmap val $ resolve l $ Loc l x +  resolve l x = fmap val $ resolve l $ Loc l l x  instance Resolvable Sort where   resolve _ FInt         = return FInt   resolve _ FReal        = return FReal   resolve _ FNum         = return FNum+  resolve _ FFrac        = return FFrac   resolve _ s@(FObj _)   = return s --FObj . S <$> lookupName env m s   resolve _ s@(FVar _)   = return s   resolve l (FFunc i ss) = FFunc i <$> resolve l ss   resolve _ (FApp tc ss)     | tcs' `elem` prims  = FApp tc <$> ss'-    | otherwise          = FApp <$> (symbolFTycon.Loc l.symbol <$> lookupGhcTyCon tcs) <*> ss'+    | otherwise          = FApp <$> (symbolFTycon . Loc l l' . symbol <$> lookupGhcTyCon tcs) <*> ss'       where-        tcs@(Loc l tcs') = fTyconSymbol tc-        ss'              = resolve l ss+        tcs@(Loc l l' tcs') = fTyconSymbol tc+        ss'                 = resolve l ss  instance Resolvable (UReft Reft) where   resolve l (U r p s) = U <$> resolve l r <*> resolve l p <*> return s  instance Resolvable Reft where-  resolve l (Reft (s, ras)) = Reft . (s,) <$> mapM resolveRefa ras+  resolve l (Reft (s, ra)) = Reft . (s,) <$> resolveRefa ra     where-      resolveRefa (RConc p) = RConc <$> resolve l p-      resolveRefa kv        = return kv+      resolveRefa (Refa p) = Refa <$> resolve l p  instance Resolvable Predicate where   resolve l (Pr pvs) = Pr <$> resolve l pvs@@ -105,5 +106,4 @@   resolve l (PV n t v as) = PV n t v <$> mapM (third3M (resolve l)) as  instance Resolvable () where-  resolve _ = return -+  resolve _ = return
src/Language/Haskell/Liquid/Bare/Spec.hs view
@@ -5,28 +5,28 @@ module Language.Haskell.Liquid.Bare.Spec (     makeClasses   , makeQualifiers-     , makeHints   , makeLVar   , makeLazy   , makeHIMeas   , makeTExpr-   , makeTargetVars   , makeAssertSpec   , makeAssumeSpec   , makeDefaultMethods-   , makeIAliases   , makeInvariants-   , makeSpecDictionaries+  , makeBounds+  , makeHBounds   ) where +import MonadUtils (mapMaybeM) import TyCon import Var  import Control.Applicative ((<$>))+import Control.Monad.Error import Control.Monad.State import Data.Maybe import Data.Monoid@@ -44,10 +44,10 @@ import Language.Haskell.Liquid.Misc (addFst3, fourth4) import Language.Haskell.Liquid.RefType (generalize, rVar, symbolRTyVar) import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Bounds  import qualified Language.Haskell.Liquid.Measure as Ms -import Language.Haskell.Liquid.Bare.Check (checkDefAsserts) import Language.Haskell.Liquid.Bare.Env import Language.Haskell.Liquid.Bare.Existential import Language.Haskell.Liquid.Bare.Lookup@@ -55,46 +55,55 @@ import Language.Haskell.Liquid.Bare.OfType import Language.Haskell.Liquid.Bare.Resolve import Language.Haskell.Liquid.Bare.SymSort+import Language.Haskell.Liquid.Bare.Measure -makeClasses cfg vs (mod, spec) = inModule mod $ mapM mkClass $ Ms.classes spec+makeClasses cmod cfg vs (mod, spec) = inModule mod $ mapM mkClass $ Ms.classes spec   where     --FIXME: cleanup this code     unClass = snd . bkClass . fourth4 . bkUniv     mkClass (RClass c ss as ms)-            = do let l   = loc c  +            = do let l   = loc  c+                 let l'  = locE c                  tc  <- lookupGhcTyCon c                  ss' <- mapM (mkSpecType l) ss                  let (dc:_) = tyConDataCons tc                  let αs  = map symbolRTyVar as                  let as' = [rVar $ symbolTyVar a | a <- as ]                  let ms' = [ (s, rFun "" (RApp c (flip RVar mempty <$> as) [] mempty) t) | (s, t) <- ms]-                 vts <- makeSpec cfg vs ms'+                 vts <- makeSpec (noCheckUnknown cfg || cmod /= mod) vs ms'                  let sts = [(val s, unClass $ val t) | (s, _)    <- ms                                                      | (_, _, t) <- vts]                  let t   = rCls tc as'-                 let dcp = DataConP l αs [] [] ss' (reverse sts) t+                 let dcp = DataConP l αs [] [] ss' (reverse sts) t l'                  return ((dc,dcp),vts)  makeQualifiers (mod,spec) = inModule mod mkQuals   where     mkQuals = mapM (\q -> resolve (q_pos q) q) $ Ms.qualifiers spec -makeHints vs spec = varSymbols id vs $ Ms.decr spec-makeLVar  vs spec = fmap fst <$> (varSymbols id vs $ [(v, ()) | v <- Ms.lvars spec])-makeLazy  vs spec = fmap fst <$> (varSymbols id vs $ [(v, ()) | v <- S.toList $ Ms.lazy spec])-makeHIMeas vs spec = fmap (uncurry $ flip Loc) <$> (varSymbols id vs $ [(v, loc v) | v <- (S.toList $ Ms.hmeas spec) ++ (S.toList $ Ms.inlines spec)])-makeTExpr vs spec = varSymbols id vs $ Ms.termexprs spec+makeHints   vs spec = varSymbols id vs $ Ms.decr spec+makeLVar    vs spec = fmap fst <$> (varSymbols id vs $ [(v, ()) | v <- Ms.lvars spec])+makeLazy    vs spec = fmap fst <$> (varSymbols id vs $ [(v, ()) | v <- S.toList $ Ms.lazy    spec])+makeHBounds vs spec = varSymbols id vs $ [(v, v ) | v <- S.toList $ Ms.hbounds spec]+makeTExpr   vs spec = varSymbols id vs $ Ms.termexprs spec+-- makeHIMeas  vs spec = fmap (uncurry $ flip Loc) <$> (varSymbols id vs $ [(v, loc v) | v <- (S.toList $ Ms.hmeas spec) ++ (S.toList $ Ms.inlines spec)])+makeHIMeas  vs spec = fmap tx <$> (varSymbols id vs $ [(v, (loc v, locE v)) | v <- (S.toList $ Ms.hmeas spec) ++ (S.toList $ Ms.inlines spec)])+  where+    tx (x,(l, l'))  = Loc l l' x +++ varSymbols :: ([Var] -> [Var]) -> [Var] -> [(LocSymbol, a)] -> BareM [(Var, a)] varSymbols f vs  = concatMapM go   where lvs        = M.map L.sort $ group [(sym v, locVar v) | v <- vs]         sym        = dropModuleNames . symbol . showPpr         locVar v   = (getSourcePos v, v)-        go (s, ns) = case M.lookup (val s) lvs of +        go (s, ns) = case M.lookup (val s) lvs of                      Just lvs -> return ((, ns) <$> varsAfter f s lvs)                      Nothing  -> ((:[]).(,ns)) <$> lookupGhcVar s -varsAfter f s lvs +varsAfter f s lvs   | eqList (fst <$> lvs)    = f (snd <$> lvs)   | otherwise               = map snd $ takeEqLoc $ dropLeLoc lvs   where@@ -122,15 +131,15 @@   | cmod == mod   = makeLocalSpec cfg cmod vs lvs (grepClassAsserts (Ms.rinstance spec)) (Ms.sigs spec ++ Ms.localSigs spec)   | otherwise-  = inModule mod $ makeSpec cfg vs $ Ms.sigs spec+  = inModule mod $ makeSpec True vs $ Ms.sigs spec  makeAssumeSpec cmod cfg vs lvs (mod,spec)   | cmod == mod   = makeLocalSpec cfg cmod vs lvs [] $ Ms.asmSigs spec   | otherwise-  = inModule mod $ makeSpec cfg vs $ Ms.asmSigs spec+  = inModule mod $ makeSpec True vs $ Ms.asmSigs spec -grepClassAsserts  = concatMap go +grepClassAsserts  = concatMap go    where     go    = map goOne . risigs     goOne = mapFst (fmap (symbol . (".$c" ++ ) . symbolString))@@ -153,11 +162,9 @@ makeLocalSpec :: Config -> ModName -> [Var] -> [Var] -> [(LocSymbol, BareType)] -> [(LocSymbol, BareType)]                     -> BareM [(ModName, Var, Located SpecType)] makeLocalSpec cfg mod vs lvs cbs xbs-  = do env   <- get-       vbs1  <- fmap expand3 <$> varSymbols fchoose lvs (dupSnd <$> xbs1)-       unless (noCheckUnknown cfg)   $ checkDefAsserts env vbs1 xbs1+  = do vbs1  <- fmap expand3 <$> varSymbols fchoose lvs (dupSnd <$> xbs1)        vts1  <- map (addFst3 mod) <$> mapM mkVarSpec vbs1-       vts2  <- makeSpec cfg vs xbs2+       vts2  <- makeSpec (noCheckUnknown cfg) vs xbs2        return $ vts1 ++ vts2   where     xbs1 = xbs1' ++ cbs@@ -168,23 +175,29 @@     fchoose ls          = maybe ls (:[]) $ L.find (`elem` vs) ls     modElem n x         = (takeModuleNames $ val x) == (symbol n) -makeSpec :: Config -> [Var] -> [(LocSymbol, BareType)]-                -> BareM [(ModName, Var, Located SpecType)]-makeSpec cfg vs xbs-  = do vbs <- map (joinVar vs) <$> lookupIds xbs-       env@(BE { modName = mod}) <- get-       unless (noCheckUnknown cfg) $ checkDefAsserts env vbs xbs+makeSpec :: Bool -> [Var] -> [(LocSymbol, BareType)]+                 -> BareM [(ModName, Var, Located SpecType)]+makeSpec ignoreUnknown vs xbs+  = do vbs <- map (joinVar vs) <$> lookupIds ignoreUnknown xbs+       (BE { modName = mod}) <- get        map (addFst3 mod) <$> mapM mkVarSpec vbs  -lookupIds = mapM lookup+lookupIds ignoreUnknown+  = mapMaybeM lookup   where-    lookup (s, t) = (,s,t) <$> lookupGhcVar s+    lookup (s, t)+      = (Just . (,s,t) <$> lookupGhcVar s) `catchError` handleError+    handleError (ErrGhc {})+      | ignoreUnknown+        = return Nothing+    handleError err+      = throwError err  mkVarSpec :: (Var, LocSymbol, BareType) -> BareM (Var, Located SpecType)-mkVarSpec (v, Loc l _, b) = tx <$> mkSpecType l b+mkVarSpec (v, Loc l l' _, b) = tx <$> mkSpecType l b   where-    tx = (v,) . Loc l . generalize+    tx = (v,) . Loc l l' . generalize   makeIAliases (mod, spec)@@ -192,41 +205,54 @@  makeIAliases' :: [(Located BareType, Located BareType)] -> BareM [(Located SpecType, Located SpecType)] makeIAliases' ts = mapM mkIA ts-  where +  where     mkIA (t1, t2)      = liftM2 (,) (mkI t1) (mkI t2)-    mkI (Loc l t)      = (Loc l) . generalize <$> mkSpecType l t+    mkI (Loc l l' t)   = (Loc l l') . generalize <$> mkSpecType l t  makeInvariants (mod,spec)   = inModule mod $ makeInvariants' $ Ms.invariants spec  makeInvariants' :: [Located BareType] -> BareM [Located SpecType] makeInvariants' ts = mapM mkI ts-  where -    mkI (Loc l t)  = (Loc l) . generalize <$> mkSpecType l t+  where+    mkI (Loc l l' t)  = (Loc l l') . generalize <$> mkSpecType l t   makeSpecDictionaries embs vars specs sp   = do ds <- (dfromList . concat)  <$>  mapM (makeSpecDictionary embs vars) specs        return $ sp {dicts = ds} -makeSpecDictionary embs vars (_, spec)  -  = mapM (makeSpecDictionaryOne embs vars) (Ms.rinstance spec)+makeSpecDictionary embs vars (_, spec)+  = catMaybes <$> mapM (makeSpecDictionaryOne embs vars) (Ms.rinstance spec) -makeSpecDictionaryOne embs vars (RI x t xts) +makeSpecDictionaryOne embs vars (RI x t xts)   = do t'  <-  mkTy t        tyi <- gets tcEnv        ts' <- (map (txRefSort tyi embs . txExpToBind)) <$> mapM mkTy' ts        let (d, dts) = makeDictionary $ RI x t' $ zip xs ts'-       let v = lookupName d   -       return (v, dts)-  where +       let v = lookupName d+       return ((, dts) <$> v)+  where     mkTy  t  = mkSpecType (loc x) t     mkTy' t  = generalize  <$> mkTy t     (xs, ts) = unzip xts-    lookupName x -             = case filter ((==x) . fst) ((\x -> (dropModuleNames $ symbol $ show x, x)) <$> vars) of -                [(_, x)] -> x-                _ -> head vars -- HACK, but since it is not imported, -                               -- the dictionary cannot be used-                               -- errorstar ("makeSpecDictionary: " ++ show x ++ "\tnot in\n" ++ show vars)+    lookupName x+             = case filter ((==x) . fst) ((\x -> (dropModuleNames $ symbol $ show x, x)) <$> vars) of+                [(_, x)] -> Just x+                _        -> Nothing +makeBounds name defVars cbs specs+  = do bnames  <- mkThing makeHBounds+       hbounds <- makeHaskellBounds cbs bnames+       bnds    <- M.fromList <$> (mapM go (concatMap (M.toList . Ms.bounds . snd ) specs))+       modify   $ \env -> env{ bounds = hbounds `mappend` bnds }+  where+    go (x,bound) = (x,) <$> (mkBound bound)+    mkThing mk   = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs, m == name]+++mkBound (Bound s vs pts xts r)+  = do ptys' <- mapM (\(x, t) -> ((x,) . toRSort) <$> mkSpecType (loc x) t) pts+       xtys' <- mapM (\(x, t) -> ((x,) . toRSort) <$> mkSpecType (loc x) t) xts+       vs'   <- map toRSort <$> mapM (mkSpecType (loc s)) vs+       Bound s vs' ptys' xtys' <$> resolve (loc s) r
src/Language/Haskell/Liquid/Bare/SymSort.hs view
@@ -51,20 +51,8 @@     where       xs = spliceArgs "addSymSortRef 2" s p --- EFFECTS: why can't we replace the next two equations with (breaks many tests)------ EFFECTS: addSymSortRef' (PV _ (PVProp t) _ ptxs) (RPropP s r@(U _ (Pr [up]) _)) --- EFFECTS:   = RProp xts $ (ofRSort t) `strengthen` r--- EFFECTS:     where--- EFFECTS:       xts = safeZip "addRefSortMono" xs ts--- EFFECTS:       xs  = snd3 <$> pargs up--- EFFECTS:       ts  = fst3 <$> ptxs---    --- EFFECTS: addSymSortRef' (PV _ (PVProp t) _ _) (RPropP s r)--- EFFECTS:   = RProp s $ (ofRSort t) `strengthen` r- addSymSortRef' rc i p (RPropP _ r@(U _ (Pr [up]) _)) -  = RProp xts ((ofRSort $ pvType p) `strengthen` r)+  = RPropP xts r -- (ofRSort (pvType p) `strengthen` r)     where       xts = safeZipWithError msg xs ts       xs  = snd3 <$> pargs up@@ -73,7 +61,7 @@             ++ " that expects " ++ show (length ts) ++ " arguments, but it has " ++ show (length xs)  addSymSortRef' _ _ _ (RPropP s r)-  = RPropP s r+  = RPropP s r -- (ofRSort (pvType p) `strengthen` r)  addSymSortRef' _ _ _ _   = errorstar "TODO:EFFECTS:addSymSortRef'"
+ src/Language/Haskell/Liquid/Bounds.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bounds (++    Bound(..),++    RBound, RRBound,++    RBEnv, RRBEnv,++    makeBound,+    envToSub++	) where++import Text.PrettyPrint.HughesPJ++import Data.List (partition)+import Data.Maybe+import Data.Hashable+import Data.Monoid+import Data.Bifunctor++import qualified Data.HashMap.Strict as M+import Control.Applicative           ((<$>))++import Language.Fixpoint.Types+import Language.Fixpoint.Misc++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.RefType+++data Bound t e+  = Bound { bname   :: LocSymbol         -- ^ The name of the bound+          , tyvars  :: [t]               -- ^ Type variables that appear in the bounds+          , bparams :: [(LocSymbol, t)]  -- ^ These are abstract refinements, for now+          , bargs   :: [(LocSymbol, t)]  -- ^ These are value variables+          , bbody   :: e                 -- ^ The body of the bound+          }++type RBound        = RRBound RSort+type RRBound tv    = Bound tv Pred++type RBEnv         = M.HashMap LocSymbol RBound+type RRBEnv tv     = M.HashMap LocSymbol (RRBound tv)+++instance Hashable (Bound t e) where+	hashWithSalt i = hashWithSalt i . bname++instance Eq (Bound t e) where+  b1 == b2 = (bname b1) == (bname b2)++instance (PPrint e, PPrint t) => (Show (Bound t e)) where+	show = showpp+++instance (PPrint e, PPrint t) => (PPrint (Bound t e)) where+	pprint (Bound s vs ps xs e) =   text "bound" <+> pprint s <+>+	                                text "forall" <+> pprint vs <+> text "." <+>+	                                pprint (fst <$> ps) <+> text "=" <+>+	                                pprint_bsyms (fst <$> xs) <+> pprint e++pprint_bsyms [] = text ""+pprint_bsyms xs = text "\\" <+> pprint xs <+> text "->"++instance Bifunctor Bound where+	first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (mapSnd f <$> ps) (mapSnd f <$> xs) e+	second f (Bound s vs ps xs e) = Bound s vs ps xs (f e)+++makeBound :: (PPrint r, UReftable r)+          => RRBound RSort -> [RRType r] -> [Symbol] -> (RRType r) -> (RRType r)+makeBound (Bound _  vs ps xs p) ts qs t+  = RRTy cts mempty OCons t+  where+    cts  = (\(x, t) -> (x, foldr subsTyVar_meet t su)) <$> cts'++    cts' = makeBoundType penv rs xs++    penv = zip (val . fst <$> ps) qs+    rs   = bkImp [] p++    bkImp acc (PImp p q) = bkImp (p:acc) q+    bkImp acc p          = p:acc++    su  = [(α, toRSort t, t) | (RVar α _, t) <-  zip vs ts ]++makeBoundType :: (PPrint r, UReftable r)+              => [(Symbol, Symbol)]+              -> [Pred]+              -> [(LocSymbol, RSort)]+              -> [(Symbol, RRType r)]+makeBoundType penv (q:qs) xts = go xts+  where+    -- NV TODO: Turn this into a proper error+    go [] = errorstar "Bound with empty symbols"++    go [(x, t)]      = [(dummySymbol, tp t x), (dummySymbol, tq t x)]+    go ((x, t):xtss) = (val x, mkt t x):(go xtss)++    mkt t x = ofRSort t `strengthen` ofUReft (U (Reft (val x, mempty))+    	                                        (Pr $ M.lookupDefault [] (val x) ps) mempty)+    tp t x  = ofRSort t `strengthen` ofUReft (U (Reft (val x, refa rs))+    	                                        (Pr $ M.lookupDefault [] (val x) ps) mempty)+    tq t x  = ofRSort t `strengthen` makeRef penv x q++    (ps, rs) = partitionPs penv qs+++-- NV TODO: Turn this into a proper error+makeBoundType _ _ _           = errorstar "Bound with empty predicates"+++partitionPs :: [(Symbol, Symbol)] -> [Pred] -> (M.HashMap Symbol [UsedPVar], [Pred])+partitionPs penv qs = mapFst makeAR $ partition (isPApp penv) qs+  where+    makeAR ps       = M.fromListWith (++) $ map (toUsedPVars penv) ps++isPApp penv (PBexp (EApp p _))  = isJust $ lookup (val p) penv+isPApp _    _                   = False++toUsedPVars penv q@(PBexp (EApp _ es)) = (x, [toUsedPVar penv q])+  where+    -- NV : TODO make this a better error+    x = (\(EVar x) -> x) $ last es+toUsedPVars _ _ = error "This cannot happen"++toUsedPVar penv (PBexp (EApp p es))+  = PV q (PVProp ()) e (((), dummySymbol,) <$> es')+   where+     EVar e = last es+     es'    = init es+     Just q = lookup (val p) penv++toUsedPVar _ _ = error "This cannot happen"++envToSub = go []+  where+    go _   []              = error "This cannot happen: envToSub on 0 elems"+    go _   [(_,_)]         = error "This cannot happen: envToSub on 1 elem"+    go ack [(_,l), (_, r)] = (reverse ack, l, r)+    go ack (x:xs)          = go (x:ack) xs++-- `makeRef` is used to make the refinement of the last implication,+-- thus it can contain both concrete and abstract refinements++makeRef :: (UReftable r) => [(Symbol, Symbol)] -> LocSymbol -> Pred -> r+makeRef penv v (PAnd rs) = ofUReft (U (Reft (val v, refa rrs)) r mempty)+  where+    r                    = Pr  (toUsedPVar penv <$> pps)+    (pps, rrs)           = partition (isPApp penv) rs++makeRef penv v rr+  | isPApp penv rr       = ofUReft (U (Reft(val v, mempty)) r mempty)+  where+    r                    = Pr [toUsedPVar penv rr]++makeRef _    v p         = ofReft (Reft(val v, Refa p))
src/Language/Haskell/Liquid/CmdLine.hs view
@@ -43,7 +43,7 @@ import           System.FilePath                     (dropFileName, isAbsolute,                                                       takeDirectory, (</>)) -import Language.Fixpoint.Config            hiding (Config, real)+import Language.Fixpoint.Config            hiding (Config, real, native, getOpts) import Language.Fixpoint.Files import Language.Fixpoint.Misc import Language.Fixpoint.Names             (dropModuleNames)@@ -82,6 +82,8 @@  , real     = def           &= help "Supports real number arithmetic"+ , native+    = def &= help "Use native (Haskell) fixpoint constraint solver"   , binders     = def &= help "Check a specific set of binders"@@ -144,9 +146,6 @@           &= typ "OPTION"           &= help "Tell GHC to compile and link against these files" - -- , verbose- --    = def &= help "Generate Verbose Output"- --          &= name "verbose-output"   } &= verbosity    &= program "liquid"@@ -211,9 +210,10 @@               Nothing -> return mempty               Just s  -> parsePragma $ envLoc s          where-            envLoc  = Loc (newPos "ENVIRONMENT" 0 0)+            envLoc  = Loc l l+            l       = newPos "ENVIRONMENT" 0 0 -copyright = "LiquidHaskell Copyright 2009-14 Regents of the University of California. All Rights Reserved.\n"+copyright = "LiquidHaskell Copyright 2009-15 Regents of the University of California. All Rights Reserved.\n"  mkOpts :: Config -> IO Config mkOpts cfg@@ -246,12 +246,13 @@   instance Monoid Config where-  mempty        = Config def def def def def def def def def def def def def def def 2 def def def def def+  mempty        = Config def def def def def def def def def def def def def def def def 2 def def def def def   mappend c1 c2 = Config { files          = sortNub $ files c1   ++     files          c2                          , idirs          = sortNub $ idirs c1   ++     idirs          c2                          , fullcheck      = fullcheck c1         ||     fullcheck      c2                          , real           = real      c1         ||     real           c2                          , diffcheck      = diffcheck c1         ||     diffcheck      c2+                         , native         = native    c1         ||     native         c2                          , binders        = sortNub $ binders c1 ++     binders        c2                          , noCheckUnknown = noCheckUnknown c1    ||     noCheckUnknown c2                          , notermination  = notermination  c1    ||     notermination  c2@@ -310,7 +311,7 @@     writeBlock _  _ ss     = forM_ ("\n" : ss) putStrLn  resDocs _ Safe             = [text "SAFE"]-resDocs k (Crash xs s)     = text ("ERROR: " ++ s) : pprManyOrdered k "" xs+resDocs k (Crash xs s)     = text ("ERROR: " ++ s) : pprManyOrdered k "" (errToFCrash <$> xs) resDocs k (Unsafe xs)      = text "UNSAFE" : pprManyOrdered k "" (nub xs) resDocs _ (UnknownError d) = [text $ "PANIC: Unexpected Error: " ++ d, reportUrl] @@ -323,4 +324,3 @@ addErrors r  _             = r instance Fixpoint (FixResult Error) where   toFix = vcat . resDocs Full-
src/Language/Haskell/Liquid/Constraint/Constraint.hs view
@@ -5,7 +5,7 @@  import Data.Monoid import Data.Maybe-import Control.Applicative +import Control.Applicative  import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.Constraint.Types@@ -14,30 +14,34 @@  instance Monoid LConstraint where 	mempty  = LC []-	mappend (LC cs1) (LC cs2) = LC (cs1 ++ cs2) +	mappend (LC cs1) (LC cs2) = LC (cs1 ++ cs2)  typeToConstraint t = LC [t] - addConstraints t γ = γ {lcs = mappend (typeToConstraint t) (lcs γ)}  constraintToLogic γ (LC ts) = pAnd (constraintToLogicOne γ  <$> ts) -constraintToLogicOne γ t-  =  pAnd [subConstraintToLogicOne (zip xs xts) (last xs, (last $ (fst <$> xts), r))  | xts <- xss]-  	where rep = toRTypeRep t-  	      ts  = ty_args  rep-  	      r   = ty_res   rep -  	      xs  = ty_binds rep -  	      xss = combinations ((\t -> [(x, t) | x <- grapBindsWithType t γ]) <$> ts)+constraintToLogicOne γ env+  =  pAnd [subConstraintToLogicOne+            (zip xs xts)+            (last xs,+            (last $ (fst <$> xts), r))+          | xts <- xss]+  where+   xts      = init env+   (xs, ts) = unzip xts+   r        = snd $ last env+   xss      = combinations ((\t -> [(x, t) | x <- grapBindsWithType t γ]) <$> ts)  subConstraintToLogicOne xts (x', (x, t)) = PImp (pAnd rs) r   where   	(rs , su) = foldl go ([], []) xts   	([r], _ ) = go ([], su) (x', (x, t))-  	go (acc, su) (x', (x, t)) = let (Reft(v, rr)) = toReft (fromMaybe mempty (stripRTypeBase t)) in-                                let su' = (x', EVar x):(v, EVar x):su in-                                (subst (mkSubst su') (pAnd [p | RConc p <- rr]):acc, su')+  	go (acc, su) (x', (x, t)) = let (Reft(v, Refa p)) = toReft (fromMaybe mempty (stripRTypeBase t))+                                        su'               = (x', EVar x):(v, EVar x) : su+                                    in+                                     (subst (mkSubst su') p : acc, su')   @@ -45,4 +49,3 @@ combinations []           = [[]] combinations ([]:_)       = [] combinations ((y:ys):yss) = [y:xs | xs <- combinations yss] ++ combinations (ys:yss)-
src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -13,26 +13,26 @@ {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE OverloadedStrings         #-} --- | This module defines the representation of Subtyping and WF Constraints, and --- the code for syntax-directed constraint generation. +-- | This module defines the representation of Subtyping and WF Constraints, and+-- the code for syntax-directed constraint generation.  module Language.Haskell.Liquid.Constraint.Generate (-    +    generateConstraints-    +   ) where  import CoreUtils     (exprType)  import CoreSyn-import SrcLoc           +import SrcLoc import Type import PrelNames-import TypeRep +import TypeRep import Class            (Class, className) import Var import Id-import Name            +import Name import NameSet import Text.PrettyPrint.HughesPJ hiding (first) @@ -55,6 +55,7 @@  import qualified Language.Haskell.Liquid.CTags      as Tg import Language.Fixpoint.Sort (pruneUnsortedReft)+import Language.Fixpoint.Visitor  import Language.Haskell.Liquid.Fresh @@ -64,14 +65,16 @@ import Language.Haskell.Liquid.Variance import Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def) import Language.Haskell.Liquid.Strata+import Language.Haskell.Liquid.Bounds import Language.Haskell.Liquid.RefType import Language.Haskell.Liquid.Visitors-import Language.Haskell.Liquid.PredType         hiding (freeTyVars)          +import Language.Haskell.Liquid.PredType         hiding (freeTyVars) import Language.Haskell.Liquid.GhcMisc          ( isInternal, collectArguments, tickSrcSpan-                                                , hasBaseTypeVar, showPpr)+                                                , hasBaseTypeVar, showPpr, isDataConId) import Language.Haskell.Liquid.Misc import Language.Fixpoint.Misc import Language.Haskell.Liquid.Literals+import Language.Haskell.Liquid.RefSplit import Control.DeepSeq  import Language.Haskell.Liquid.Constraint.Types@@ -83,7 +86,7 @@  generateConstraints      :: GhcInfo -> CGInfo generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info-  where +  where     act                  = consAct info     cfg                  = config $ spec info @@ -92,11 +95,11 @@   = do γ     <- initEnv info        sflag <- scheck <$> get        tflag <- trustghc <$> get-       let trustBinding x = if tflag -                             then (x `elem` (derVars info) || isInternal x) -                             else False +       let trustBinding x = if tflag+                             then (x `elem` (derVars info) || isInternal x)+                             else False        foldM_ (consCBTop trustBinding) γ (cbs info)-       hcs <- hsCs  <$> get +       hcs <- hsCs  <$> get        hws <- hsWfs <$> get        scss <- sCs <$> get        annot <- annotMap <$> get@@ -104,37 +107,41 @@                        else return []        let smap = if sflag then solveStrata scs else []        let hcs' = if sflag then subsS smap hcs else hcs-       fcs <- concat <$> mapM splitC (subsS smap hcs') +       fcs <- concat <$> mapM splitC (subsS smap hcs')        fws <- concat <$> mapM splitW hws        let annot' = if sflag then (\t -> subsS smap t) <$> annot else annot        modify $ \st -> st { fixCs = fcs } { fixWfs = fws } {annotMap = annot'}  -------------------------------------------------------------------------------------initEnv :: GhcInfo -> CG CGEnv  +initEnv :: GhcInfo -> CG CGEnv -------------------------------------------------------------------------------------initEnv info +initEnv info   = do let tce   = tcEmbeds sp-       let fVars = impVars info ++ filter isConLikeId (snd <$> freeSyms sp)+       let fVars = impVars info+       let dcs   = filter isConLikeId (snd <$> freeSyms sp)        defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x)-       (hs,f0)  <- refreshHoles $ grty info -- asserted refinements     (for defined vars)-       f0''     <- refreshArgs' =<< grtyTop info     -- default TOP reftype      (for exported vars without spec)+       dcsty    <- forM dcs   $ \x -> liftM (x,) (trueTy $ varType x)+       (hs,f0)  <- refreshHoles $ grty info                  -- asserted refinements     (for defined vars)+       f0''     <- refreshArgs' =<< grtyTop info             -- default TOP reftype      (for exported vars without spec)        let f0'   = if notruetypes $ config sp then [] else f0''-       f1       <- refreshArgs' $ defaults           -- default TOP reftype      (for all vars)-       f2       <- refreshArgs' $ assm info          -- assumed refinements      (for imported vars)-       f3       <- refreshArgs' $ vals asmSigs sp    -- assumed refinedments     (with `assume`)-       f4       <- refreshArgs' $ vals ctors   sp    -- constructor refinements  (for measures)+       f1       <- refreshArgs' $ defaults                   -- default TOP reftype      (for all vars)+       f1'      <- refreshArgs' $ makedcs dcsty              -- default TOP reftype      (for data cons)+       f2       <- refreshArgs' $ assm info                  -- assumed refinements      (for imported vars)+       f3       <- refreshArgs' $ vals asmSigs sp            -- assumed refinedments     (with `assume`)+       f4       <- refreshArgs' $ makedcs $ vals ctors sp    -- constructor refinements  (for measures)        sflag    <- scheck <$> get        let senv  = if sflag then f2 else []        let tx    = mapFst F.symbol . addRInv ialias . strataUnify senv . predsUnify sp-       let bs    = (tx <$> ) <$> [f0 ++ f0', f1, f2, f3, f4]+       let bs    = (tx <$> ) <$> [f0 ++ f0', f1 ++ f1', f2, f3, f4]        lts      <- lits <$> get        let tcb   = mapSnd (rTypeSort tce) <$> concat bs        let γ0    = measEnv sp (head bs) (cbs info) (tcb ++ lts) (bs!!3) hs        foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat $ tail bs]   where     sp           = spec info-    ialias       = mkRTyConIAl $ ialiases sp +    ialias       = mkRTyConIAl $ ialiases sp     vals f       = map (mapSnd val) . f+    makedcs      = map strengthenDataConType  refreshHoles vts = first catMaybes . unzip . map extract <$> mapM refreshHoles' vts refreshHoles' (x,t)@@ -144,7 +151,7 @@     tx r | hasHole r = refresh r          | otherwise = return r extract (a,b,c) = (a,(b,c))-    + refreshArgs' = mapM (mapSndM refreshArgs)  strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType)@@ -161,11 +168,11 @@  predsUnify :: GhcSpec -> (Var, RRType RReft) -> (Var, RRType RReft) predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@-                             +   where-    tce            = tcEmbeds sp +    tce            = tcEmbeds sp     tyi            = tyconEnv sp- +  ---------------------------------------------------------------------------------------  ---------------------------------------------------------------------------------------  ---------------------------------------------------------------------------------------@@ -176,29 +183,29 @@         , syenv = F.fromListSEnv $ freeSyms sp         , fenv  = initFEnv $ lts ++ (second (rTypeSort tce . val) <$> meas sp)         , denv  = dicts sp-        , recs  = S.empty +        , recs  = S.empty         , invs  = mkRTyConInv    $ invariants sp         , ial   = mkRTyConIAl    $ ialiases   sp         , grtys = fromListREnv xts         , assms = fromListREnv asms-        , emb   = tce +        , emb   = tce         , tgEnv = Tg.makeTagEnv cbs         , tgKey = Nothing         , trec  = Nothing         , lcb   = M.empty         , holes = fromListHEnv hs         , lcs   = mempty-        } +        }     where       tce = tcEmbeds sp  assm = assm_grty impVars grty = assm_grty defVars -assm_grty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ] -  where -    xs           = S.fromList $ f info -    sigs         = tySigs     $ spec info  +assm_grty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]+  where+    xs           = S.fromList $ f info+    sigs         = tySigs     $ spec info  grtyTop info     = forM topVs $ \v -> (v,) <$> (trueTy $ varType v) -- val $ varSpecType v) | v <- defVars info, isTop v]   where@@ -219,11 +226,11 @@ getTag γ = maybe Tg.defaultTag (`Tg.getTag` (tgEnv γ)) (tgKey γ)  setLoc :: CGEnv -> SrcSpan -> CGEnv-γ `setLoc` src -  | isGoodSrcSpan src = γ { loc = src } +γ `setLoc` src+  | isGoodSrcSpan src = γ { loc = src }   | otherwise         = γ -withRecs :: CGEnv -> [Var] -> CGEnv +withRecs :: CGEnv -> [Var] -> CGEnv withRecs γ xs  = γ { recs = foldl' (flip S.insert) (recs γ) xs }  withTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'}@@ -231,8 +238,8 @@         trec' = fromMaybe M.empty $ trec γ         xts'  = mapFst F.symbol <$> xts -setBind :: CGEnv -> Tg.TagKey -> CGEnv  -setBind γ k +setBind :: CGEnv -> Tg.TagKey -> CGEnv+setBind γ k   | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }   | otherwise                = γ @@ -252,53 +259,53 @@  splitW ::  WfC -> CG [FixWfC] -splitW (WfC γ t@(RFun x t1 t2 _)) +splitW (WfC γ t@(RFun x t1 t2 _))   =  do ws   <- bsplitW γ t-        ws'  <- splitW (WfC γ t1) +        ws'  <- splitW (WfC γ t1)         γ'   <- (γ, "splitW") += (x, t1)         ws'' <- splitW (WfC γ' t2)         return $ ws ++ ws' ++ ws'' -splitW (WfC γ t@(RAppTy t1 t2 _)) +splitW (WfC γ t@(RAppTy t1 t2 _))   =  do ws   <- bsplitW γ t-        ws'  <- splitW (WfC γ t1) +        ws'  <- splitW (WfC γ t1)         ws'' <- splitW (WfC γ t2)         return $ ws ++ ws' ++ ws'' -splitW (WfC γ (RAllT _ r)) +splitW (WfC γ (RAllT _ r))   = splitW (WfC γ r) -splitW (WfC γ (RAllP _ r)) +splitW (WfC γ (RAllP _ r))   = splitW (WfC γ r)  splitW (WfC γ t@(RVar _ _))-  = bsplitW γ t +  = bsplitW γ t  splitW (WfC γ t@(RApp _ ts rs _))-  =  do ws    <- bsplitW γ t -        γ'    <- γ `extendEnvWithVV` t +  =  do ws    <- bsplitW γ t+        γ'    <- γ `extendEnvWithVV` t         ws'   <- concat <$> mapM splitW (map (WfC γ') ts)         ws''  <- concat <$> mapM (rsplitW γ) rs         return $ ws ++ ws' ++ ws''  splitW (WfC γ (RAllE x tx t))-  = do  ws  <- splitW (WfC γ tx) +  = do  ws  <- splitW (WfC γ tx)         γ'  <- (γ, "splitW") += (x, tx)         ws' <- splitW (WfC γ' t)         return $ ws ++ ws'  splitW (WfC γ (REx x tx t))-  = do  ws  <- splitW (WfC γ tx) +  = do  ws  <- splitW (WfC γ tx)         γ'  <- (γ, "splitW") += (x, tx)         ws' <- splitW (WfC γ' t)         return $ ws ++ ws' -splitW (WfC _ t) +splitW (WfC _ t)   = errorstar $ "splitW cannot handle: " ++ showpp t -rsplitW _ (RPropP _ _)  +rsplitW _ (RPropP _ _)   = errorstar "Constrains: rsplitW for RPropP"-rsplitW γ (RProp ss t0) +rsplitW γ (RProp ss t0)   = do γ' <- foldM (++=) γ [("rsplitC", x, ofRSort s) | (x, s) <- ss]        splitW $ WfC γ' t0 rsplitW _ (RHProp _ _)@@ -308,11 +315,11 @@ bsplitW γ t = pruneRefs <$> get >>= return . bsplitW' γ t  bsplitW' γ t pflag-  | F.isNonTrivialSortedReft r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci] -  | otherwise                   = []-  where -    r'                          = rTypeSortedReft' pflag γ t-    ci                          = Ci (loc γ) Nothing+  | F.isNonTrivial r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci]+  | otherwise         = []+  where+    r'                = rTypeSortedReft' pflag γ t+    ci                = Ci (loc γ) Nothing  ------------------------------------------------------------ splitS  :: SubC -> CG [([Stratum], [Stratum])]@@ -322,10 +329,10 @@ splitS (SubC γ (REx x _ t1) (REx x2 _ t2)) | x == x2   = splitS (SubC γ t1 t2) -splitS (SubC γ t1 (REx _ _ t2)) +splitS (SubC γ t1 (REx _ _ t2))   = splitS (SubC γ t1 t2) -splitS (SubC γ (REx _ _ t1) t2) +splitS (SubC γ (REx _ _ t1) t2)   = splitS (SubC γ t1 t2)  splitS (SubC γ (RAllE x _ t1) (RAllE x2 _ t2)) | x == x2@@ -337,50 +344,51 @@ splitS (SubC γ t1 (RAllE _ _ t2))   = splitS (SubC γ t1 t2) -splitS (SubC γ (RRTy _ _ _ t1) t2) +splitS (SubC γ (RRTy _ _ _ t1) t2)   = splitS (SubC γ t1 t2) -splitS (SubC γ t1 (RRTy _ _ _ t2)) +splitS (SubC γ t1 (RRTy _ _ _ t2))   = splitS (SubC γ t1 t2) -splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) -  =  do cs       <- bsplitS t1 t2 -        cs'      <- splitS  (SubC γ r2 r1) -        γ'       <- (γ, "splitC") += (x2, r2) -        let r1x2' = r1' `F.subst1` (x1, F.EVar x2) -        cs''     <- splitS  (SubC γ' r1x2' r2') +splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _))+  =  do cs       <- bsplitS t1 t2+        cs'      <- splitS  (SubC γ r2 r1)+        γ'       <- (γ, "splitC") += (x2, r2)+        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)+        cs''     <- splitS  (SubC γ' r1x2' r2')         return    $ cs ++ cs' ++ cs'' -splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) -  =  do cs    <- bsplitS t1 t2 -        cs'   <- splitS  (SubC γ r1 r2) -        cs''  <- splitS  (SubC γ r1' r2') -        cs''' <- splitS  (SubC γ r2' r1') +splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))+  =  do cs    <- bsplitS t1 t2+        cs'   <- splitS  (SubC γ r1 r2)+        cs''  <- splitS  (SubC γ r1' r2')+        cs''' <- splitS  (SubC γ r2' r1')         return $ cs ++ cs' ++ cs'' ++ cs'''  splitS (SubC γ t1 (RAllP p t))   = splitS $ SubC γ t1 t'-  where t' = fmap (replacePredsWithRefs su) t-        su = (uPVar p, pVartoRConc p)+  where+    t' = fmap (replacePredsWithRefs su) t+    su = (uPVar p, pVartoRConc p) -splitS (SubC _ t1@(RAllP _ _) t2) +splitS (SubC _ t1@(RAllP _ _) t2)   = errorstar $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2  splitS (SubC γ (RAllT α1 t1) (RAllT α2 t2))-  |  α1 ==  α2 +  |  α1 ==  α2   = splitS $ SubC γ t1 t2-  | otherwise   -  = splitS $ SubC γ t1 t2' +  | otherwise+  = splitS $ SubC γ t1 t2'   where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2 -splitS (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2 +splitS (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2   = return []   splitS (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))   = do (t1',t2') <- unifyVV t1 t2        cs    <- bsplitS t1' t2'-       γ'    <- γ `extendEnvWithVV` t1' +       γ'    <- γ `extendEnvWithVV` t1'        let RApp c t1s r1s _ = t1'        let RApp _ t2s r2s _ = t2'        let tyInfo = rtc_info c@@ -388,24 +396,24 @@        csvar' <- rsplitsSWithVariance γ' r1s r2s $ variancePsArgs tyInfo        return $ cs ++ csvar ++ csvar' -splitS (SubC _ t1@(RVar a1 _) t2@(RVar a2 _)) +splitS (SubC _ t1@(RVar a1 _) t2@(RVar a2 _))   | a1 == a2   = bsplitS t1 t2 -splitS (SubC _ t1 t2) +splitS (SubC _ t1 t2)   = errorstar $ "(Another Broken Test!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2  splitS (SubR _ _ _)   = return [] -splitsSWithVariance γ t1s t2s variants +splitsSWithVariance γ t1s t2s variants   = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitS (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants) -rsplitsSWithVariance γ t1s t2s variants +rsplitsSWithVariance γ t1s t2s variants   = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitS γ) t1 t2 v) (zip3 t1s t2s variants) -bsplitS t1 t2 -  = return $ [(s1, s2)] +bsplitS t1 t2+  = return $ [(s1, s2)]   where [s1, s2]   = getStrata <$> [t1, t2]  rsplitS γ (RProp s1 r1) (RProp s2 r2)@@ -414,9 +422,9 @@  rsplitS _ _ _   = errorstar "rspliS Rpoly - RPropP"-    + splitfWithVariance f t1 t2 Invariant     = liftM2 (++) (f t1 t2) (f t2 t1) -- return [] splitfWithVariance f t1 t2 Bivariant     = liftM2 (++) (f t1 t2) (f t2 t1) splitfWithVariance f t1 t2 Covariant     = f t1 t2@@ -431,15 +439,13 @@   = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)        splitC (SubC γ' t1 t2) -splitC (SubC γ t1 (REx x tx t2)) +splitC (SubC γ t1 (REx x tx t2))   = do γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)-       let xs  = grapBindsWithType tx γ-       let t2' = splitExistsCases x xs tx t2-       splitC (SubC γ' t1 t2')+       splitC (SubC γ' t1 t2)  -- existential at the left hand side is treated like forall-splitC (SubC γ (REx x tx t1) t2) -  = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx +splitC (SubC γ (REx x tx t1) t2)+  = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx        γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)        splitC (SubC γ' t1 t2) @@ -447,7 +453,6 @@   = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)        splitC (SubC γ' t1 t2) - splitC (SubC γ (RAllE x tx t1) t2)   = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)        splitC (SubC γ' t1 t2)@@ -456,54 +461,49 @@   = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)        splitC (SubC γ' t1 t2) -splitC (SubC γ (RRTy [(_, t)] _ OCons t1) t2)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ (zip xs ts)+splitC (SubC γ (RRTy env _ OCons t1) t2)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts        c1 <- splitC (SubC γ' t1' t2')        c2 <- splitC (SubC γ  t1  t2 )        return $ c1 ++ c2   where-    trep = toRTypeRep t-    xs   = init $ ty_binds trep-    ts   = init $ ty_args  trep-    t2'  = ty_res   trep-    t1'  = last $ ty_args trep--+    (xts, t1', t2') = envToSub env -splitC (SubC γ (RRTy e r o t1) t2) -  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e +splitC (SubC γ (RRTy e r o t1) t2)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e        c1 <- splitC (SubR γ' o  r )        c2 <- splitC (SubC γ t1 t2)        return $ c1 ++ c2 -splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) -  =  do cs       <- bsplitC γ t1 t2 -        cs'      <- splitC  (SubC γ r2 r1) -        γ'       <- (γ, "splitC") += (x2, r2) -        let r1x2' = r1' `F.subst1` (x1, F.EVar x2) -        cs''     <- splitC  (SubC γ' r1x2' r2') +splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _))+  =  do cs       <- bsplitC γ t1 t2+        cs'      <- splitC  (SubC γ r2 r1)+        γ'       <- (γ, "splitC") += (x2, r2)+        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)+        cs''     <- splitC  (SubC γ' r1x2' r2')         return    $ cs ++ cs' ++ cs'' -splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) -  =  do cs    <- bsplitC γ t1 t2 -        cs'   <- splitC  (SubC γ r1 r2) -        cs''  <- splitC  (SubC γ r1' r2') -        cs''' <- splitC  (SubC γ r2' r1') +splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))+  =  do cs    <- bsplitC γ t1 t2+        cs'   <- splitC  (SubC γ r1 r2)+        cs''  <- splitC  (SubC γ r1' r2')+        cs''' <- splitC  (SubC γ r2' r1')         return $ cs ++ cs' ++ cs'' ++ cs'''  splitC (SubC γ t1 (RAllP p t))   = splitC $ SubC γ t1 t'-  where t' = fmap (replacePredsWithRefs su) t-        su = (uPVar p, pVartoRConc p)+  where+    t' = fmap (replacePredsWithRefs su) t+    su = (uPVar p, pVartoRConc p) -splitC (SubC _ t1@(RAllP _ _) t2) +splitC (SubC _ t1@(RAllP _ _) t2)   = errorstar $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2  splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2))-  |  α1 ==  α2 +  |  α1 ==  α2   = splitC $ SubC γ t1 t2-  | otherwise   -  = splitC $ SubC γ t1 t2' +  | otherwise+  = splitC $ SubC γ t1 t2'   where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2  @@ -513,7 +513,7 @@ splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))   = do (t1',t2') <- unifyVV t1 t2        cs    <- bsplitC γ t1' t2'-       γ'    <- γ `extendEnvWithVV` t1' +       γ'    <- γ `extendEnvWithVV` t1'        let RApp c t1s r1s _ = t1'        let RApp _ t2s r2s _ = t2'        let tyInfo = rtc_info c@@ -521,43 +521,43 @@        csvar' <- rsplitsCWithVariance γ' r1s r2s $ variancePsArgs tyInfo        return $ cs ++ csvar ++ csvar' -splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _)) +splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _))   | a1 == a2   = bsplitC γ t1 t2 -splitC (SubC _ t1 t2) +splitC (SubC _ t1 t2)   = errorstar $ "(Another Broken Test!!!) splitc unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2  splitC (SubR γ o r)-  = do fg     <- pruneRefs <$> get +  = do fg     <- pruneRefs <$> get        let r1' = if fg then pruneUnsortedReft γ'' r1 else r1        return $ F.subC γ' F.PTrue r1' r2 Nothing tag ci   where     γ'' = fe_env $ fenv γ     γ'  = fe_binds $ fenv γ     r1  = F.RR s $ F.toReft r-    r2  = F.RR s $ F.Reft (vv, [F.RConc $ F.PBexp $ F.EVar vv])+    r2  = F.RR s $ F.Reft (vv, F.Refa $ F.PBexp $ F.EVar vv)     vv  = "vvRec"     s   = F.FApp F.boolFTyCon []     ci  = Ci src err     err = Just $ ErrAssType src o (text $ show o ++ "type error") r     tag = getTag γ-    src = loc γ +    src = loc γ  -splitsCWithVariance γ t1s t2s variants +splitsCWithVariance γ t1s t2s variants   = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> (splitC (SubC γ s1 s2))) t1 t2 v) (zip3 t1s t2s variants) -rsplitsCWithVariance γ t1s t2s variants +rsplitsCWithVariance γ t1s t2s variants   = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants)    bsplitC γ t1 t2-  = do checkStratum γ t1 t2 +  = do checkStratum γ t1 t2        pflag <- pruneRefs <$> get-       γ' <- γ ++= ("bsplitC", v, t1) -       let r = (mempty :: UReft F.Reft){ur_reft = F.Reft (F.dummySymbol,  [F.RConc $ constraintToLogic γ' (lcs γ')])}+       γ' <- γ ++= ("bsplitC", v, t1)+       let r = (mempty :: UReft F.Reft){ur_reft = F.Reft (F.dummySymbol,  F.Refa $ constraintToLogic γ' (lcs γ'))}        let t1' = addRTyConInv (invs γ')  t1 `strengthen` r        return $ bsplitC' γ' t1' t2 pflag   where@@ -566,25 +566,26 @@ checkStratum γ t1 t2   | s1 <:= s2 = return ()   | otherwise = addWarning wrn-  where [s1, s2]   = getStrata <$> [t1, t2]-        wrn        =  ErrOther (loc γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2) +  where+    [s1, s2]  = getStrata <$> [t1, t2]+    wrn       =  ErrOther (loc γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2)  bsplitC' γ t1 t2 pflag-  | F.isFunctionSortedReft r1' && F.isNonTrivialSortedReft r2'+  | F.isFunctionSortedReft r1' && F.isNonTrivial r2'   = F.subC γ' grd (r1' {F.sr_reft = mempty}) r2' Nothing tag ci-  | F.isNonTrivialSortedReft r2'+  | F.isNonTrivial r2'   = F.subC γ' grd r1'  r2' Nothing tag ci   | otherwise   = []-  where +  where     γ'     = fe_binds $ fenv γ     r1'    = rTypeSortedReft' pflag γ t1     r2'    = rTypeSortedReft' pflag γ t2     ci     = Ci src err     tag    = getTag γ-    err    = Just $ ErrSubType src (text "subtype") g t1 t2 +    err    = Just $ ErrSubType src (text "subtype") g t1 t2     src    = loc γ-    REnv g = renv γ +    REnv g = renv γ     grd    = F.PTrue  @@ -593,10 +594,10 @@   = do vv     <- (F.vv . Just) <$> fresh        return  $ (shiftVV t1 vv,  (shiftVV t2 vv) ) -- {rt_pargs = r2s'}) -unifyVV _ _ +unifyVV _ _   = errorstar $ "Constraint.Generate.unifyVV called on invalid inputs" -rsplitC _ (RPropP _ _) (RPropP _ _) +rsplitC _ (RPropP _ _) (RPropP _ _)   = errorstar "RefTypes.rsplitC on RPropP"  rsplitC γ (RProp s1 r1) (RProp s2 r2)@@ -604,26 +605,26 @@        splitC (SubC γ' (F.subst su r1) r2)   where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2] -rsplitC _ _ _  +rsplitC _ _ _   = errorstar "rsplit Rpoly - RPropP"   type CG = State CGInfo  initCGI cfg info = CGInfo {-    hsCs       = [] -  , sCs        = [] -  , hsWfs      = [] +    hsCs       = []+  , sCs        = []+  , hsWfs      = []   , fixCs      = []   , isBind     = []-  , fixWfs     = [] +  , fixWfs     = []   , freshIndex = 0   , binds      = F.emptyBindEnv   , annotMap   = AI M.empty   , tyConInfo  = tyi-  , tyConEmbed = tce  -  , kuts       = F.ksEmpty -  , lits       = coreBindLits tce info +  , tyConEmbed = tce+  , kuts       = F.ksEmpty+  , lits       = coreBindLits tce info   , termExprs  = M.fromList $ texprs spc   , specDecr   = decr spc   , specLVars  = lvars spc@@ -635,58 +636,68 @@   , logErrors  = []   , kvProf     = emptyKVProf   , recCount   = 0-  } -  where -    tce        = tcEmbeds spc +  }+  where+    tce        = tcEmbeds spc     spc        = spec info     tyi        = tyconEnv spc -- EFFECTS HEREHEREHERE makeTyConInfo (tconsP spc)  coreBindLits tce info-  = sortNub      $ [ (val x, so) | (_, Just (F.ELit x so)) <- lconsts]-                ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons]-  where +  = sortNub      $ [ (val x, so) | (_, Just (F.ELit x so)) <- lconsts ]+                ++ [(F.symbol x, F.strSort) | (_, Just (F.ESym x)) <- lconsts ]+                ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ]+  where     lconsts      = literalConst tce <$> literals (cbs info)-    dcons        = filter isDCon $ impVars info-    dconToSort   = typeSort tce . expandTypeSynonyms . varType +    dcons        = filter isDCon $ impVars info -- ++ (snd <$> freeSyms (spec info))+    dconToSort   = typeSort tce . expandTypeSynonyms . varType     dconToSym    = dataConSymbol . idDataCon-    isDCon x     = isDataConWorkId x && not (hasBaseTypeVar x)+    isDCon x     = isDataConId x && not (hasBaseTypeVar x) -extendEnvWithVV γ t +extendEnvWithVV γ t   | F.isNontrivialVV vv   = (γ, "extVV") += (vv, t)   | otherwise   = return γ   where vv = rTypeValueVar t -{- see tests/pos/polyfun for why you need everything in fixenv -} +{- see tests/pos/polyfun for why you need everything in fixenv -} addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-addCGEnv tx γ (msg, x, RAllE y tyy tyx)-  = do y' <- fresh +addCGEnv tx γ (msg, x, REx y tyy tyx)+  = do y' <- fresh        γ' <- addCGEnv tx γ (msg, y', tyy)        addCGEnv tx γ' (msg, x, tyx `F.subst1` (y, F.EVar y')) -addCGEnv tx γ (_, x, t') +addCGEnv tx γ (msg, x, RAllE yy tyy tyx)+  = addCGEnv tx γ (msg, x, t)+  where+    xs    = grapBindsWithType tyy γ+    t     = foldl (\t1 t2 -> t1 `F.meet` t2) ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]++    (tyx', ttrue) = splitXRelatedRefs yy tyx++addCGEnv tx γ (_, x, t')   = do idx   <- fresh-       let t  = tx $ normalize {-x-} idx t'  -       let γ' = γ { renv = insertREnv x t (renv γ) }  +       let t  = tx $ normalize {-x-} idx t'+       let γ' = γ { renv = insertREnv x t (renv γ) }        pflag <- pruneRefs <$> get-       is    <- if isBase t +       is    <- if isBase t                   then liftM2 (++) (liftM single $ addBind x $ rTypeSortedReft' pflag γ' t) (addClassBind t)-                  else return [] -- addClassBind t +                  else return [] -- addClassBind t        return $ γ' { fenv = insertsFEnv (fenv γ) is }  (++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-(++=) γ = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ  +(++=) γ = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ  addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ -rTypeSortedReft' pflag γ +rTypeSortedReft' pflag γ   | pflag   = pruneUnsortedReft (fe_env $ fenv γ) . f   | otherwise-  = f -  where f = rTypeSortedReft (emb γ)+  = f+  where+    f = rTypeSortedReft (emb γ)  (+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv @@ -697,43 +708,43 @@   | x == F.dummySymbol   = return γ   | x `memberREnv` (renv γ)-  = err +  = err   | otherwise-  =  γ ++= (msg, x, r) -  where err = errorstar $ msg ++ " Duplicate binding for " -                              ++ F.symbolString x +  =  γ ++= (msg, x, r)+  where err = errorstar $ msg ++ " Duplicate binding for "+                              ++ F.symbolString x                               ++ "\n New: " ++ showpp r                               ++ "\n Old: " ++ showpp (x `lookupREnv` (renv γ))-                        + γ -= x =  γ {renv = deleteREnv x (renv γ), lcb  = M.delete x (lcb γ)}  (??=) :: CGEnv -> F.Symbol -> CG SpecType-γ ??= x +γ ??= x   = case M.lookup x (lcb γ) of     Just e  -> consE (γ-=x) e     Nothing -> refreshTy $ γ ?= x -(?=) ::  CGEnv -> F.Symbol -> SpecType +(?=) ::  CGEnv -> F.Symbol -> SpecType γ ?= x = fromMaybe err $ lookupREnv x (renv γ)-         where err = errorstar $ "EnvLookup: unknown " -                               ++ showpp x -                               ++ " in renv " +         where err = errorstar $ "EnvLookup: unknown "+                               ++ showpp x+                               ++ " in renv "                                ++ showpp (renv γ) -normalize idx -  = normalizeVV idx +normalize idx+  = normalizeVV idx   . normalizePds  normalizeVV idx t@(RApp _ _ _ _)   | not (F.isNontrivialVV (rTypeValueVar t))   = shiftVV t (F.vv $ Just idx) -normalizeVV _ t -  = t +normalizeVV _ t+  = t   addBind :: F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)-addBind x r +addBind x r   = do st          <- get        let (i, bs') = F.insertBindEnv x r (binds st)        put          $ st { binds = bs' }@@ -749,94 +760,94 @@        modify $ \s -> s { isBind = tail (isBind s) }        return z -addC :: SubC -> String -> CG ()  -addC !c@(SubC γ t1 t2) _msg +addC :: SubC -> String -> CG ()+addC !c@(SubC γ t1 t2) _msg   = do -- trace ("addC at " ++ show (loc γ) ++ _msg++ showpp t1 ++ "\n <: \n" ++ showpp t2 ) $        modify $ \s -> s { hsCs  = c : (hsCs s) }        bflag <- headDefault True . isBind <$> get-       sflag <- scheck                 <$> get +       sflag <- scheck                 <$> get        if bflag && sflag          then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) }          else return ()-  where +  where     headDefault a []    = a     headDefault _ (x:_) = x  -addC !c _msg +addC !c _msg   = modify $ \s -> s { hsCs  = c : (hsCs s) } -addPost γ (RRTy e r OInv t) -  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e +addPost γ (RRTy e r OInv t)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e        addC (SubR γ' OInv r) "precondition" >> return t -addPost γ (RRTy e r OTerm t) -  = do γ' <- foldM (\γ (x, t) -> γ ++= ("addPost", x,t)) γ e +addPost γ (RRTy e r OTerm t)+  = do γ' <- foldM (\γ (x, t) -> γ ++= ("addPost", x,t)) γ e        addC (SubR γ' OTerm r) "precondition" >> return t -addPost _ (RRTy _ _ OCons t) +addPost _ (RRTy _ _ OCons t)   = return t -addPost _ t  +addPost _ t   = return t -addW   :: WfC -> CG ()  +addW   :: WfC -> CG () addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) } -addWarning   :: TError SpecType -> CG ()  +addWarning   :: TError SpecType -> CG () addWarning w = modify $ \s -> s { logErrors = w : (logErrors s) }  -- | Used for annotation binders (i.e. at binder sites)  addIdA            :: Var -> Annot SpecType -> CG () addIdA !x !t      = modify $ \s -> s { annotMap = upd $ annotMap s }-  where +  where     loc           = getSrcSpan x     upd m@(AI _)  = if boundRecVar loc m then m else addA loc (Just x) t m  boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]  --- | Used for annotating reads (i.e. at Var x sites) +-- | Used for annotating reads (i.e. at Var x sites)  addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()-addLocA !xo !l !t +addLocA !xo !l !t   = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }  -- | Used to update annotations for a location, due to (ghost) predicate applications  updateLocA (_:_)  (Just l) t = addLocA Nothing l (AnnUse t)-updateLocA _      _        _ = return () +updateLocA _      _        _ = return ()  addA !l xo@(Just _) !t (AI m)-  | isGoodSrcSpan l +  | isGoodSrcSpan l   = AI $ inserts l (T.pack . showPpr <$> xo, t) m addA !l xo@Nothing  !t (AI m)   | l `M.member` m                  -- only spans known to be variables   = AI $ inserts l (T.pack . showPpr <$> xo, t) m-addA _ _ _ !a +addA _ _ _ !a   = a  ------------------------------------------------------------------- ------------------------ Generation: Freshness -------------------- ------------------------------------------------------------------- --- | Right now, we generate NO new pvars. Rather than clutter code ---   with `uRType` calls, put it in one place where the above +-- | Right now, we generate NO new pvars. Rather than clutter code+--   with `uRType` calls, put it in one place where the above --   invariant is /obviously/ enforced. --   Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@ -freshTy_type        :: KVKind -> CoreExpr -> Type -> CG SpecType +freshTy_type        :: KVKind -> CoreExpr -> Type -> CG SpecType freshTy_type k _ τ  = freshTy_reftype k $ ofType τ -freshTy_expr        :: KVKind -> CoreExpr -> Type -> CG SpecType +freshTy_expr        :: KVKind -> CoreExpr -> Type -> CG SpecType freshTy_expr k e _  = freshTy_reftype k $ exprRefType e -freshTy_reftype     :: KVKind -> SpecType -> CG SpecType --- freshTy_reftype k t = do t <- refresh =<< fixTy t +freshTy_reftype     :: KVKind -> SpecType -> CG SpecType+-- freshTy_reftype k t = do t <- refresh =<< fixTy t --                          addKVars k t --                          return t-                       + freshTy_reftype k t = (fixTy t >>= refresh) =>> addKVars k  -- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive@@ -852,36 +863,38 @@ isKut RecBindE = True isKut _        = False -specTypeKVars :: SpecType -> [F.Symbol]-specTypeKVars = foldReft ((++) . (F.reftKVars . ur_reft)) []+specTypeKVars :: SpecType -> [F.KVar]+specTypeKVars = foldReft ((++) . (kvars . ur_reft)) []  trueTy  :: Type -> CG SpecType trueTy = ofType' >=> true  ofType' :: Type -> CG SpecType ofType' = fixTy . ofType-  + fixTy :: SpecType -> CG SpecType fixTy t = do tyi   <- tyConInfo  <$> get              tce   <- tyConEmbed <$> get              return $ addTyConInfo tce tyi t  refreshArgsTop :: (Var, SpecType) -> CG SpecType-refreshArgsTop (x, t) +refreshArgsTop (x, t)   = do (t', su) <- refreshArgsSub t        modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}        return t'-  + refreshArgs :: SpecType -> CG SpecType-refreshArgs t +refreshArgs t   = fst <$> refreshArgsSub t ++-- NV TODO: this does not refreshes args if they are wrapped in an RRTy refreshArgsSub :: SpecType -> CG (SpecType, F.Subst)-refreshArgsSub t +refreshArgsSub t   = do ts     <- mapM refreshArgs ts_u        xs'    <- mapM (\_ -> fresh) xs        let sus = F.mkSubst <$> (L.inits $ zip xs (F.EVar <$> xs'))-       let su  = last sus +       let su  = last sus        let ts' = zipWith F.subst sus ts        let t'  = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = F.subst su tbd}        return (t', su)@@ -896,8 +909,8 @@              let n = freshIndex s              put $ s { freshIndex = n + 1 }              return n-  	 + ------------------------------------------------------------------------------- ----------------------- TERMINATION TYPE -------------------------------------- -------------------------------------------------------------------------------@@ -922,50 +935,71 @@          Nothing -> return $ Left msg -- addWarning msg >> return []          Just i  -> return $ Right $ fromMaybe [i] hint     where-       ts         = ty_args $ toRTypeRep t-       checkHint' = checkHint x ts isDecreasing-       dindex     = L.findIndex isDecreasing ts-       msg        = ErrTermin [x] (getSrcSpan x) (text "No decreasing parameter") +       ts         = ty_args trep+       checkHint' = checkHint x ts (isDecreasing cenv)+       dindex     = L.findIndex (isDecreasing cenv) ts+       msg        = ErrTermin [x] (getSrcSpan x) (text "No decreasing parameter")+       cenv       = makeNumEnv ts +       trep       = toRTypeRep $ unOCons t + recType ((_, []), (_, [], t))   = t  recType ((vs, indexc), (_, index, t))-  = makeRecType t v dxt index       +  = makeRecType t v dxt index   where v    = (vs !!)  <$> indexc         dxt  = (xts !!) <$> index-        xts  = zip (ty_binds trep) (ty_args trep) -        trep = toRTypeRep t+        xts  = zip (ty_binds trep) (ty_args trep)+        trep = toRTypeRep $ unOCons t  checkIndex (x, vs, t, index)   = do mapM_ (safeLogIndex msg' vs) index        mapM  (safeLogIndex msg  ts) index     where        loc   = getSrcSpan x-       ts    = ty_args $ toRTypeRep $ unTemplate t-       msg'  = ErrTermin [x] loc (text $ "No decreasing argument on " ++ (showPpr x) ++ " with " ++ (showPpr vs))+       ts    = ty_args $ toRTypeRep $ unOCons $ unTemplate t+       msg'  = ErrTermin [x] loc (text $ "No decreasing " ++ show index ++ "-th argument on " ++ (showPpr x) ++ " with " ++ (showPpr vs))        msg   = ErrTermin [x] loc (text "No decreasing parameter")  makeRecType t vs dxs is-  = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}+  = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}   where     (xs', ts') = unzip $ replaceN (last is) (makeDecrType vdxs) xts     vdxs       = zip vs dxs     xts        = zip (ty_binds trep) (ty_args trep)-    trep       = toRTypeRep t+    trep       = toRTypeRep $ unOCons t +unOCons (RAllT v t)        = RAllT v $ unOCons t+unOCons (RAllP p t)        = RAllP p $ unOCons t+unOCons (RFun x tx t r)    = RFun x (unOCons tx) (unOCons t) r+unOCons (RRTy _ _ OCons t) = unOCons t+unOCons t                  = t+++mergecondition (RAllT _ t1) (RAllT v t2)+  = RAllT v $ mergecondition t1 t2+mergecondition (RAllP _ t1) (RAllP p t2)+  = RAllP p $ mergecondition t1 t2+mergecondition (RRTy xts r OCons t1) t2+  = RRTy xts r OCons (mergecondition t1 t2)+mergecondition (RFun _ t11 t12 _) (RFun x2 t21 t22 r2)+  = RFun x2 (mergecondition t11 t21) (mergecondition t12 t22) r2+mergecondition _ t+  = t+ safeLogIndex err ls n   | n >= length ls = addWarning err >> return Nothing   | otherwise      = return $ Just $ ls !! n -checkHint _ _ _ Nothing +checkHint _ _ _ Nothing   = return Nothing  checkHint x _ _ (Just ns) | L.sort ns /= ns   = addWarning (ErrTermin [x] loc (text "The hints should be increasing")) >> return Nothing   where loc = getSrcSpan x -checkHint x ts f (Just ns) +checkHint x ts f (Just ns)   = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes)  checkValidHint x ts f n@@ -978,8 +1012,8 @@ ------------------------------------------------------------------- -------------------- Generation: Corebind ------------------------- --------------------------------------------------------------------consCBTop :: (Var -> Bool) -> CGEnv -> CoreBind -> CG CGEnv -consCBLet :: CGEnv -> CoreBind -> CG CGEnv +consCBTop :: (Var -> Bool) -> CGEnv -> CoreBind -> CG CGEnv+consCBLet :: CGEnv -> CoreBind -> CG CGEnv -------------------------------------------------------------------  consCBLet γ cb@@ -1014,7 +1048,7 @@         binds (Rec xes)    = fst $ unzip xes  --------------------------------------------------------------------consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv +consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv -------------------------------------------------------------------  consCBSizedTys γ xes@@ -1038,7 +1072,7 @@        return γ'   where        (xs, es) = unzip xes-       collectArgs    = collectArguments . length . ty_binds . toRTypeRep . unTemplate+       collectArgs    = collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate        checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]        checkEqTypes x = mapM (checkAll err1 toRSort) (catMaybes <$> x)        checkSameLens  = checkAll err2 length@@ -1047,9 +1081,9 @@        loc            = getSrcSpan (head xs)         checkAll _   _ []            = return []-       checkAll err f (x:xs) +       checkAll err f (x:xs)          | all (==(f x)) (f <$> xs) = return (x:xs)-         | otherwise                = addWarning err >> return [] +         | otherwise                = addWarning err >> return []  consCBWithExprs γ xes   = do xets'     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))@@ -1082,27 +1116,25 @@ makeTermEnvs γ xtes xes ts ts' = withTRec γ . zip xs <$> rts   where     vs   = zipWith collectArgs ts es-    ys   = (fst3 . bkArrowDeep) <$> ts -    ys'  = (fst3 . bkArrowDeep) <$> ts'+    ys   = (fst4 . bkArrowDeep) <$> ts+    ys'  = (fst4 . bkArrowDeep) <$> ts'     sus' = zipWith mkSub ys ys'     sus  = zipWith mkSub ys ((F.symbol <$>) <$> vs)     ess  = (\x -> (safeFromJust (err x) $ (x `L.lookup` xtes))) <$> xs-    tes  = zipWith (\su es -> F.subst su <$> es)  sus ess -    tes' = zipWith (\su es -> F.subst su <$> es)  sus' ess +    tes  = zipWith (\su es -> F.subst su <$> es)  sus ess+    tes' = zipWith (\su es -> F.subst su <$> es)  sus' ess     rss  = zipWith makeLexRefa tes' <$> (repeat <$> tes)     rts  = zipWith addTermCond ts' <$> rss     (xs, es)     = unzip xes     mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']     collectArgs  = collectArguments . length . ty_binds . toRTypeRep-    err x        = "Constant: makeTermEnvs: no terminating expression for " ++ showPpr x -+    err x        = "Constant: makeTermEnvs: no terminating expression for " ++ showPpr x -                   -consCB tflag _ γ (Rec xes) | tflag +consCB tflag _ γ (Rec xes) | tflag   = do texprs <- termExprs <$> get        modify $ \i -> i { recCount = recCount i + length xes }        let xxes = catMaybes $ (`lookup` texprs) <$> xs-       if null xxes +       if null xxes          then consCBSizedTys γ xes          else check xxes <$> consCBWithExprs γ xes   where xs = fst $ unzip xes@@ -1122,22 +1154,22 @@        let xts = [(x, to) | (x, _, to) <- xets]        γ'     <- foldM extender (γ `withRecs` (fst <$> xts)) xts        mapM_ (consBind True γ') xets-       return γ' +       return γ' -consCB _ _ γ (Rec xes) +consCB _ _ γ (Rec xes)   = do xets   <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))        modify $ \i -> i { recCount = recCount i + length xes }        let xts = [(x, to) | (x, _, to) <- xets]        γ'     <- foldM extender (γ `withRecs` (fst <$> xts)) xts        mapM_ (consBind True γ') xets-       return γ' +       return γ' --- | NV: Dictionaries are not checked, because +-- | NV: Dictionaries are not checked, because -- | class methods' preconditions are not satisfied consCB _ _ γ (NonRec x _) | isDictionary x   = do t  <- trueTy (varType x)        extender γ (x, Assumed t)-  where     +  where     isDictionary = isJust . dlookup (denv γ)  @@ -1155,11 +1187,11 @@   consCB _ _ γ (NonRec x e)-  = do to  <- varTemplate γ (x, Nothing) +  = do to  <- varTemplate γ (x, Nothing)        to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)        extender γ (x, to') -consBind isRec γ (x, e, Asserted spect) +consBind isRec γ (x, e, Asserted spect)   = do let γ'         = (γ `setLoc` getSrcSpan x) `setBind` x            (_,πs,_,_) = bkUniv spect        γπ    <- foldM addPToEnv γ' πs@@ -1170,7 +1202,7 @@        addIdA x (defAnn isRec spect)        return $ Asserted spect -- Nothing -consBind isRec γ (x, e, Assumed spect) +consBind isRec γ (x, e, Assumed spect)   = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x        γπ    <- foldM addPToEnv γ' πs        cconsE γπ e =<< true spect@@ -1186,12 +1218,19 @@ noHoles = and . foldReft (\r bs -> not (hasHole r) : bs) []  killSubst :: RReft -> RReft-killSubst = fmap tx+killSubst = fmap killSubstReft++killSubstReft :: F.Reft -> F.Reft+killSubstReft = trans kv () ()   where-    tx (F.Reft (s, rs)) = F.Reft (s, map f rs)-    f (F.RKvar k _) = F.RKvar k mempty-    f (F.RConc p)   = F.RConc p+    kv    = defaultVisitor { txPred = ks }+    ks _ (F.PKVar k _) = F.PKVar k mempty+    ks _ p             = p +    -- tx (F.Reft (s, rs)) = F.Reft (s, map f rs)+    -- f (F.RKvar k _)     = F.RKvar k mempty+    -- f (F.RConc p)       = F.RConc p+ defAnn True  = AnnRDf defAnn False = AnnDef @@ -1215,10 +1254,10 @@  addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t addPostTemplate γ (Assumed  t) = Assumed  <$> addPost γ t-addPostTemplate _ Unknown      = return Unknown +addPostTemplate _ Unknown      = return Unknown  safeFromAsserted _ (Asserted t) = t-safeFromAsserted msg _ = errorstar $ "safeFromAsserted:" ++ msg +safeFromAsserted msg _ = errorstar $ "safeFromAsserted:" ++ msg  -- | @varTemplate@ is only called with a `Just e` argument when the `e` -- corresponds to the body of a @Rec@ binder.@@ -1237,12 +1276,12 @@ -------------------------------------------------------------------  ----------------------- Type Checking ------------------------------cconsE :: CGEnv -> Expr Var -> SpecType -> CG () +cconsE :: CGEnv -> Expr Var -> SpecType -> CG () ------------------------------------------------------------------- cconsE γ e@(Let b@(NonRec x _) ee) t   = do sp <- specLVars <$> get-       if (x `S.member` sp) || isDefLazyVar x  -        then cconsLazyLet γ e t +       if (x `S.member` sp) || isDefLazyVar x+        then cconsLazyLet γ e t         else do γ'  <- consCBLet γ b                 cconsE γ' ee t   where@@ -1254,37 +1293,33 @@     t'         = replacePredsWithRefs su <$> t     su         = (uPVar p, pVartoRConc p)     (css, t'') = splitConstraints t'-    γ'         = foldl (flip addConstraints) γ css ----- cconsE γ e (RRTy [(_, cs)] _ OCons t)---   = cconsE (addConstraints cs γ) e t+    γ'         = foldl (flip addConstraints) γ css -cconsE γ (Let b e) t    +cconsE γ (Let b e) t   = do γ'  <- consCBLet γ b-       cconsE γ' e t +       cconsE γ' e t -cconsE γ (Case e x _ cases) t +cconsE γ (Case e x _ cases) t   = do γ'  <- consCBLet γ (NonRec x e)-       forM_ cases $ cconsCase γ' x t nonDefAlts -    where +       forM_ cases $ cconsCase γ' x t nonDefAlts+    where        nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT] -cconsE γ (Lam α e) (RAllT α' t) | isTyVar α -  = cconsE γ e $ subsTyVar_meet' (α', rVar α) t +cconsE γ (Lam α e) (RAllT α' t) | isTyVar α+  = cconsE γ e $ subsTyVar_meet' (α', rVar α) t -cconsE γ (Lam x e) (RFun y ty t _) -  | not (isTyVar x) +cconsE γ (Lam x e) (RFun y ty t _)+  | not (isTyVar x)   = do γ' <- (γ, "cconsE") += (F.symbol x, ty)        cconsE γ' e (t `F.subst1` (y, F.EVar $ F.symbol x))-       addIdA x (AnnDef ty) +       addIdA x (AnnDef ty) -cconsE γ (Tick tt e) t   +cconsE γ (Tick tt e) t   = cconsE (γ `setLoc` tickSrcSpan tt) e t -cconsE γ e@(Cast e' _) t     +cconsE γ e@(Cast e' _) t   = do t' <- castTy γ (exprType e) e'-       addC (SubC γ t' t) ("cconsE Cast" ++ showPpr e) +       addC (SubC γ t' t) ("cconsE Cast" ++ showPpr e)  cconsE γ e t   = do te  <- consE γ e@@ -1292,15 +1327,17 @@        addC (SubC γ te' t) ("cconsE" ++ showPpr e)  -splitConstraints (RRTy [(_, cs)] _ OCons t) +splitConstraints (RRTy cs _ OCons t)   = let (css, t') = splitConstraints t in (cs:css, t')-splitConstraints t                       -  = ([], t) +splitConstraints (RFun x tx@(RApp c _ _ _) t r) | isClass c+  = let (css, t') = splitConstraints t in (css, RFun x tx t' r)+splitConstraints t+  = ([], t) ------------------------------------------------------------------- -- | @instantiatePreds@ peels away the universally quantified @PVars@ --   of a @RType@, generates fresh @Ref@ for them and substitutes them --   in the body.-       + instantiatePreds γ e (RAllP π t)   = do r     <- freshPredRef γ e π        instantiatePreds γ e $ replacePreds "consE" t [(π, r)]@@ -1328,78 +1365,78 @@     where        x' = F.symbol x -cconsLazyLet _ _ _ +cconsLazyLet _ _ _   = errorstar "Constraint.Generate.cconsLazyLet called on invalid inputs"  ------------------------------------------------------------------- -- | Type Synthesis ----------------------------------------------- --------------------------------------------------------------------consE :: CGEnv -> Expr Var -> CG SpecType +consE :: CGEnv -> Expr Var -> CG SpecType ------------------------------------------------------------------- -consE γ (Var x)   +consE γ (Var x)   = do t <- varRefType γ x        addLocA (Just x) (loc γ) (varAnn γ x t)        return t -consE γ (Lit c) +consE γ (Lit c)   = refreshVV $ uRType $ literalFRefType (emb γ) c -consE γ e'@(App e (Type τ)) +consE γ e'@(App e (Type τ))   = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e        t          <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ        addW        $ WfC γ t        t'         <- refreshVV t        instantiatePreds γ e' $ subsTyVar_meet' (α, t') te -consE γ e'@(App e a) | isDictionary a               -  = if isJust tt +consE γ e'@(App e a) | isDictionary a+  = if isJust tt       then return $ fromJust tt       else do ([], πs, ls, te) <- bkUniv <$> consE γ e-              te0              <- instantiatePreds γ e' $ foldr RAllP te πs +              te0              <- instantiatePreds γ e' $ foldr RAllP te πs               te'              <- instantiateStrata ls te0               (γ', te''')      <- dropExists γ te'               te''             <- dropConstraints γ te'''-              updateLocA πs (exprLoc e) te'' +              updateLocA πs (exprLoc e) te''               let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''-              pushConsBind      $ cconsE γ' a tx +              pushConsBind      $ cconsE γ' a tx               addPost γ'        $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a)   where     grepfunname (App x (Type _)) = grepfunname x     grepfunname (Var x)          = x-    grepfunname e                = errorstar $ "grepfunname on \t" ++ showPpr e  -    mdict w                      = case w of -                                     Var x    -> case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing}    +    grepfunname e                = errorstar $ "grepfunname on \t" ++ showPpr e+    mdict w                      = case w of+                                     Var x    -> case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing}                                      Tick _ e -> mdict e-                                     _        -> Nothing    +                                     _        -> Nothing     isDictionary _               = isJust (mdict a)     d = fromJust (mdict a)     dinfo = dlookup (denv γ) d     tt = dhasinfo dinfo $ grepfunname e -consE γ e'@(App e a)               +consE γ e'@(App e a)   = do ([], πs, ls, te) <- bkUniv <$> consE γ e-       te0              <- instantiatePreds γ e' $ foldr RAllP te πs +       te0              <- instantiatePreds γ e' $ foldr RAllP te πs        te'              <- instantiateStrata ls te0        (γ', te''')      <- dropExists γ te'        te''             <- dropConstraints γ te'''-       updateLocA πs (exprLoc e) te'' +       updateLocA πs (exprLoc e) te''        let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''-       pushConsBind      $ cconsE γ' a tx +       pushConsBind      $ cconsE γ' a tx        addPost γ'        $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a) -consE γ (Lam α e) | isTyVar α -  = liftM (RAllT (rTyVar α)) (consE γ e) +consE γ (Lam α e) | isTyVar α+  = liftM (RAllT (rTyVar α)) (consE γ e) -consE γ  e@(Lam x e1) -  = do tx      <- freshTy_type LamE (Var x) τx +consE γ  e@(Lam x e1)+  = do tx      <- freshTy_type LamE (Var x) τx        γ'      <- ((γ, "consE") += (F.symbol x, tx))        t1      <- consE γ' e1-       addIdA x $ AnnDef tx -       addW     $ WfC γ tx +       addIdA x $ AnnDef tx+       addW     $ WfC γ tx        return   $ rFun (F.symbol x) tx t1     where-      FunTy τx _ = exprType e +      FunTy τx _ = exprType e  -- EXISTS-BASED CONSTRAINTS HEREHEREHEREHERE -- Currently suppressed because they break all sorts of invariants,@@ -1407,16 +1444,16 @@ -- consE γ e@(Let b@(NonRec x _) e') --   = do γ'    <- consCBLet γ b --        consElimE γ' [F.symbol x] e'--- --- consE γ (Case e x _ [(ac, ys, ce)]) +--+-- consE γ (Case e x _ [(ac, ys, ce)]) --   = do γ'  <- consCBLet γ (NonRec x e) --        γ'' <- caseEnv γ' x [] ac ys---        consElimE γ'' (F.symbol <$> (x:ys)) ce +--        consElimE γ'' (F.symbol <$> (x:ys)) ce -consE γ e@(Let _ _) +consE γ e@(Let _ _)   = cconsFreshE LetE γ e -consE γ e@(Case _ _ _ _) +consE γ e@(Case _ _ _ _)   = cconsFreshE CaseE γ e  consE γ (Tick tt e)@@ -1425,31 +1462,31 @@        return t     where l = tickSrcSpan tt -consE γ e@(Cast e' _)      +consE γ e@(Cast e' _)   = castTy γ (exprType e) e'  consE _ e@(Coercion _)    = trueTy $ exprType e -consE _ e@(Type t)     -  = errorstar $ "consE cannot handle type" ++ showPpr (e, t) +consE _ e@(Type t)+  = errorstar $ "consE cannot handle type" ++ showPpr (e, t)  castTy _ τ (Var x)-  = do t <- trueTy τ +  = do t <- trueTy τ        return $  t `strengthen` (uTop $ F.uexprReft $ F.expr x)  castTy γ τ e   = do t <- trueTy (exprType e)        cconsE γ e t-       trueTy τ +       trueTy τ -singletonReft = uTop . F.symbolReft . F.symbol +singletonReft = uTop . F.symbolReft . F.symbol --- | @consElimE@ is used to *synthesize* types by **existential elimination** +-- | @consElimE@ is used to *synthesize* types by **existential elimination** --   instead of *checking* via a fresh template. That is, assuming --      γ |- e1 ~> t1 --   we have---      γ |- let x = e1 in e2 ~> Ex x t1 t2 +--      γ |- let x = e1 in e2 ~> Ex x t1 t2 --   where --      γ, x:t1 |- e2 ~> t2 --   instead of the earlier case where we generate a fresh template `t` and check@@ -1469,10 +1506,10 @@        cconsE γ e t        return t -checkUnbound γ e x t -  | x `notElem` (F.syms t) +checkUnbound γ e x t+  | x `notElem` (F.syms t)   = t-  | otherwise              +  | otherwise   = errorstar $ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t                  ++ "\nIn\t"  ++ showPpr e ++ " at " ++ showPpr (loc γ) @@ -1480,16 +1517,14 @@ dropExists γ t            = return (γ, t)  dropConstraints :: CGEnv -> SpecType -> CG SpecType-dropConstraints γ (RRTy [(_, ct)] _ OCons t) -  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ (zip xs ts)+dropConstraints γ (RFun x tx@(RApp c _ _ _) t r) | isClass c+  = (flip (RFun x tx)) r <$> dropConstraints γ t+dropConstraints γ (RRTy cts _ OCons t)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts        addC (SubC  γ' t1 t2)  "dropConstraints"        dropConstraints γ t   where-    trep = toRTypeRep ct-    xs   = init $ ty_binds trep-    ts   = init $ ty_args  trep-    t2   = ty_res   trep-    t1   = last $ ty_args trep+    (xts, t1, t2) = envToSub cts  dropConstraints _ t = return t @@ -1497,7 +1532,7 @@ cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG () ------------------------------------------------------------------------------------- cconsCase γ x t acs (ac, ys, ce)-  = do cγ <- caseEnv γ x acs ac ys +  = do cγ <- caseEnv γ x acs ac ys        cconsE cγ ce t  refreshTy t = refreshVV t >>= refreshArgs@@ -1522,39 +1557,39 @@        rs' <- mapM refreshVVRef rs        liftM (shiftVV (RApp c ts' rs' r)) fresh -refreshVV t           +refreshVV t   = return t  -refreshVVRef (RProp ss t) +refreshVVRef (RProp ss t)   = do xs    <- mapM (\_ -> fresh) (fst <$> ss)        let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs)        liftM (RProp (zip xs (snd <$> ss)) . F.subst su) (refreshVV t) -refreshVVRef (RPropP ss r) +refreshVVRef (RPropP ss r)   = return $ RPropP ss r -refreshVVRef (RHProp _ _) -  = errorstar "TODO: EFFECTS refreshVVRef" +refreshVVRef (RHProp _ _)+  = errorstar "TODO: EFFECTS refreshVVRef"   --------------------------------------------------------------------------------------caseEnv   :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> CG CGEnv +caseEnv   :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> CG CGEnv ------------------------------------------------------------------------------------- caseEnv γ x _   (DataAlt c) ys   = do let (x' : ys')    = F.symbol <$> (x:ys)        xt0              <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x'        tdc              <- γ ??= (dataConSymbol c) >>= refreshVV        let (rtd, yts, _) = unfoldR tdc (shiftVV xt0 x') ys-       let r1            = dataConReft   c   ys' +       let r1            = dataConReft   c   ys'        let r2            = dataConMsReft rtd ys'-       let xt            = xt0 `strengthen` (uTop (r1 `F.meet` r2))+       let xt            = (xt0 `F.meet` rtd) `strengthen` (uTop (r1 `F.meet` r2))        let cbs           = safeZip "cconsCase" (x':ys') (xt0:yts)        cγ'              <- addBinders γ x' cbs        cγ               <- addBinders cγ' x' [(x', xt)]-       return cγ +       return cγ -caseEnv γ x acs a _ +caseEnv γ x acs a _   = do let x'  = F.symbol x        xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x')        cγ     <- addBinders γ x' [(x', xt')]@@ -1566,25 +1601,25 @@ altReft _ _ _            = error "Constraint : altReft"  unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)-  where -        tbody           = instantiatePvs (instantiateTys td ts) $ reverse rs-        (ys0, yts', rt) = safeBkArrow $ instantiateTys tbody tvs'-        yts''           = zipWith F.subst sus (yts'++[rt])-        (t3,yts)        = (last yts'', init yts'')-        sus             = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])-        (αs, ys')       = mapSnd (F.symbol <$>) $ L.partition isTyVar ys-        tvs'            = rVar <$> αs-        tvys            = ofType . varType <$> αs+  where+        tbody              = instantiatePvs (instantiateTys td ts) $ reverse rs+        (ys0, yts', _, rt) = safeBkArrow $ instantiateTys tbody tvs'+        yts''              = zipWith F.subst sus (yts'++[rt])+        (t3,yts)           = (last yts'', init yts'')+        sus                = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])+        (αs, ys')          = mapSnd (F.symbol <$>) $ L.partition isTyVar ys+        tvs'               = rVar <$> αs+        tvys               = ofType . varType <$> αs  unfoldR _  _                _  = error "Constraint.hs : unfoldR"  instantiateTys = foldl' go   where go (RAllT α tbody) t = subsTyVar_meet' (α, t) tbody-        go _ _               = errorstar "Constraint.instanctiateTy" +        go _ _               = errorstar "Constraint.instanctiateTy" -instantiatePvs = foldl' go +instantiatePvs = foldl' go   where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]-        go _ _               = errorstar "Constraint.instanctiatePv" +        go _ _               = errorstar "Constraint.instanctiatePv"  checkTyCon _ t@(RApp _ _ _ _) = t checkTyCon x t                = checkErr x t --errorstar $ showPpr x ++ "type: " ++ showPpr t@@ -1597,13 +1632,13 @@  checkErr (msg, e) t          = errorstar $ msg ++ showPpr e ++ ", type: " ++ showpp t -varAnn γ x t +varAnn γ x t   | x `S.member` recs γ-  = AnnLoc (getSrcSpan' x) -  | otherwise +  = AnnLoc (getSrcSpan' x)+  | otherwise   = AnnUse t -getSrcSpan' x +getSrcSpan' x   | loc == noSrcSpan   = loc   | otherwise@@ -1640,7 +1675,7 @@ varRefType γ x = liftM (varRefType' γ x) (γ ??= F.symbol x)  varRefType' γ x t'-  | Just tys <- trec γ, Just tr <- M.lookup x' tys +  | Just tys <- trec γ, Just tr <- M.lookup x' tys   = tr `strengthen` xr   | otherwise   = t@@ -1657,16 +1692,16 @@  instance NFData CGEnv where   rnf (CGE x1 x2 x3 _ x5 x6 x7 x8 x9 _ _ x10 _ _ _ _ _)-    = x1 `seq` rnf x2 `seq` seq x3 `seq` rnf x5 `seq` +    = x1 `seq` rnf x2 `seq` seq x3 `seq` rnf x5 `seq`       rnf x6  `seq` x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10  instance NFData FEnv where   rnf (FE x1 _) = rnf x1  instance NFData SubC where-  rnf (SubC x1 x2 x3) +  rnf (SubC x1 x2 x3)     = rnf x1 `seq` rnf x2 `seq` rnf x3-  rnf (SubR x1 _ x2) +  rnf (SubR x1 _ x2)     = rnf x1 `seq` rnf x2  instance NFData Class where@@ -1675,71 +1710,75 @@ instance NFData RTyCon where   rnf _ = () -instance NFData Type where +instance NFData Type where   rnf _ = ()  instance NFData WfC where-  rnf (WfC x1 x2)   +  rnf (WfC x1 x2)     = rnf x1 `seq` rnf x2  instance NFData CGInfo where-  rnf x = ({-# SCC "CGIrnf1" #-}  rnf (hsCs x))       `seq` -          ({-# SCC "CGIrnf2" #-}  rnf (hsWfs x))      `seq` -          ({-# SCC "CGIrnf3" #-}  rnf (fixCs x))      `seq` -          ({-# SCC "CGIrnf4" #-}  rnf (fixWfs x))     `seq` +  rnf x = ({-# SCC "CGIrnf1" #-}  rnf (hsCs x))       `seq`+          ({-# SCC "CGIrnf2" #-}  rnf (hsWfs x))      `seq`+          ({-# SCC "CGIrnf3" #-}  rnf (fixCs x))      `seq`+          ({-# SCC "CGIrnf4" #-}  rnf (fixWfs x))     `seq`           ({-# SCC "CGIrnf6" #-}  rnf (freshIndex x)) `seq`           ({-# SCC "CGIrnf7" #-}  rnf (binds x))      `seq`           ({-# SCC "CGIrnf8" #-}  rnf (annotMap x))   `seq`           ({-# SCC "CGIrnf10" #-} rnf (kuts x))       `seq`           ({-# SCC "CGIrnf10" #-} rnf (lits x))       `seq`-          ({-# SCC "CGIrnf10" #-} rnf (kvProf x)) +          ({-# SCC "CGIrnf10" #-} rnf (kvProf x))  ------------------------------------------------------------------------------- --------------------- Reftypes from F.Fixpoint Expressions ---------------------- -------------------------------------------------------------------------------  forallExprRefType     :: CGEnv -> SpecType -> SpecType-forallExprRefType γ t = t `strengthen` (uTop r') -  where r'            = fromMaybe mempty $ forallExprReft γ r -        r             = F.sr_reft $ rTypeSortedReft (emb γ) t+forallExprRefType γ t = t `strengthen` (uTop r')+  where+    r'                = fromMaybe mempty $ forallExprReft γ r+    r                 = F.sr_reft $ rTypeSortedReft (emb γ) t -forallExprReft γ r -  = do e  <- F.isSingletonReft r-       r' <- forallExprReft_ γ e-       return r'+forallExprReft :: CGEnv -> F.Reft -> Maybe F.Reft+forallExprReft γ r = F.isSingletonReft r >>= forallExprReft_ γ -forallExprReft_ γ (F.EApp f es) +--   = do e  <- F.isSingletonReft r+--        r' <- forallExprReft_ γ e+--        return r'++forallExprReft_ :: CGEnv -> F.Expr -> Maybe F.Reft+forallExprReft_ γ (F.EApp f es)   = case forallExprReftLookup γ (val f) of-      Just (xs,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in+      Just (xs,_,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in                        Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t       Nothing       -> Nothing -- F.exprReft e -forallExprReft_ γ (F.EVar x) -  = case forallExprReftLookup γ x of -      Just (_,_,t)  -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t +forallExprReft_ γ (F.EVar x)+  = case forallExprReftLookup γ x of+      Just (_,_,_,t)  -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t       Nothing       -> Nothing -- F.exprReft e -forallExprReft_ _ _ = Nothing -- F.exprReft e +forallExprReft_ _ _ = Nothing -- F.exprReft e  forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)-  where -    snap                 = mapThd3 ignoreOblig . bkArrow . fourth4 . bkUniv . (γ ?=) . F.symbol+  where+    snap                 = mapFourth4 ignoreOblig . bkArrow . fourth4 . bkUniv . (γ ?=) . F.symbol +{- splitExistsCases z xs tx   = fmap $ fmap (exrefAddEq z xs tx) -exrefAddEq z xs t (F.Reft(s, rs))-  = F.Reft(s, [F.RConc (F.POr [ pand x | x <- xs])])-  where tref                = fromMaybe mempty $ stripRTypeBase t-        pand x              = F.PAnd $ (substzx x) (fFromRConc <$> rs)-                                       ++ exrefToPred x tref-        substzx x           = F.subst (F.mkSubst [(z, F.EVar x)])+exrefAddEq z xs t (F.Reft (s, F.Refa rs))+  = F.Reft(s, F.Refa (F.POr [ pand x | x <- xs]))+  where+    tref      = fromMaybe mempty $ stripRTypeBase t+    pand x    = substzx x rs `mappend` exrefToPred x tref+    substzx x = F.subst (F.mkSubst [(z, F.EVar x)]) -exrefToPred x uref-  = F.subst (F.mkSubst [(v, F.EVar x)]) ((fFromRConc <$> r))-  where (F.Reft(v, r))         = ur_reft uref-fFromRConc (F.RConc p) = p-fFromRConc _           = errorstar "can not hanlde existential type with kvars"+exrefToPred x u             = F.subst (F.mkSubst [(v, F.EVar x)]) p+  where+    F.Reft (v, F.Refa p)    = ur_reft u+-}  ------------------------------------------------------------------------------- -------------------- Cleaner Signatures For Rec-bindings ----------------------@@ -1755,23 +1794,23 @@ isType a                        = eqType (exprType a) predType  -exprRefType :: CoreExpr -> SpecType -exprRefType = exprRefType_ M.empty +exprRefType :: CoreExpr -> SpecType+exprRefType = exprRefType_ M.empty -exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType -exprRefType_ γ (Let b e) +exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType+exprRefType_ γ (Let b e)   = exprRefType_ (bindRefType_ γ b) e  exprRefType_ γ (Lam α e) | isTyVar α   = RAllT (rTyVar α) (exprRefType_ γ e) -exprRefType_ γ (Lam x e) +exprRefType_ γ (Lam x e)   = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)  exprRefType_ γ (Tick _ e)   = exprRefType_ γ e -exprRefType_ γ (Var x) +exprRefType_ γ (Var x)   = M.lookupDefault (ofType $ varType x) x γ  exprRefType_ _ e
src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -9,24 +9,55 @@  import Language.Haskell.Liquid.Types hiding     ( binds ) import Language.Fixpoint.Misc                   ( mapSnd )+import Language.Fixpoint.Interface              ( parseFInfo ) +-- import           Control.Applicative ((<$>)) import qualified Data.HashMap.Strict            as M+import           Data.Monoid  import Language.Haskell.Liquid.Qualifier import Language.Haskell.Liquid.RefType          ( rTypeSortedReft ) +cgInfoFInfo :: GhcInfo -> CGInfo -> IO (F.FInfo Cinfo)+cgInfoFInfo info cgi = do+  let tgtFI = targetFInfo info cgi+  impFI    <- parseFInfo $ hqFiles info+  return    $ tgtFI <> impFI -cgInfoFInfo :: GhcInfo -> CGInfo -> F.FInfo Cinfo-cgInfoFInfo info cgi+--   qs    <- ghcQuals info+--   return F.FI { F.cm    = M.fromList $ F.addIds $ fixCs cgi+--               , F.ws    = fixWfs cgi+--               , F.bs    = binds cgi+--               , F.gs    = F.fromListSEnv . map mkSort $ meas spc+--               , F.lits  = lits cgi+--               , F.kuts  = kuts cgi+--               , F.quals = qs }+--    where+--     spc    = spec info+--     tce    = tcEmbeds spc+--     mkSort = mapSnd (rTypeSortedReft tce . val)++targetFInfo :: GhcInfo -> CGInfo -> F.FInfo Cinfo+targetFInfo info cgi   = F.FI { F.cm    = M.fromList $ F.addIds $ fixCs cgi-         , F.ws    = fixWfs cgi  -         , F.bs    = binds cgi +         , F.ws    = fixWfs cgi+         , F.bs    = binds cgi          , F.gs    = F.fromListSEnv . map mkSort $ meas spc-         , F.lits  = lits cgi -         , F.kuts  = kuts cgi -         , F.quals = (qualifiers $ spc) ++ (specificationQualifiers (maxParams (config spc)) info)-         }-   where  -    spc        = spec info-    tce        = tcEmbeds spc -    mkSort     = mapSnd (rTypeSortedReft tce . val)+         , F.lits  = lits cgi+         , F.kuts  = kuts cgi+         , F.quals = targetQuals info }+   where+    spc    = spec info+    tce    = tcEmbeds spc+    mkSort = mapSnd (rTypeSortedReft tce . val)++targetQuals :: GhcInfo -> [F.Qualifier]+targetQuals info = spcQs ++ genQs+  where+    spcQs     = qualifiers spc+    genQs     = specificationQualifiers n info+    n         = maxParams $ config spc+    spc       = spec info+++
src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -52,7 +52,7 @@         } -- deriving (Data, Typeable)  -data LConstraint = LC [SpecType]+data LConstraint = LC [[(F.Symbol, SpecType)]]   instance PPrint CGEnv where
src/Language/Haskell/Liquid/CoreToLogic.hs view
@@ -15,20 +15,21 @@   ) where  import GHC hiding (Located)-import Var+import Var  import Type   import qualified CoreSyn   as C import Literal import IdInfo -import qualified Data.ByteString as B+import Data.Text.Encoding+ import TysWiredIn   import Control.Applicative   import Language.Fixpoint.Misc-import Language.Fixpoint.Names (dropModuleNames, isPrefixOfSym, propConName)+import Language.Fixpoint.Names (dropModuleNames, propConName, isPrefixOfSym) import Language.Fixpoint.Types hiding (Def, R, simplify) import qualified Language.Fixpoint.Types as F import Language.Haskell.Liquid.GhcMisc@@ -38,18 +39,17 @@ import Language.Haskell.Liquid.RefType  - import qualified Data.HashMap.Strict as M  import Data.Monoid   logicType :: (Reftable r) => Type -> RRType r-logicType τ = fromRTypeRep $ t{ty_res = res, ty_binds = binds, ty_args = args}+logicType τ = fromRTypeRep $ t{ty_res = res, ty_binds = binds, ty_args = args, ty_refts = refts}   where      t   = toRTypeRep $ ofType τ      res = mkResType $ ty_res t-    (binds, args) =  unzip $ dropWhile isClassBind $ zip (ty_binds t) (ty_args t)+    (binds, args, refts) = unzip3 $ dropWhile (isClassType.snd3) $ zip3 (ty_binds t) (ty_args t) (ty_refts t)           mkResType t @@ -59,8 +59,6 @@ isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon isBool _ = False -isClassBind   = isClassType . snd- {- strengthenResult type: the refinement depends on whether the result type is a Bool or not:  CASE1: measure f@logic :: X -> Prop <=> f@haskell :: x:X -> {v:Bool | (Prop v) <=> (f@logic x)} @@ -78,13 +76,13 @@     fromRTypeRep $ rep{ty_res = res `strengthen` r', ty_binds = xs}   where rep = toRTypeRep t         res = ty_res rep-        xs  = intSymbol (symbol ("x" :: String)) <$> [1..]+        xs  = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]         r'  = U (exprReft (EApp f (mkA <$> vxs)))         mempty mempty         r   = U (propReft (PBexp $ EApp f (mkA <$> vxs))) mempty mempty-        vxs = dropWhile isClassBind $ zip xs (ty_args rep)+        vxs = dropWhile (isClassType.snd) $ zip xs (ty_args rep)         f   = dummyLoc $ dropModuleNames $ simplesymbol v         t   = (ofType $ varType v) :: SpecType-        mkA = \(x, t) -> if isBool t then EApp (dummyLoc propConName) [(EVar x)] else EVar x+        mkA = \(x, _) -> EVar x -- if isBool t then EApp (dummyLoc propConName) [(EVar x)] else EVar x   simplesymbol = symbol . getName@@ -126,30 +124,38 @@ runToLogic lmap ferror (LM m)    = m $ LState {symbolMap = lmap, mkError = ferror} -coreToDef :: LocSymbol -> Var -> C.CoreExpr ->  LogicM [Def DataCon]-coreToDef x _ e = go $ inline_preds $ simplify e+coreToDef :: Reftable r => LocSymbol -> Var -> C.CoreExpr ->  LogicM [Def (RRType r) DataCon]+coreToDef x _ e = go [] $ inline_preds $ simplify e   where-    go (C.Lam _  e) = go e-    go (C.Tick _ e) = go e-    go (C.Case _ _ t alts) -      | eqType t boolTy = mapM goalt_prop alts-      | otherwise       = mapM goalt      alts-    go _                = throw "Measure Functions should have a case at top level"+    go args (C.Lam  x e) = go (x:args) e+    go args (C.Tick _ e) = go args e+    go args (C.Case _ _ t alts) +      | eqType t boolTy  = mapM (goalt_prop (reverse $ tail args) (head args)) alts+      | otherwise        = mapM (goalt      (reverse $ tail args) (head args)) alts+    go _ _               = throw "Measure Functions should have a case at top level" -    goalt ((C.DataAlt d), xs, e)      = ((Def x d (symbol <$> xs)) . E) <$> coreToLogic e-    goalt alt = throw $ "Bad alternative" ++ showPpr alt+    goalt args dx ((C.DataAlt d), xs, e)      +      = ((Def x (toArgs id args) d (Just $ ofType $ varType dx) (toArgs Just xs)) . E) +        <$> coreToLogic e+    goalt _ _ alt+       = throw $ "Bad alternative" ++ showPpr alt -    goalt_prop ((C.DataAlt d), xs, e) = ((Def x d (symbol <$> xs)) . P) <$> coreToPred  e-    goalt_prop alt = throw $ "Bad alternative" ++ showPpr alt+    goalt_prop args dx ((C.DataAlt d), xs, e) +      = ((Def x (toArgs id args) d (Just $ ofType $ varType dx) (toArgs Just xs)) . P) +        <$> coreToPred  e+    goalt_prop _ _ alt +      = throw $ "Bad alternative" ++ showPpr alt +    toArgs f args = [(symbol x, f $ ofType $ varType x) | x <- args]+     inline_preds = inline (eqType boolTy . varType) -coreToFun :: LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Symbol], Either Pred Expr)+coreToFun :: LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Var], Either Pred Expr) coreToFun _ v e = go [] $ inline_preds $ simplify e   where     go acc (C.Lam x e)  | isTyVar    x = go acc e     go acc (C.Lam x e)  | isErasable x = go acc e-    go acc (C.Lam x e)  = go (symbol x : acc) e+    go acc (C.Lam x e)  = go (x:acc) e     go acc (C.Tick _ e) = go acc e     go acc e            | eqType rty boolTy                          = (reverse acc,) . Left  <$> coreToPred e  @@ -172,6 +178,8 @@   = return PFalse   | x == trueDataConId   = return PTrue+  | eqType boolTy (varType x)+  = return $ PBexp $ EApp (dummyLoc propConName) [(EVar $ symbol x)] coreToPred p@(C.App _ _) = toPredApp p   coreToPred e   = PBexp <$> coreToLogic e  @@ -226,6 +234,8 @@       = POr <$> mapM coreToPred [e1, e2]       | val f == symbol ("&&" :: String)       = PAnd <$> mapM coreToPred [e1, e2]+      | val f == symbol ("==>" :: String)+      = PImp <$> coreToPred e1 <*> coreToPred e2     go f es       | val f == symbol ("or" :: String)       = POr <$> mapM coreToPred es@@ -286,6 +296,7 @@     go (C.App f e) = (f', e:es) where (f', es) = go f     go f           = (f, []) +tosymbol (C.Var c) | isDataConId  c = return $ dummyLoc $ symbol c  tosymbol (C.Var x) = return $ dummyLoc $ simpleSymbolVar x tosymbol  e        = throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied") @@ -308,15 +319,7 @@  mkI                    = Just . ECon . I   mkR                    = Just . ECon . F.R . fromRational-mkS s                  = Just (ELit  (dummyLoc $ symbol s) stringSort)---stringSort = rTypeSort M.empty (ofType stringTy :: RSort)--- stringSort = rTypeSort M.empty (ofType stringTy :: RSort)---instance Symbolic B.ByteString where-  symbol x = symbol $ init $ tail $ show x+mkS                    = Just . ESym . SL  . decodeUtf8  ignoreVar i = simpleSymbolVar i `elem` ["I#"] @@ -324,9 +327,9 @@ simpleSymbolVar  = dropModuleNames . symbol . showPpr . getName simpleSymbolVar' = symbol . showPpr . getName -isErasable v   = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v)+isErasable v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v) -isDead = isDeadOcc . occInfo . idInfo+isDead     = isDeadOcc . occInfo . idInfo  class Simplify a where   simplify :: a -> a @@ -347,12 +350,18 @@     = C.App (simplify e1) (simplify e2)   simplify (C.Lam x e) | isTyVar x      = simplify e+  simplify (C.Lam x e) | isErasable x +    = simplify e   simplify (C.Lam x e)      = C.Lam x (simplify e)+  simplify (C.Let (C.NonRec x _) e) | isErasable x+    = simplify e +  simplify (C.Let (C.Rec xes) e)    | all (isErasable . fst) xes+    = simplify e    simplify (C.Let xes e)      = C.Let (simplify xes) (simplify e)   simplify (C.Case e x t alts) -    = C.Case (simplify e) x t (simplify <$> alts)+    = C.Case (simplify e) x t (filter (not . isUndefined) (simplify <$> alts))   simplify (C.Cast e _)         = simplify e   simplify (C.Tick _ e) @@ -374,6 +383,15 @@   inline _ (C.Lit l)           = C.Lit l   inline _ (C.Coercion c)      = C.Coercion c   inline _ (C.Type t)          = C.Type t++isUndefined (_, _, e) = isUndefinedExpr e+  where +   -- auto generated undefined case: (\_ -> (patError @type "error message")) void+   isUndefinedExpr (C.App (C.Var x) _) | (show x) `elem` perrors = True+   -- otherwise +   isUndefinedExpr _ = False ++   perrors = ["Control.Exception.Base.patError"]   instance Simplify C.CoreBind where
src/Language/Haskell/Liquid/DiffCheck.hs view
@@ -1,69 +1,75 @@--- | This module contains the code for Incremental checking, which finds the ---   part of a target file (the subset of the @[CoreBind]@ that have been +-- | This module contains the code for Incremental checking, which finds the+--   part of a target file (the subset of the @[CoreBind]@ that have been --   modified since it was last checked, as determined by a diff against---   a saved version of the file. +--   a saved version of the file. -{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}  module Language.Haskell.Liquid.DiffCheck (-  +    -- * Changed binders + Unchanged Errors      DiffCheck (..)-   -   -- * Use previously saved info to generate DiffCheck target ++   -- * Use previously saved info to generate DiffCheck target    , slice -   -- * Use target binders to generate DiffCheck target +   -- * Use target binders to generate DiffCheck target    , thin-   -   -- * Save current information for next time ++   -- * Save current information for next time    , saveResult -   ) +   )    where +-- import            Debug.Trace (trace) import            Control.Applicative          ((<$>), (<*>))-import            Data.Aeson                   +import            Data.Aeson import qualified  Data.Text as T import            Data.Algorithm.Diff import            Data.Monoid                   (mempty) import            Data.Maybe                    (listToMaybe, mapMaybe, fromMaybe) import            Data.Hashable-import qualified  Data.IntervalMap.FingerTree as IM -import            CoreSyn                      +import qualified  Data.IntervalMap.FingerTree as IM+import            CoreSyn import            Name-import            SrcLoc  -import            Var -import qualified  Data.HashSet                  as S    -import qualified  Data.HashMap.Strict           as M    +import            SrcLoc hiding (Located)+import            Var+import qualified  Data.HashSet                  as S+import qualified  Data.HashMap.Strict           as M import qualified  Data.List                     as L import            System.Directory                (copyFile, doesFileExist)-import            Language.Fixpoint.Types         (FixResult (..))+import            Language.Fixpoint.Misc          (mkGraph)+import            Language.Fixpoint.Types         (FixResult (..), Located (..)) import            Language.Fixpoint.Files-import            Language.Haskell.Liquid.Types   (AnnInfo (..), Error, TError (..), Output (..))+import            Language.Haskell.Liquid.Types   (SpecType, GhcSpec (..), AnnInfo (..), DataConP (..), Error, TError (..), Output (..)) import            Language.Haskell.Liquid.GhcMisc import            Language.Haskell.Liquid.Visitors import            Language.Haskell.Liquid.Errors   () import            Text.Parsec.Pos                  (sourceName, sourceLine, sourceColumn, SourcePos, newPos) import            Text.PrettyPrint.HughesPJ        (text, render, Doc) + import qualified  Data.ByteString               as B import qualified  Data.ByteString.Lazy          as LB + ------------------------------------------------------------------------- -- Data Types ----------------------------------------------------------- -------------------------------------------------------------------------  -- | Main type of value returned for diff-check.-data DiffCheck = DC { newBinds  :: [CoreBind] +data DiffCheck = DC { newBinds  :: [CoreBind]                     , oldOutput :: !(Output Doc)+                    , newSpec   :: !GhcSpec                     } +-- | Variable definitions data Def  = D { start  :: Int -- ^ line at which binder definition starts               , end    :: Int -- ^ line at which binder definition ends               , binder :: Var -- ^ name of binder-              } +              }             deriving (Eq, Ord)  -- | Variable dependencies "call-graph"@@ -75,96 +81,180 @@ -- | Intervals of line numbers that have been re-checked type ChkItv = IM.IntervalMap Int () --instance Show Def where +instance Show Def where   show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j   --- | `slice` returns a subset of the @[CoreBind]@ of the input `target` ---    file which correspond to top-level binders whose code has changed +-------------------------------------------------------------------------+-- | `slice` returns a subset of the @[CoreBind]@ of the input `target`+--    file which correspond to top-level binders whose code has changed --    and their transitive dependencies. --------------------------------------------------------------------------slice :: FilePath -> [CoreBind] -> IO (Maybe DiffCheck)+slice :: FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck) --------------------------------------------------------------------------slice target cbs = ifM (doesFileExist saved) (Just <$> dc) (return Nothing)-  where -    saved        = extFileName Saved target-    dc           = sliceSaved target saved cbs +slice target cbs sp = ifM (doesFileExist saved) dc (return Nothing)+  where+    saved           = extFileName Saved target+    dc              = sliceSaved target saved cbs sp -sliceSaved :: FilePath -> FilePath -> [CoreBind] -> IO DiffCheck-sliceSaved target saved cbs +sliceSaved :: FilePath -> FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck)+sliceSaved target saved cbs sp   = do (is, lm) <- lineDiff target saved        res      <- loadResult target-       return    $ sliceSaved' is lm (DC cbs res) +       return    $ sliceSaved' is lm (DC cbs res sp) -sliceSaved'          :: [Int] -> LMap -> DiffCheck -> DiffCheck-sliceSaved' is lm dc = DC cbs' res'+sliceSaved' :: [Int] -> LMap -> DiffCheck -> Maybe DiffCheck+sliceSaved' is lm (DC cbs res sp)+  | globalDiff is sp = Nothing+  | otherwise        = Just $ DC cbs' res' sp'   where-    cbs'             = thin cbs $ diffVars is dfs+    cbs'             = thinWith sigs cbs $ diffVars is dfs+    sigs             = S.fromList $ M.keys sigm+    sigm             = sigVars is sp     res'             = adjustOutput lm cm res     cm               = checkedItv chDfs-    dfs              = coreDefs cbs+    dfs              = coreDefs cbs ++ specDefs sp     chDfs            = coreDefs cbs'-    DC cbs res       = dc+    sp'              = assumeSpec sigm sp +-- Add the specified signatures for vars-with-preserved-sigs,+-- whose bodies have been pruned from [CoreBind] into the "assumes"+assumeSpec :: M.HashMap Var (Located SpecType) -> GhcSpec -> GhcSpec+assumeSpec sigm sp = sp { asmSigs = M.toList $ M.union sigm assm }+  where+    assm           = M.fromList $ asmSigs sp+    -- sigm'       = trace ("INCCHECK: sigm = " ++ show zs) sigm+    -- zs          = M.keys sigm++diffVars :: [Int] -> [Def] -> [Var]+diffVars ls defs'    = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $+                       go (L.sort ls) defs+  where+    defs             = L.sort defs'+    go _      []     = []+    go []     _      = []+    go (i:is) (d:ds)+      | i < start d  = go is (d:ds)+      | i > end d    = go (i:is) ds+      | otherwise    = binder d : go (i:is) ds++sigVars :: [Int] -> GhcSpec -> M.HashMap Var (Located SpecType)+sigVars ls sp = M.fromList $ filter (ok . snd) $ specSigs sp+  where+    ok        = not . isDiff ls++globalDiff :: [Int] -> GhcSpec -> Bool+globalDiff ls sp = measDiff || invsDiff || dconsDiff+  where+    measDiff  = any (isDiff ls) (snd  <$> meas sp)+    invsDiff  = any (isDiff ls) (invariants   sp)+    dconsDiff = any (isDiff ls) (dloc . snd <$> dconsP sp)+    dloc dc   = Loc (dc_loc dc) (dc_locE dc) ()++isDiff :: [Int] -> Located a -> Bool+isDiff ls x = any hits ls+  where+    hits i  = line x <= i && i <= lineE x++------------------------------------------------------------------------- -- | @thin@ returns a subset of the @[CoreBind]@ given which correspond --   to those binders that depend on any of the @Var@s provided. --------------------------------------------------------------------------thin :: [CoreBind] -> [Var] -> [CoreBind] +thin :: [CoreBind] -> [Var] -> [CoreBind] --------------------------------------------------------------------------thin cbs xs = filterBinds cbs ys +thin = thinWith S.empty++thinWith :: S.HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]+thinWith sigs cbs xs = filterBinds cbs ys   where-    ys      = dependentVars (coreDeps cbs) $ S.fromList xs+    ys               = txClosure (coreDeps cbs) sigs (S.fromList xs) +coreDeps    :: [CoreBind] -> Deps+coreDeps bs = mkGraph $ calls ++ calls'+  where+    calls   = concatMap deps bs+    calls'  = [(y, x) | (x, y) <- calls]+    deps b  = [(x, y) | x <- bindersOf b+                      , y <- freeVars S.empty b] +++txClosure :: Deps -> S.HashSet Var -> S.HashSet Var -> S.HashSet Var+txClosure d sigs xs = -- tracePpr "INCCHECK: tx changed vars" $+                      go S.empty -- $+                      -- tracePpr "INCCHECK: seed changed vars" $+                      xs+  where+    next           = S.unions . fmap deps . S.toList+    deps x         = M.lookupDefault S.empty x d+    go seen new+      | S.null new = seen+      | otherwise  = let seen' = S.union seen new+                         new'  = next new `S.difference` seen'+                         new'' = new'  `S.difference` sigs+                     in go seen' new''+++ ------------------------------------------------------------------------- filterBinds        :: [CoreBind] -> S.HashSet Var -> [CoreBind] ------------------------------------------------------------------------- filterBinds cbs ys = filter f cbs-  where -    f (NonRec x _) = x `S.member` ys -    f (Rec xes)    = any (`S.member` ys) $ fst <$> xes +  where+    f (NonRec x _) = x `S.member` ys+    f (Rec xes)    = any (`S.member` ys) $ fst <$> xes   -------------------------------------------------------------------------+specDefs :: GhcSpec -> [Def]+-------------------------------------------------------------------------+specDefs       = map def . specSigs+  where+    def (x, t) = D (line t) (lineE t) x++specSigs :: GhcSpec -> [(Var, Located SpecType)]+specSigs sp = tySigs sp ++ asmSigs sp ++ ctors sp++------------------------------------------------------------------------- coreDefs     :: [CoreBind] -> [Def] ------------------------------------------------------------------------- coreDefs cbs = L.sort [D l l' x | b <- cbs                                 , x <- bindersOf b                                 , isGoodSrcSpan (getSrcSpan x)                                 , (l, l') <- coreDef b]-coreDef b    = meetSpans b eSp vSp -  where -    eSp      = lineSpan b $ catSpans b $ bindSpans b +coreDef b    = meetSpans b eSp vSp+  where+    eSp      = lineSpan b $ catSpans b $ bindSpans b     vSp      = lineSpan b $ catSpans b $ getSrcSpan <$> bindersOf b-     --- | `meetSpans` cuts off the start-line to be no less than the line at which ++-------------------------------------------------------------------------+-- | `meetSpans` cuts off the start-line to be no less than the line at which --   the binder is defined. Without this, i.e. if we ONLY use the ticks and---   spans appearing inside the definition of the binder (i.e. just `eSp`) +--   spans appearing inside the definition of the binder (i.e. just `eSp`) --   then the generated span can be WAY before the actual definition binder, --   possibly due to GHC INLINE pragmas or dictionaries OR ...---   for an example: see the "INCCHECK: Def" generated by +--   for an example: see the "INCCHECK: Def" generated by --      liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs --   where `spanEnd` is a single line function around 1092 but where---   the generated span starts mysteriously at 222 where Data.List is imported. +--   the generated span starts mysteriously at 222 where Data.List is imported. -meetSpans _ Nothing       _ +meetSpans _ Nothing       _   = []-meetSpans _ (Just (l,l')) Nothing +meetSpans _ (Just (l,l')) Nothing   = [(l, l')]-meetSpans _ (Just (l,l')) (Just (m,_)) +meetSpans _ (Just (l,l')) (Just (m,_))   = [(max l m, l')]  lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp)-lineSpan _ _                = Nothing +lineSpan _ _                = Nothing -catSpans b []             = error $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b-catSpans b xs             = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z]+catSpans b []               = error $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b+catSpans b xs               = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z]  bindFile (NonRec x _) = varFile x-bindFile (Rec xes)    = varFile $ fst $ head xes +bindFile (Rec xes)    = varFile $ fst $ head xes  varFile b = case getSrcSpan b of               RealSrcSpan z -> srcSpanFile z@@ -173,7 +263,7 @@  bindSpans (NonRec x e)    = getSrcSpan x : exprSpans e bindSpans (Rec    xes)    = map getSrcSpan xs ++ concatMap exprSpans es-  where +  where     (xs, es)              = unzip xes  exprSpans (Tick t e)@@ -181,14 +271,14 @@   | otherwise             = [sp]   where     sp                    = tickSrcSpan t-    + exprSpans (Var x)         = [getSrcSpan x]-exprSpans (Lam x e)       = getSrcSpan x : exprSpans e -exprSpans (App e a)       = exprSpans e ++ exprSpans a +exprSpans (Lam x e)       = getSrcSpan x : exprSpans e+exprSpans (App e a)       = exprSpans e ++ exprSpans a exprSpans (Let b e)       = bindSpans b ++ exprSpans e exprSpans (Cast e _)      = exprSpans e-exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs -exprSpans _               = [] +exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs+exprSpans _               = []  altSpans (_, xs, e)       = map getSrcSpan xs ++ exprSpans e @@ -196,59 +286,22 @@ isJunkSpan _               = True  --------------------------------------------------------------------------coreDeps  :: [CoreBind] -> Deps---------------------------------------------------------------------------coreDeps  = M.fromList . concatMap bindDep --bindDep b = [(x, ys) | x <- bindersOf b]-  where -    ys    = S.fromList $ freeVars S.empty b----------------------------------------------------------------------------dependentVars :: Deps -> S.HashSet Var -> S.HashSet Var---------------------------------------------------------------------------dependentVars d    = {- tracePpr "INCCHECK: tx changed vars" $ -} -                     go S.empty {- tracePpr "INCCHECK: seed changed vars" -} -  where -    pre            = S.unions . fmap deps . S.toList-    deps x         = M.lookupDefault S.empty x d-    go seen new -      | S.null new = seen-      | otherwise  = let seen' = S.union seen new-                         new'  = pre new `S.difference` seen'-                     in go seen' new'----------------------------------------------------------------------------diffVars :: [Int] -> [Def] -> [Var]---------------------------------------------------------------------------diffVars lines defs' = -- tracePpr ("INCCHECK: diffVars lines = " ++ show lines ++ " defs= " ++ show defs) $  -                       go (L.sort lines) defs-  where -    defs             = L.sort defs'-    go _      []     = []-    go []     _      = []-    go (i:is) (d:ds) -      | i < start d  = go is (d:ds)-      | i > end d    = go (i:is) ds-      | otherwise    = binder d : go (i:is) ds ------------------------------------------------------------------------------ Diff Interface -------------------------------------------------------+-- | Diff Interface ----------------------------------------------------- -------------------------------------------------------------------------  --- | `lineDiff new old` compares the contents of `src` with `dst` ---   and returns the lines of `src` that are different. +-- | `lineDiff new old` compares the contents of `src` with `dst`+--   and returns the lines of `src` that are different. ------------------------------------------------------------------------- lineDiff :: FilePath -> FilePath -> IO ([Int], LMap) --------------------------------------------------------------------------lineDiff new old  = lineDiff' <$> getLines new <*> getLines old +lineDiff new old  = lineDiff' <$> getLines new <*> getLines old   where     getLines      = fmap lines . readFile  lineDiff'         :: [String] -> [String] -> ([Int], LMap) lineDiff' new old = (ns, lm)-  where +  where     ns            = diffLines 1 diff     lm            = foldr setShift IM.empty $ diffShifts diff     diff          = fmap length <$> getGroupedDiff new old@@ -256,10 +309,10 @@ diffLines _ []                  = [] diffLines n (Both i _ : d)      = diffLines n' d                         where n' = n + i -- length ls diffLines n (First i : d)       = [n .. (n' - 1)] ++ diffLines n' d      where n' = n + i -- length ls-diffLines n (Second _ : d)      = diffLines n d +diffLines n (Second _ : d)      = diffLines n d  diffShifts                      :: [Diff Int] -> [(Int, Int, Int)]-diffShifts                      = go 1 1  +diffShifts                      = go 1 1   where     go old new (Both n _ : d)   = (old, old + n - 1, new - old) : go (old + n) (new + n) d     go old new (Second n : d)   = go (old + n) new d@@ -271,14 +324,14 @@   fmap f (Second x) = Second (f x)   fmap f (Both x y) = Both (f x) (f y) --- | @save@ creates an .saved version of the @target@ file, which will be +-- | @save@ creates an .saved version of the @target@ file, which will be --    used to find what has changed the /next time/ @target@ is checked. ------------------------------------------------------------------------- saveResult :: FilePath -> Output Doc -> IO () --------------------------------------------------------------------------saveResult target res +saveResult target res   = do copyFile target saveF-       B.writeFile errF $ LB.toStrict $ encode res +       B.writeFile errF $ LB.toStrict $ encode res     where        saveF = extFileName Saved  target        errF  = extFileName Cache  target@@ -286,57 +339,59 @@ ------------------------------------------------------------------------- loadResult   :: FilePath -> IO (Output Doc) --------------------------------------------------------------------------loadResult f = ifM (doesFileExist jsonF) out (return mempty)  +loadResult f = ifM (doesFileExist jsonF) out (return mempty)   where     jsonF    = extFileName Cache f     out      = (fromMaybe mempty . decode . LB.fromStrict) <$> B.readFile jsonF  --------------------------------------------------------------------------adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc +adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc ------------------------------------------------------------------------- adjustOutput lm cm o  = mempty { o_types  = adjustTypes  lm cm (o_types  o) }                                { o_result = adjustResult lm cm (o_result o) }  adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a-adjustTypes lm cm (AI m)          = AI $ M.fromList +adjustTypes lm cm (AI m)          = AI $ M.fromList                                     [(sp', v) | (sp, v)  <- M.toList m                                               , Just sp' <- [adjustSrcSpan lm cm sp]] -adjustResult :: LMap -> ChkItv -> FixResult Error -> FixResult Error +adjustResult :: LMap -> ChkItv -> FixResult Error -> FixResult Error adjustResult lm cm (Unsafe es)    = errorsResult Unsafe      $ adjustErrors lm cm es adjustResult lm cm (Crash es z)   = errorsResult (`Crash` z) $ adjustErrors lm cm es adjustResult _  _  r              = r +errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b errorsResult _ []                 = Safe errorsResult f es                 = f es +adjustErrors :: LMap -> ChkItv -> [TError a] -> [TError a] adjustErrors lm cm                = mapMaybe adjustError-  where -    adjustError (ErrSaved sp msg) =  (`ErrSaved` msg) <$> adjustSrcSpan lm cm sp -    adjustError e                 = Just e +  where+    adjustError (ErrSaved sp m)   =  (`ErrSaved` m) <$> adjustSrcSpan lm cm sp+    adjustError e                 = Just e  ------------------------------------------------------------------------- adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan --------------------------------------------------------------------------adjustSrcSpan lm cm sp +adjustSrcSpan lm cm sp   = do sp' <- adjustSpan lm sp-       if isCheckedSpan cm sp' -         then Nothing +       if isCheckedSpan cm sp'+         then Nothing          else Just sp'  isCheckedSpan cm (RealSrcSpan sp) = isCheckedRealSpan cm sp isCheckedSpan _  _                = False-isCheckedRealSpan cm              = not . null . (`IM.search` cm) . srcSpanStartLine  +isCheckedRealSpan cm              = not . null . (`IM.search` cm) . srcSpanStartLine -adjustSpan lm (RealSrcSpan rsp)   = RealSrcSpan <$> adjustReal lm rsp -adjustSpan _  sp                  = Just sp +adjustSpan lm (RealSrcSpan rsp)   = RealSrcSpan <$> adjustReal lm rsp+adjustSpan _  sp                  = Just sp adjustReal lm rsp   | Just δ <- getShift l1 lm      = Just $ realSrcSpan f (l1 + δ) c1 (l2 + δ) c2   | otherwise                     = Nothing   where-    (f, l1, c1, l2, c2)           = unpackRealSrcSpan rsp -  +    (f, l1, c1, l2, c2)           = unpackRealSrcSpan rsp + -- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@ -- in the diff and returns @Nothing@ otherwise. getShift     :: Int -> LMap -> Maybe Int@@ -348,7 +403,7 @@   checkedItv :: [Def] -> ChkItv-checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is +checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is   where     is            = [IM.Interval l1 l2 | D l1 l2 _ <- chDefs] @@ -370,9 +425,9 @@                c    = sourceColumn p  instance FromJSON SourcePos where-  parseJSON (Object v) = newPos <$> v .: "sourceName"   -                                <*> v .: "sourceLine"   -                                <*> v .: "sourceColumn"  +  parseJSON (Object v) = newPos <$> v .: "sourceName"+                                <*> v .: "sourceLine"+                                <*> v .: "sourceColumn"   parseJSON _          = mempty  @@ -380,7 +435,7 @@ instance FromJSON (FixResult Error)  instance ToJSON Doc where-  toJSON = String . T.pack . render +  toJSON = String . T.pack . render  instance FromJSON Doc where   parseJSON (String s) = return $ text $ T.unpack s@@ -398,4 +453,10 @@ instance ToJSON (Output Doc) instance FromJSON (Output Doc) ++line :: Located a -> Int+line  = sourceLine . loc++lineE :: Located a -> Int+lineE = sourceLine . locE
src/Language/Haskell/Liquid/Errors.hs view
@@ -118,15 +118,11 @@   pprintTidy k = ppError k . fmap ppSpecTypeErr   ppSpecTypeErr   :: SpecType -> Doc-ppSpecTypeErr t -  | isTrivial t = dt-  | otherwise   = dt <+> dr -    where-      dt        = rtypeDoc Lossy t'-      dr        = maybe empty ((text "|" <+>) . pprint . everywhere (mkT noCasts)) ro -      (t', ro)  = stripRType t-      noCasts (ECst x _) = x-      noCasts e          = e+ppSpecTypeErr+  = rtypeDoc Lossy . tidySpecType Lossy . fmap (everywhere (mkT noCasts))+  where+    noCasts (ECst x _) = x+    noCasts e          = e  -- full = isNontrivialVV $ rTypeValueVar t =  @@ -137,7 +133,7 @@ instance Exception [Error]  -------------------------------------------------------------------------ppError :: (PPrint a) => Tidy -> TError a -> Doc+ppError :: (PPrint a, Show a) => Tidy -> TError a -> Doc ------------------------------------------------------------------------  ppError k e  = ppError' k (pprintE $ errSpan e) e@@ -149,7 +145,7 @@ blankLine    = sizedText 5 " "  -------------------------------------------------------------------------ppError' :: (PPrint a) => Tidy -> Doc -> TError a -> Doc+ppError' :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc -----------------------------------------------------------------------  ppError' _ dSp (ErrAssType _ OCons _ _)@@ -174,6 +170,16 @@               , nests 2 [ text "In Context"                         , pprint c                 ]] +ppError' _  dSp (ErrFCrash _ _ c tA tE)+  = dSp <+> text "Fixpoint Crash on Constraint"+        $+$ sepVcat blankLine+              [ nests 2 [ text "Inferred type" +                        , text "VV :" <+> pprint tA]+              , nests 2 [ text "Required type" +                        , text "VV :" <+> pprint tE]+              , nests 2 [ text "Context"+                        , pprint c                 ]]+ ppError' _ dSp (ErrParse _ _ e)   = dSp <+> text "Cannot parse specification:"     $+$ (nest 4 $ pprint e)@@ -291,3 +297,4 @@  errSaved :: SrcSpan -> String -> Error errSaved x = ErrSaved x . text+
src/Language/Haskell/Liquid/Fresh.hs view
@@ -26,14 +26,16 @@   fresh = tempSymbol "x" <$> fresh  instance Freshable m Integer => Freshable m Refa where-  fresh = ((`RKvar` mkSubst []) . intKvar) <$> fresh+  fresh  = kv <$> fresh+    where+      kv = Refa . (`PKVar` mempty) . intKvar  instance Freshable m Integer => Freshable m [Refa] where   fresh = single <$> fresh  instance Freshable m Integer => Freshable m Reft where   fresh                = errorstar "fresh Reft"-  true    (Reft (v,_)) = return $ Reft (v, [])+  true    (Reft (v,_)) = return $ Reft (v, mempty)   refresh (Reft (_,_)) = (Reft .) . (,) <$> freshVV <*> fresh     where       freshVV          = vv . Just <$> fresh@@ -85,6 +87,9 @@        tx' <- true tx        return $ RAllE y' ty' (tx' `subst1` (y, EVar y'))  +trueRefType (RRTy e o r t)+  = RRTy e o r <$> trueRefType t + trueRefType t    = return t @@ -122,6 +127,9 @@        ty' <- refresh ty        tx' <- refresh tx        return $ RAllE y' ty' (tx' `subst1` (y, EVar y')) ++refreshRefType (RRTy e o r t)+  = RRTy e o r <$> refreshRefType t   refreshRefType t   = return t
src/Language/Haskell/Liquid/GhcInterface.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-} +{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE TupleSections             #-}-{-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE ScopedTypeVariables       #-}  module Language.Haskell.Liquid.GhcInterface (-  +   -- * extract all information needed for verification     getGhcInfo @@ -25,7 +24,7 @@ import Var import CoreMonad    (liftIO) import DataCon-import Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc) +import Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc) import qualified Control.Exception as Ex  import GHC.Paths (libdir)@@ -38,10 +37,10 @@ import Data.List (find, nub) import Data.Maybe (catMaybes, maybeToList) import qualified Data.HashSet        as S-  + import System.Console.CmdArgs.Verbosity (whenLoud) import System.Directory (removeFile, createDirectory, doesFileExist)-import Language.Fixpoint.Types hiding (Expr) +import Language.Fixpoint.Types hiding (Result, Expr) import Language.Fixpoint.Misc  import Language.Haskell.Liquid.Types@@ -65,11 +64,11 @@ -------------------------------------------------------------------- getGhcInfo :: Config -> FilePath -> IO (Either ErrorResult GhcInfo) ---------------------------------------------------------------------getGhcInfo cfg target = (Right <$> getGhcInfo' cfg target) +getGhcInfo cfg target = (Right <$> getGhcInfo' cfg target)                           `Ex.catch` (\(e :: SourceError) -> handle e)                           `Ex.catch` (\(e :: Error)       -> handle e)                           `Ex.catch` (\(e :: [Error])     -> handle e)-  where +  where     handle            = return . Left . result  @@ -98,19 +97,19 @@                             | tc <- mgi_tcs modguts                             , dc <- tyConDataCons tc                             ]-      let impVs           = importVars  coreBinds -      let defVs           = definedVars coreBinds +      let impVs           = importVars  coreBinds+      let defVs           = definedVars coreBinds       let useVs           = readVars    coreBinds       let letVs           = letVars     coreBinds       let derVs           = derivedVars coreBinds $ mgi_is_dfun modguts-      logicmap           <- liftIO makeLogicMap +      logicmap           <- liftIO makeLogicMap       (spec, imps, incs) <- moduleSpec cfg coreBinds (impVs ++ defVs) letVs name' modguts tgtSpec logicmap impSpecs'       liftIO              $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps       hqualFiles         <- moduleHquals modguts paths target imps incs-      return              $ GI hscEnv coreBinds derVs impVs (letVs ++ datacons) useVs hqualFiles imps incs spec +      return              $ GI hscEnv coreBinds derVs impVs (letVs ++ datacons) useVs hqualFiles imps incs spec  -makeLogicMap +makeLogicMap   = do lg    <- getCoreToLogicPath        lspec <- readFile lg        return $ parseSymbolToLogic lg lspec@@ -123,7 +122,7 @@ derivedVs cbs fd = concatMap bindersOf cbf ++ deps   where cbf            = filter f cbs -        f (NonRec x _) = eqFd x +        f (NonRec x _) = eqFd x         f (Rec xes   ) = any eqFd (fst <$> xes)         eqFd x         = varName x == varName fd         deps :: [Id]@@ -170,10 +169,10 @@  mgi_namestring = moduleNameString . moduleName . mgi_module -importVars            = freeVars S.empty +importVars            = freeVars S.empty -definedVars           = concatMap defs -  where +definedVars           = concatMap defs+  where     defs (NonRec x _) = [x]     defs (Rec xes)    = map fst xes @@ -189,17 +188,17 @@        -- mod_guts <- modSummaryModGuts modSummary        mod_p    <- parseModule modSummary        mod_guts <- coreModule <$> (desugarModuleWithLoc =<< typecheckModule (ignoreInline mod_p))-       let deriv = getDerivedDictionaries mod_guts +       let deriv = getDerivedDictionaries mod_guts        return   $! (miModGuts (Just deriv) mod_guts)      Nothing     -> exitWithPanic "Ghc Interface: Unable to get GhcModGuts"  getDerivedDictionaries cm = is_dfun <$> (instEnvElts $ mg_inst_env cm)  cleanFiles :: FilePath -> IO ()-cleanFiles fn +cleanFiles fn   = do forM_ bins (tryIgnore "delete binaries" . removeFileIfExists)-       tryIgnore "create temp directory" $ createDirectory dir -    where +       tryIgnore "create temp directory" $ createDirectory dir+    where        bins = replaceExtension fn <$> ["hi", "o"]        dir  = tempDirectory fn @@ -212,7 +211,7 @@  desugarModuleWithLoc :: TypecheckedModule -> Ghc DesugaredModule desugarModuleWithLoc tcm = do-  let ms = pm_mod_summary $ tm_parsed_module tcm +  let ms = pm_mod_summary $ tm_parsed_module tcm   -- let ms = modSummary tcm   let (tcg, _) = tm_internals_ tcm   hsc_env <- getSession@@ -224,18 +223,18 @@ -- | Extracting Qualifiers ----------------------------------------------------- -------------------------------------------------------------------------------- -moduleHquals mg paths target imps incs -  = do hqs   <- specIncludes Hquals paths incs +moduleHquals mg paths target imps incs+  = do hqs   <- specIncludes Hquals paths incs        hqs'  <- moduleImports [Hquals] paths (mgi_namestring mg : imps)        hqs'' <- liftIO   $ filterM doesFileExist [extFileName Hquals target]        let rv = sortNub  $ hqs'' ++ hqs ++ (snd <$> hqs')-       liftIO $ whenLoud $ putStrLn $ "Reading Qualifiers From: " ++ show rv +       liftIO $ whenLoud $ putStrLn $ "Reading Qualifiers From: " ++ show rv        return rv  -------------------------------------------------------------------------------- -- | Extracting Specifications (Measures + Assumptions) ------------------------ --------------------------------------------------------------------------------- + moduleSpec cfg cbs vars defVars target mg tgtSpec logicmap impSpecs   = do addImports  impSpecs        addContext  $ IIModule $ moduleName $ mgi_module mg@@ -261,14 +260,14 @@ notRealSpecName = "NotReal"  getSpecs rflag tflag target paths names exts-  = do fs'     <- sortNub <$> moduleImports exts paths names +  = do fs'     <- sortNub <$> moduleImports exts paths names        patSpec <- getPatSpec paths tflag        rlSpec  <- getRealSpec paths rflag        let fs  = patSpec ++ rlSpec ++ fs'        liftIO  $ whenLoud $ putStrLn ("getSpecs: " ++ show fs)        transParseSpecs exts paths (S.singleton target) mempty (map snd fs) -getPatSpec paths totalitycheck +getPatSpec paths totalitycheck   | totalitycheck   = (map (patErrorName, )) . maybeToList <$> moduleFile paths patErrorName Spec   | otherwise@@ -321,18 +320,18 @@   = liftIO $ getFileInDirs (extModuleName name ext) paths  specIncludes :: GhcMonad m => Ext -> [FilePath] -> [FilePath] -> m [FilePath]-specIncludes ext paths reqs +specIncludes ext paths reqs   = do let libFile  = extFileNameR ext $ symbolString preludeName-       let incFiles = catMaybes $ reqFile ext <$> reqs +       let incFiles = catMaybes $ reqFile ext <$> reqs        liftIO $ forM (libFile : incFiles) $ \f -> do          mfile <- getFileInDirs f paths          case mfile of            Just file -> return file            Nothing -> errorstar $ "cannot find " ++ f ++ " in " ++ show paths -reqFile ext s -  | isExtFile ext s -  = Just s +reqFile ext s+  | isExtFile ext s+  = Just s   | otherwise   = Nothing @@ -352,7 +351,7 @@               $$ (text "******* Measure Specifications **************")               $$ (pprintLongList $ meas spec) -instance PPrint GhcInfo where +instance PPrint GhcInfo where   pprint info =   (text "*************** Imports *********************")               $+$ (intersperse comma $ text <$> imports info)               $+$ (text "*************** Includes ********************")@@ -367,29 +366,28 @@               $+$ (pprint $ cbs info)  instance Show GhcInfo where-  show = showpp +  show = showpp  instance PPrint [CoreBind] where   pprint = pprDoc . tidyCBs  instance PPrint TargetVars where   pprint AllVars   = text "All Variables"-  pprint (Only vs) = text "Only Variables: " <+> pprint vs +  pprint (Only vs) = text "Only Variables: " <+> pprint vs  ------------------------------------------------------------------------ -- Dealing With Errors ------------------------------------------------- ------------------------------------------------------------------------  -- | Throw a panic exception-exitWithPanic  :: String -> a -exitWithPanic  = Ex.throw . errOther . text +exitWithPanic  :: String -> a+exitWithPanic  = Ex.throw . errOther . text  -- | Convert a GHC error into one of ours-instance Result SourceError where -  result = (`Crash` "Invalid Source") -         . concatMap errMsgErrors -         . bagToList +instance Result SourceError where+  result = (`Crash` "Invalid Source")+         . concatMap errMsgErrors+         . bagToList          . srcErrorMessages-     -errMsgErrors e = [ ErrGhc (errMsgSpan e) (pprint e)]  +errMsgErrors e = [ ErrGhc (errMsgSpan e) (pprint e)]
src/Language/Haskell/Liquid/GhcMisc.hs view
@@ -19,6 +19,7 @@ import           Debug.Trace  import           Avail                        (availsToNameSet)+import           BasicTypes                   (Arity) import           CoreSyn                      hiding (Expr) import qualified CoreSyn as Core import           CostCentre@@ -45,13 +46,15 @@ import           Type                         (liftedTypeKind) import           TypeRep import           Var+import           IdInfo import qualified TyCon                        as TC+-- import qualified DataCon                      as DC import           Data.Char                    (isLower, isSpace) import           Data.Monoid                  (mempty) import           Data.Hashable import qualified Data.HashSet                 as S import qualified Data.List                    as L-import           Data.Aeson                 +import           Data.Aeson import qualified Data.Text.Encoding           as T import qualified Data.Text.Unsafe             as T import           Control.Applicative          ((<$>), (<*>))@@ -104,7 +107,7 @@  tickSrcSpan ::  Outputable a => Tickish a -> SrcSpan tickSrcSpan (ProfNote cc _ _) = cc_loc cc-tickSrcSpan _                 = noSrcSpan +tickSrcSpan _                 = noSrcSpan ----------------------------------------------------------------------- --------------- Generic Helpers for Accessing GHC Innards ------------- -----------------------------------------------------------------------@@ -116,7 +119,7 @@  stringTyCon :: Char -> Int -> String -> TyCon stringTyCon c n s = TC.mkKindTyCon name superKind-  where +  where     name          = mkInternalName (mkUnique c n) occ noSrcSpan     occ           = mkTcOcc s @@ -128,7 +131,7 @@ isBaseType (FunTy t1 t2)   = isBaseType t1 && isBaseType t2 isBaseType _               = False validTyVar :: String -> Bool-validTyVar s@(c:_) = isLower c && all (not . isSpace) s +validTyVar s@(c:_) = isLower c && all (not . isSpace) s validTyVar _       = False  tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)@@ -158,53 +161,58 @@ ------------------ Generic Helpers for DataConstructors --------------- ----------------------------------------------------------------------- +isDataConId id = case idDetails id of+                  DataConWorkId _ -> True+                  DataConWrapId _ -> True+                  _               -> False+ getDataConVarUnique v-  | isId v && isDataConWorkId v = getUnique $ idDataCon v-  | otherwise                   = getUnique v-  +  | isId v && isDataConId v = getUnique $ idDataCon v+  | otherwise               = getUnique v + newtype Loc    = L (Int, Int) deriving (Eq, Ord, Show)  instance Hashable Loc where-  hashWithSalt i (L z) = hashWithSalt i z +  hashWithSalt i (L z) = hashWithSalt i z  --instance (Uniquable a) => Hashable a where  instance Hashable SrcSpan where-  hashWithSalt i (UnhelpfulSpan s) = hashWithSalt i (uniq s) +  hashWithSalt i (UnhelpfulSpan s) = hashWithSalt i (uniq s)   hashWithSalt i (RealSrcSpan s)   = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)  instance Outputable a => Outputable (S.HashSet a) where-  ppr = ppr . S.toList +  ppr = ppr . S.toList  instance ToJSON RealSrcSpan where   toJSON sp = object [ "filename"  .= f  -- (unpackFS $ srcSpanFile sp)-                     , "startLine" .= l1 -- srcSpanStartLine sp +                     , "startLine" .= l1 -- srcSpanStartLine sp                      , "startCol"  .= c1 -- srcSpanStartCol  sp                      , "endLine"   .= l2 -- srcSpanEndLine   sp                      , "endCol"    .= c2 -- srcSpanEndCol    sp                      ]-    where -      (f, l1, c1, l2, c2) = unpackRealSrcSpan sp          +    where+      (f, l1, c1, l2, c2) = unpackRealSrcSpan sp  unpackRealSrcSpan rsp = (f, l1, c1, l2, c2)-  where    +  where     f                 = unpackFS $ srcSpanFile rsp-    l1                = srcSpanStartLine rsp +    l1                = srcSpanStartLine rsp     c1                = srcSpanStartCol  rsp     l2                = srcSpanEndLine   rsp     c2                = srcSpanEndCol    rsp-     + instance FromJSON RealSrcSpan where-  parseJSON (Object v) = realSrcSpan <$> v .: "filename" +  parseJSON (Object v) = realSrcSpan <$> v .: "filename"                                      <*> v .: "startLine"                                      <*> v .: "startCol"                                      <*> v .: "endLine"                                      <*> v .: "endCol"   parseJSON _          = mempty -realSrcSpan f l1 c1 l2 c2 = mkRealSrcSpan loc1 loc2 +realSrcSpan f l1 c1 l2 c2 = mkRealSrcSpan loc1 loc2   where     loc1                  = mkRealSrcLoc (fsLit f) l1 c1     loc2                  = mkRealSrcLoc (fsLit f) l2 c2@@ -212,21 +220,21 @@   instance ToJSON SrcSpan where-  toJSON (RealSrcSpan rsp) = object [ "realSpan" .= True, "spanInfo" .= rsp ]  +  toJSON (RealSrcSpan rsp) = object [ "realSpan" .= True, "spanInfo" .= rsp ]   toJSON (UnhelpfulSpan _) = object [ "realSpan" .= False ]  instance FromJSON SrcSpan where   parseJSON (Object v) = do tag <- v .: "realSpan"                             case tag of-                              False -> return noSrcSpan +                              False -> return noSrcSpan                               True  -> RealSrcSpan <$> v .: "spanInfo"   parseJSON _          = mempty   ------------------------------------------------------- -toFixSDoc = PJ.text . PJ.render . toFix -sDocDoc   = PJ.text . showSDoc +toFixSDoc = PJ.text . PJ.render . toFix+sDocDoc   = PJ.text . showSDoc pprDoc    = sDocDoc . ppr  -- Overriding Outputable functions because they now require DynFlags!@@ -237,7 +245,7 @@ typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr  instance Fixpoint Var where-  toFix = pprDoc +  toFix = pprDoc  instance Fixpoint Name where   toFix = pprDoc@@ -258,35 +266,50 @@   show = showPpr  sourcePosSrcSpan   :: SourcePos -> SrcSpan-sourcePosSrcSpan = srcLocSpan . sourcePosSrcLoc +sourcePosSrcSpan = srcLocSpan . sourcePosSrcLoc  sourcePosSrcLoc    :: SourcePos -> SrcLoc-sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col  -  where +sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col+  where     file          = sourceName p     line          = sourceLine p     col           = sourceColumn p  srcSpanSourcePos :: SrcSpan -> SourcePos-srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "LH.GhcMisc.srcSpanSourcePos" +srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "LH.GhcMisc.srcSpanSourcePos" srcSpanSourcePos (RealSrcSpan s)   = realSrcSpanSourcePos s +srcSpanSourcePosE :: SrcSpan -> SourcePos+srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "LH.GhcMisc.srcSpanSourcePos"+srcSpanSourcePosE (RealSrcSpan s)   = realSrcSpanSourcePosE s+++ srcSpanFilename    = maybe "" unpackFS . srcSpanFileName_maybe srcSpanStartLoc l  = L (srcSpanStartLine l, srcSpanStartCol l) srcSpanEndLoc l    = L (srcSpanEndLine l, srcSpanEndCol l) oneLine l          = srcSpanStartLine l == srcSpanEndLine l lineCol l          = (srcSpanStartLine l, srcSpanStartCol l) -realSrcSpanSourcePos :: RealSrcSpan -> SourcePos +realSrcSpanSourcePos :: RealSrcSpan -> SourcePos realSrcSpanSourcePos s = newPos file line col-  where +  where     file               = unpackFS $ srcSpanFile s     line               = srcSpanStartLine       s     col                = srcSpanStartCol        s -getSourcePos           = srcSpanSourcePos . getSrcSpan  +realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos+realSrcSpanSourcePosE s = newPos file line col+  where+    file                = unpackFS $ srcSpanFile s+    line                = srcSpanEndLine       s+    col                 = srcSpanEndCol        s ++getSourcePos           = srcSpanSourcePos  . getSrcSpan+getSourcePosE          = srcSpanSourcePosE . getSrcSpan+ collectArguments n e = if length xs > n then take n xs else xs   where (vs', e') = collectValBinders' $ snd $ collectTyBinders e         vs        = fst $ collectValBinders $ ignoreLetBinds e'@@ -299,9 +322,9 @@     go tvs (Tick _ e)            = go tvs e     go tvs e                     = (reverse tvs, e) -ignoreLetBinds (Let (NonRec _ _) e') +ignoreLetBinds (Let (NonRec _ _) e')   = ignoreLetBinds e'-ignoreLetBinds e +ignoreLetBinds e   = e  isDictionaryExpression :: Core.Expr Id -> Maybe Id@@ -313,11 +336,24 @@ isInternal   x = L.isPrefixOf "$"  (symbolString $ dropModuleNames $ symbol x)  +realTcArity :: TyCon -> Arity+realTcArity+  = kindArity . TC.tyConKind++kindArity :: Kind -> Arity+kindArity (FunTy _ res)+  = 1 + kindArity res+kindArity (ForAllTy _ res)+  = kindArity res+kindArity _+  = 0++ instance Hashable Var where-  hashWithSalt = uniqueHash +  hashWithSalt = uniqueHash  instance Hashable TyCon where-  hashWithSalt = uniqueHash +  hashWithSalt = uniqueHash  uniqueHash i = hashWithSalt i . getKey . getUnique @@ -373,7 +409,7 @@   symbol = varSymbol  varSymbol ::  Var -> Symbol-varSymbol v +varSymbol v   | us `isSuffixOfSym` vs = vs   | otherwise             = vs `mappend` singletonSym symSepName `mappend` us   where us  = symbol $ showPpr $ getDataConVarUnique v@@ -390,3 +426,9 @@  fastStringText = T.decodeUtf8 . fastStringToByteString symbolFastString = T.unsafeDupablePerformIO . mkFastStringByteString . T.encodeUtf8 . symbolText+++tyConTyVarsDef c | TC.isPrimTyCon c || isFunTyCon c = []+tyConTyVarsDef c | TC.isPromotedTyCon   c = error ("TyVars on " ++ show c) -- tyConTyVarsDef $ TC.ty_con c+tyConTyVarsDef c | TC.isPromotedDataCon c = error ("TyVars on " ++ show c) -- DC.dataConUnivTyVars $ TC.datacon c+tyConTyVarsDef c = TC.tyConTyVars c
src/Language/Haskell/Liquid/Literals.hs view
@@ -3,7 +3,7 @@ 	) where   import TypeRep-import Literal+import Literal   import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.RefType@@ -12,14 +12,16 @@ import Language.Fixpoint.Types (exprReft)  import Data.Monoid+import Control.Applicative+ --------------------------------------------------------------- ----------------------- Typing Literals ----------------------- ---------------------------------------------------------------  makeRTypeBase (TyVarTy α)    x          = RVar (rTyVar α) x -makeRTypeBase (TyConApp c _) x -  = rApp c [] [] x+makeRTypeBase (TyConApp c ts) x +  = rApp c ((`makeRTypeBase` mempty) <$> ts) [] x makeRTypeBase _              _   = error "RefType : makeRTypeBase" @@ -27,6 +29,7 @@   = makeRTypeBase (literalType l) (literalFReft tce l)   literalFReft tce = maybe mempty exprReft . snd . literalConst tce+  -- | `literalConst` returns `Nothing` for unhandled lits because --    otherwise string-literals show up as global int-constants
src/Language/Haskell/Liquid/Measure.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FlexibleContexts       #-} +{-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE UndecidableInstances   #-} {-# LANGUAGE OverloadedStrings      #-} -module Language.Haskell.Liquid.Measure (  +module Language.Haskell.Liquid.Measure (     Spec (..)-  , BareSpec  +  , BareSpec   , MSpec (..)   , mkM, mkMSpec, mkMSpec'   , qualifySpec@@ -22,31 +22,34 @@  import qualified Data.HashMap.Strict as M  import qualified Data.HashSet        as S -import Data.List (foldl1')+import Data.List (foldl')  import Data.Monoid hiding ((<>)) import Data.Bifunctor import Control.Applicative      ((<$>)) +import Data.Maybe (fromMaybe)+ import Language.Fixpoint.Misc import Language.Fixpoint.Types hiding (Def, R) import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.Types    hiding (GhcInfo(..), GhcSpec (..)) import Language.Haskell.Liquid.RefType import Language.Haskell.Liquid.Variance+import Language.Haskell.Liquid.Bounds  -- MOVE TO TYPES type BareSpec      = Spec BareType LocSymbol -data Spec ty bndr  = Spec { +data Spec ty bndr  = Spec {     measures   :: ![Measure ty bndr]            -- ^ User-defined properties for ADTs   , asmSigs    :: ![(LocSymbol, ty)]            -- ^ Assumed (unchecked) types-  , sigs       :: ![(LocSymbol, ty)]            -- ^ Imported functions and types   +  , sigs       :: ![(LocSymbol, ty)]            -- ^ Imported functions and types   , localSigs  :: ![(LocSymbol, ty)]            -- ^ Local type signatures   , invariants :: ![Located ty]                 -- ^ Data type invariants   , ialiases   :: ![(Located ty, Located ty)]   -- ^ Data type invariants to be checked   , imports    :: ![Symbol]                     -- ^ Loaded spec module names-  , dataDecls  :: ![DataDecl]                   -- ^ Predicated data definitions +  , dataDecls  :: ![DataDecl]                   -- ^ Predicated data definitions   , includes   :: ![FilePath]                   -- ^ Included qualifier files   , aliases    :: ![RTAlias Symbol BareType]    -- ^ RefType aliases   , paliases   :: ![RTAlias Symbol Pred]        -- ^ Refinement/Predicate aliases@@ -57,20 +60,22 @@   , lvars      :: ![(LocSymbol)]                -- ^ Variables that should be checked in the environment they are used   , lazy       :: !(S.HashSet LocSymbol)        -- ^ Ignore Termination Check in these Functions   , hmeas      :: !(S.HashSet LocSymbol)        -- ^ Binders to turn into measures using haskell definitions+  , hbounds    :: !(S.HashSet LocSymbol)        -- ^ Binders to turn into bounds using haskell definitions   , inlines    :: !(S.HashSet LocSymbol)        -- ^ Binders to turn into logic inline using haskell definitions   , pragmas    :: ![Located String]             -- ^ Command-line configurations passed in through source   , cmeasures  :: ![Measure ty ()]              -- ^ Measures attached to a type-class   , imeasures  :: ![Measure ty bndr]            -- ^ Mappings from (measure,type) -> measure   , classes    :: ![RClass ty]                  -- ^ Refined Type-Classes-  , termexprs  :: ![(LocSymbol, [Expr])]        -- ^ Terminating Conditions for functions  -  , rinstance  :: ![RInstance ty] +  , termexprs  :: ![(LocSymbol, [Expr])]        -- ^ Terminating Conditions for functions+  , rinstance  :: ![RInstance ty]   , dvariance  :: ![(LocSymbol, [Variance])]+  , bounds     :: !(RRBEnv ty)   }   -- MOVE TO TYPES data MSpec ty ctor = MSpec { -    ctorMap  :: M.HashMap Symbol [Def ctor]+    ctorMap  :: M.HashMap Symbol [Def ty ctor]   , measMap  :: M.HashMap LocSymbol (Measure ty ctor)   , cmeasMap :: M.HashMap LocSymbol (Measure ty ())   , imeas    :: ![Measure ty ctor]@@ -78,22 +83,22 @@   instance (Show ty, Show ctor, PPrint ctor, PPrint ty) => Show (MSpec ty ctor) where-  show (MSpec ct m cm im) -    = "\nMSpec:\n" ++ -      "\nctorMap:\t "  ++ show ct ++ -      "\nmeasMap:\t "  ++ show m  ++ -      "\ncmeasMap:\t " ++ show cm ++ -      "\nimeas:\t "    ++ show im ++ -      "\n" +  show (MSpec ct m cm im)+    = "\nMSpec:\n" +++      "\nctorMap:\t "  ++ show ct +++      "\nmeasMap:\t "  ++ show m  +++      "\ncmeasMap:\t " ++ show cm +++      "\nimeas:\t "    ++ show im +++      "\n"  instance Eq ctor => Monoid (MSpec ty ctor) where   mempty = MSpec M.empty M.empty M.empty [] -  (MSpec c1 m1 cm1 im1) `mappend` (MSpec c2 m2 cm2 im2) -    | null dups +  (MSpec c1 m1 cm1 im1) `mappend` (MSpec c2 m2 cm2 im2)+    | null dups     = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2)            (cm1 `M.union` cm2) (im1 ++ im2)-    | otherwise +    | otherwise     = errorstar $ err (head dups)     where dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, val k1 == val k2]           err (k1, k2) = printf "\nDuplicate Measure Definitions for %s\n%s" (showpp k1) (showpp $ map loc [k1, k2])@@ -105,7 +110,7 @@   where     tx = fmap (qualifySymbol name) -mkM ::  LocSymbol -> ty -> [Def bndr] -> Measure ty bndr+mkM ::  LocSymbol -> ty -> [Def ty bndr] -> Measure ty bndr mkM name typ eqns    | all ((name ==) . measure) eqns   = M name typ eqns@@ -116,12 +121,12 @@ --         -> MSpec ty LocSymbol  mkMSpec' ms = MSpec cm mm M.empty []-  where +  where     cm     = groupMap (symbol . ctor) $ concatMap eqns ms     mm     = M.fromList [(name m, m) | m <- ms ]  mkMSpec ms cms ims = MSpec cm mm cmm ims-  where +  where     cm     = groupMap (val . ctor) $ concatMap eqns (ms'++ims)     mm     = M.fromList [(name m, m) | m <- ms' ]     cmm    = M.fromList [(name m, m) | m <- cms ]@@ -132,11 +137,11 @@   -checkDuplicateMeasure ms -  = case M.toList dups of +checkDuplicateMeasure ms+  = case M.toList dups of       []         -> ms-      mms        -> errorstar $ concatMap err mms -    where +      mms        -> errorstar $ concatMap err mms+    where       gms        = group [(name m , m) | m <- ms]       dups       = M.filter ((1 <) . length) gms       err (m,ms) = printf "\nDuplicate Measure Definitions for %s\n%s" (showpp m) (showpp $ map (loc . name) ms)@@ -148,9 +153,9 @@ instance Monoid (Spec ty bndr) where   mappend s1 s2     = Spec { measures   =           measures s1   ++ measures s2-           , asmSigs    =           asmSigs s1    ++ asmSigs s2 -           , sigs       =           sigs s1       ++ sigs s2 -           , localSigs  =           localSigs s1  ++ localSigs s2 +           , asmSigs    =           asmSigs s1    ++ asmSigs s2+           , sigs       =           sigs s1       ++ sigs s2+           , localSigs  =           localSigs s1  ++ localSigs s2            , invariants =           invariants s1 ++ invariants s2            , ialiases   =           ialiases s1   ++ ialiases s2            , imports    = sortNub $ imports s1    ++ imports s2@@ -165,6 +170,7 @@            , lvars      =           lvars s1      ++ lvars s2            , lazy       = S.union   (lazy s1)        (lazy s2)            , hmeas      = S.union   (hmeas s1)       (hmeas s2)+           , hbounds    = S.union   (hbounds s1)     (hbounds s2)            , inlines    = S.union   (inlines s1)     (inlines s2)            , pragmas    =           pragmas s1    ++ pragmas s2            , cmeasures  =           cmeasures s1  ++ cmeasures s2@@ -172,28 +178,30 @@            , classes    =           classes s1    ++ classes s1            , termexprs  =           termexprs s1  ++ termexprs s2            , rinstance  =           rinstance s1  ++ rinstance s2-           , dvariance  =           dvariance s1  ++ dvariance s2  +           , dvariance  =           dvariance s1  ++ dvariance s2+           , bounds     = M.union   (bounds s1)      (bounds s2)            }    mempty-    = Spec { measures   = [] -           , asmSigs    = [] -           , sigs       = [] -           , localSigs  = [] +    = Spec { measures   = []+           , asmSigs    = []+           , sigs       = []+           , localSigs  = []            , invariants = []            , ialiases   = []            , imports    = []-           , dataDecls  = [] -           , includes   = [] -           , aliases    = [] -           , paliases   = [] -           , ealiases   = [] +           , dataDecls  = []+           , includes   = []+           , aliases    = []+           , paliases   = []+           , ealiases   = []            , embeds     = M.empty            , qualifiers = []            , decr       = []            , lvars      = []            , lazy       = S.empty            , hmeas      = S.empty+           , hbounds    = S.empty            , inlines    = S.empty            , pragmas    = []            , cmeasures  = []@@ -202,10 +210,11 @@            , termexprs  = []            , rinstance  = []            , dvariance  = []+           , bounds     = M.empty            }  -- MOVE TO TYPES-instance Functor Def where+instance Functor (Def t) where   fmap f def = def { ctor = f (ctor def) }  -- MOVE TO TYPES@@ -219,16 +228,23 @@ instance Functor (MSpec t) where   fmap f (MSpec c m cm im) = MSpec (fc c) (fm m) cm (fmap (fmap f) im)      where fc = fmap $ fmap $ fmap f-           fm = fmap $ fmap f +           fm = fmap $ fmap f  -- MOVE TO TYPES+instance Bifunctor Def where+  first  f def  = def { dparams = mapSnd f <$> dparams def+                      , dsort = f <$> dsort def+                      , binds = mapSnd (f <$>) <$> binds def}+  second f def  = def {ctor    = f $ ctor def}++-- MOVE TO TYPES instance Bifunctor Measure where-  first f (M n s eqs)  = M n (f s) eqs-  second f (M n s eqs) = M n s (fmap f <$> eqs)+  first f (M n s eqs)  = M n (f s) (first f <$> eqs)+  second f (M n s eqs) = M n s (second f <$> eqs)  -- MOVE TO TYPES instance Bifunctor MSpec   where-  first f (MSpec c m cm im) = MSpec c (fmap (first f) m) (fmap (first f) cm) (fmap (first f) im)+  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c) (fmap (first f) m) (fmap (first f) cm) (fmap (first f) im)   second                    = fmap  -- MOVE TO TYPES@@ -244,6 +260,7 @@         , imeasures  = first f  <$> (imeasures s)         , classes    = fmap f   <$> (classes s)         , rinstance  = fmap f   <$> (rinstance s)+        , bounds     = fmap (first f) (bounds s)         }     where fmapP f (x, y)       = (fmap f x, fmap f y) @@ -254,18 +271,18 @@  -- MOVE TO TYPES instance PPrint Body where-  pprint (E e)   = pprint e  +  pprint (E e)   = pprint e   pprint (P p)   = pprint p-  pprint (R v p) = braces (pprint v <+> text "|" <+> pprint p)   +  pprint (R v p) = braces (pprint v <+> text "|" <+> pprint p)  -- instance PPrint a => Fixpoint (PPrint a) where --   toFix (BDc c)  = toFix c --   toFix (BTup n) = parens $ toFix n  -- MOVE TO TYPES-instance PPrint a => PPrint (Def a) where-  pprint (Def m c bs body) = pprint m <> text " " <> cbsd <> text " = " <> pprint body   -    where cbsd = parens (pprint c <> hsep (pprint `fmap` bs))+instance PPrint a => PPrint (Def t a) where+  pprint (Def m p c _ bs body) = pprint m <+> pprint (fst <$> p) <+> cbsd <> text " = " <> pprint body   +    where cbsd = parens (pprint c <> hsep (pprint `fmap` (fst <$> bs)))  -- MOVE TO TYPES instance (PPrint t, PPrint a) => PPrint (Measure t a) where@@ -288,39 +305,42 @@  -- MOVE TO TYPES mapTy :: (tya -> tyb) -> Measure tya c -> Measure tyb c-mapTy f (M n ty eqs) = M n (f ty) eqs+mapTy = first   dataConTypes :: MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)]) dataConTypes  s = (ctorTys, measTys)-  where +  where     measTys     = [(name m, sort m) | m <- M.elems (measMap s) ++ imeas s]     ctorTys     = concatMap mkDataConIdsTy [(defsVar ds, defsTy ds)                                            | (_, ds) <- M.toList (ctorMap s)                                                        ]-    defsTy      = foldl1' meet . fmap defRefType +    defsTy ds@(d:_) = foldl' strengthenRefTypeGen (ofType $ dataConUserType $ ctor d) (defRefType <$> ds)+    defsTy []       = errorstar "Measure.defsTy: This cannot happen"+     defsVar     = ctor . safeHead "defsVar"  -defRefType :: Def DataCon -> RRType Reft-defRefType (Def f dc xs body) = mkArrow as [] [] xts t'+defRefType :: Def (RRType Reft) DataCon -> RRType Reft+defRefType (Def f args dc mt xs body) = generalize $ mkArrow [] [] [] xts t'   where -    as  = RTV <$> dataConUnivTyVars dc-    xts = safeZip msg xs $ ofType `fmap` dataConOrigArgTys dc-    t'  = refineWithCtorBody dc f body t -    t   = ofType $ dataConOrigResTy dc+    t   = fromMaybe (ofType $ dataConOrigResTy dc) mt+    xts = safeZipWith msg g xs $ ofType `fmap` dataConOrigArgTys dc+    g (x, Nothing) t = (x, t, mempty) +    g (x, Just t)  _ = (x, t, mempty)+    t'  = mkForAlls args $ refineWithCtorBody dc f (fst <$> args) body t      msg = "defRefType dc = " ++ showPpr dc  +    mkForAlls xts t = foldl' (\t (x, tx) -> RAllE x tx t) t xts -refineWithCtorBody dc f body t =++refineWithCtorBody dc f as body t =   case stripRTypeBase t of      Just (Reft (v, _)) ->-      strengthen t $ Reft (v, [RConc $ bodyPred (EApp f [eVar v]) body])+      strengthen t $ Reft (v, Refa $ bodyPred (EApp f (eVar <$> (as ++ [v]))) body)     Nothing ->        errorstar $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc   bodyPred ::  Expr -> Body -> Pred bodyPred fv (E e)    = PAtom Eq fv e-bodyPred fv (P p)    = PIff  (PBexp fv) p +bodyPred fv (P p)    = PIff  (PBexp fv) p bodyPred fv (R v' p) = subst1 p (v', fv)--
src/Language/Haskell/Liquid/Misc.hs view
@@ -35,7 +35,13 @@ safeFromJust _  (Just x) = x safeFromJust err _        = errorstar err +fst4 (a,_,_,_) = a+snd4 (_,b,_,_) = b++mapFourth4 f (x, y, z, w) = (x, y, z, f w)+ addFst3   a (b, c) = (a, b, c)+addThd3   c (a, b) = (a, b, c) dropFst3 (_, x, y) = (x, y) dropThd3 (x, y, _) = (x, y) @@ -73,6 +79,10 @@ safeZipWithError msg (x:xs) (y:ys) = (x,y) : safeZipWithError msg xs ys safeZipWithError _   []     []     = [] safeZipWithError msg _      _      = errorstar msg++safeZip3WithError msg (x:xs) (y:ys) (z:zs) = (x,y,z) : safeZip3WithError msg xs ys zs+safeZip3WithError _   []     []     []     = []+safeZip3WithError msg _      _      _      = errorstar msg  mapNs ns f xs = foldl (\xs n -> mapN n f xs) xs ns
src/Language/Haskell/Liquid/Parse.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, TupleSections, OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE OverloadedStrings         #-}  module Language.Haskell.Liquid.Parse   ( hsSpecificationP, lhsSpecificationP, specSpecificationP@@ -8,8 +13,8 @@  import Control.Monad import Text.Parsec-import Text.Parsec.Error (newErrorMessage, Message (..)) -import Text.Parsec.Pos   (newPos) +import Text.Parsec.Error (newErrorMessage, Message (..))+import Text.Parsec.Pos   (newPos)  import qualified Text.Parsec.Token as Token import qualified Data.HashMap.Strict as M@@ -30,7 +35,8 @@ import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.Variance +import Language.Haskell.Liquid.Variance+import Language.Haskell.Liquid.Bounds  import qualified Language.Haskell.Liquid.Measure as Measure import Language.Fixpoint.Names (listConName, hpropConName, propConName, tupConName, headSym)@@ -72,10 +78,10 @@ -------------------------------------------------------------------------- specSpecificationP  :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) ---------------------------------------------------------------------------specSpecificationP  = parseWithError specificationP +specSpecificationP  = parseWithError specificationP  specificationP :: Parser (ModName, Measure.BareSpec)-specificationP +specificationP   = do reserved "module"        reserved "spec"        name   <- symbolP@@ -84,40 +90,40 @@        return $ mkSpec (ModName SpecImport $ mkModuleName $ symbolString name) xs  ----------------------------------------------------------------------------parseWithError :: Parser a -> SourceName -> String -> Either Error a +parseWithError :: Parser a -> SourceName -> String -> Either Error a --------------------------------------------------------------------------- parseWithError parser f s   = case runParser (remainderP (whiteSpace >> parser)) 0 f s of       Left e            -> Left  $ parseErrorError f e       Right (r, "", _)  -> Right $ r-      Right (_, rem, _) -> Left  $ parseErrorError f $ remParseError f s rem +      Right (_, rem, _) -> Left  $ parseErrorError f $ remParseError f s rem  --------------------------------------------------------------------------- parseErrorError     :: SourceName -> ParseError -> Error --------------------------------------------------------------------------- parseErrorError f e = ErrParse sp msg e-  where +  where     pos             = errorPos e-    sp              = sourcePosSrcSpan pos +    sp              = sourcePosSrcSpan pos     msg             = text $ "Error Parsing Specification from: " ++ f  ----------------------------------------------------------------------------remParseError       :: SourceName -> String -> String -> ParseError +remParseError       :: SourceName -> String -> String -> ParseError --------------------------------------------------------------------------- remParseError f s r = newErrorMessage msg $ newPos f line col-  where +  where     msg             = Message "Leftover while parsing"-    (line, col)     = remLineCol s r +    (line, col)     = remLineCol s r  remLineCol          :: String -> String -> (Int, Int) remLineCol src rem = (line, col)-  where +  where     line           = 1 + srcLine - remLine-    srcLine        = length srcLines +    srcLine        = length srcLines     remLine        = length remLines-    col            = srcCol - remCol  -    srcCol         = length $ srcLines !! (line - 1) -    remCol         = length $ remLines !! 0 +    col            = srcCol - remCol+    srcCol         = length $ srcLines !! (line - 1)+    remCol         = length $ remLines !! 0     srcLines       = lines  $ src     remLines       = lines  $ rem @@ -129,16 +135,16 @@ -- Parse to Logic  --------------------------------------------------------------- ---------------------------------------------------------------------------------- -parseSymbolToLogic = parseWithError toLogicP +parseSymbolToLogic = parseWithError toLogicP  toLogicP-  = toLogicMap <$> many toLogicOneP +  = toLogicMap <$> many toLogicOneP  toLogicOneP   = do reserved "define"        (x:xs) <- many1 symbolP        reserved "="-       e      <- exprP +       e      <- exprP        return (x, xs, e)  @@ -157,13 +163,13 @@ -- | The top-level parser for "bare" refinement types. If refinements are -- not supplied, then the default "top" refinement is used. -bareTypeP :: Parser BareType +bareTypeP :: Parser BareType  bareTypeP   =  try bareAllP  <|> bareAllS- <|> bareAllExprP- <|> bareExistsP+--  <|> bareAllExprP+--  <|> bareExistsP  <|> try bareConstraintP  <|> try bareFunP  <|> bareAtomP (refBindP bindP)@@ -180,10 +186,11 @@  <|> holeP  <|> try (dummyP (bbaseP <* spaces)) -holeP       = reserved "_" >> spaces >> return (RHole $ uTop $ Reft ("VV", [hole]))+holeP       = reserved "_" >> spaces >> return (RHole $ uTop $ Reft ("VV", Refa hole)) holeRefP    = reserved "_" >> spaces >> return (RHole . uTop)-refasHoleP  = refasP <|> (reserved "_" >> return [hole])-+refasHoleP  = try refaP+           <|> (reserved "_" >> return (Refa hole))+            -- FIXME: the use of `blanks = oneOf " \t"` here is a terrible and fragile hack -- to avoid parsing: --@@ -192,7 +199,7 @@ -- -- as `foo :: a -> b bar`.. bbaseP :: Parser (Reft -> BareType)-bbaseP +bbaseP   =  holeRefP  <|> liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP  <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP@@ -201,7 +208,7 @@  <|> liftM5 bCon locUpperIdP stratumP predicatesP (sepBy bareTyArgP blanks) mmonoPredicateP  stratumP :: Parser Strata-stratumP +stratumP   = do reserved "^"        bstratumP  <|> return mempty@@ -215,32 +222,25 @@  <|> liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP  <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP  <|> try (liftM5 bCon locUpperIdP stratumP predicatesP (return []) (return mempty))- <|> liftM3 bRVar lowerIdP stratumP monoPredicateP + <|> liftM3 bRVar lowerIdP stratumP monoPredicateP  maybeP p = liftM Just p <|> return Nothing  bareTyArgP   =  -- try (RExprArg . expr <$> binderP) <|>-     try (RExprArg . expr <$> integer)- <|> try (braces $ RExprArg <$> exprP)+     try (RExprArg . fmap expr <$> locParserP integer)+ <|> try (braces $ RExprArg <$> locParserP exprP)  <|> try bareAtomNoAppP  <|> try (parens bareTypeP) -bareAtomNoAppP -  =  refP bbaseNoAppP +bareAtomNoAppP+  =  refP bbaseNoAppP  <|> try (dummyP (bbaseNoAppP <* spaces)) -bareAllExprP -  = do reserved "forall"-       zs <- brackets $ sepBy1 exBindP comma -       dot-       t  <- bareTypeP-       return $ foldr (uncurry RAllE) t zs-  bareConstraintP   = do ct   <- braces constraintP-       t    <- bareTypeP -       return $ rrTy ct t +       t    <- bareTypeP+       return $ rrTy ct t   constraintP@@ -248,7 +248,7 @@        t1 <- bareTypeP        reserved "<:"        t2 <- bareTypeP-       return $ fromRTypeRep $ RTypeRep [] [] [] ((val . fst <$> xts) ++ [dummySymbol]) ((snd <$> xts) ++ [t1]) t2 +       return $ fromRTypeRep $ RTypeRep [] [] [] ((val . fst <$> xts) ++ [dummySymbol]) (replicate (length xts + 1) mempty) ((snd <$> xts) ++ [t1]) t2   constraintEnvP@@ -257,20 +257,12 @@               return xts)   <|> return [] -rrTy ct t = RRTy [(dummySymbol, ct)] mempty OCons t +rrTy ct t = RRTy (xts ++ [(dummySymbol, tr)]) mempty OCons t+  where+    tr   = ty_res trep+    xts  = zip (ty_binds trep) (ty_args trep)+    trep = toRTypeRep ct -bareExistsP -  = do reserved "exists"-       zs <- brackets $ sepBy1 exBindP comma -       dot-       t  <- bareTypeP-       return $ foldr (uncurry REx) t zs-     -exBindP -  = do b <- binderP <* colon-       t <- bareArgP b-       return (b,t)-   bareAllS   = do reserved "forall"        ss <- (angles $ sepBy1 symbolP comma)@@ -278,7 +270,7 @@        t  <- bareTypeP        return $ foldr RAllS t ss -bareAllP +bareAllP   = do reserved "forall"        as <- many tyVarIdP        ps <- predVarDefsP@@ -290,14 +282,14 @@ tyVarIdP = symbol <$> condIdP alphanums (isLower . head)            where alphanums = ['a'..'z'] ++ ['0'..'9'] -predVarDefsP +predVarDefsP   =  try (angles $ sepBy1 predVarDefP comma)  <|> return []  predVarDefP   = bPVar <$> predVarIdP <*> dcolon <*> predVarTypeP -predVarIdP +predVarIdP   = symbol <$> tyVarIdP  bPVar p _ xts  = PV p (PVProp τ) dummySymbol τxs@@ -307,15 +299,15 @@  predVarTypeP :: Parser [(Symbol, BSort)] predVarTypeP = bareTypeP >>= either parserFail return . mkPredVarType-      + mkPredVarType t   | isOk      = Right $ zip xs ts-  | otherwise = Left err +  | otherwise = Left err   where     isOk      = isPropBareType tOut || isHPropBareType tOut     tOut      = ty_res trep-    trep      = toRTypeRep t -    xs        = ty_binds trep +    trep      = toRTypeRep t+    xs        = ty_binds trep     ts        = toRSort <$> ty_args trep     err       = "Predicate Variable with non-Prop output sort: " ++ showpp t @@ -328,16 +320,16 @@   =   (reserved "->" >> return ArrowFun)   <|> (reserved "=>" >> return ArrowPred) -bareFunP  -  = do b  <- try bindP <|> dummyBindP +bareFunP+  = do b  <- try bindP <|> dummyBindP        t1 <- bareArgP b        a  <- arrowP        t2 <- bareTypeP-       return $ bareArrow b t1 a t2 +       return $ bareArrow b t1 a t2  dummyBindP = tempSymbol "db" <$> freshIntP -bbindP     = lowerIdP <* dcolon +bbindP     = lowerIdP <* dcolon  bareArrow b t1 ArrowFun t2   = rFun b t1 t2@@ -352,17 +344,17 @@   -getClasses t@(RApp tc ts _ _) +getClasses t@(RApp tc ts _ _)   | isTuple tc   = ts-  | otherwise +  | otherwise   = [t]-getClasses t +getClasses t   = [t]  dummyP ::  Monad m => m (Reft -> b) -> m b-dummyP fm -  = fm `ap` return dummyReft +dummyP fm+  = fm `ap` return dummyReft  symsP   = do reserved "\\"@@ -374,49 +366,71 @@ dummyRSort   = RVar "dummy" mempty -refasP :: Parser [Refa]-refasP  =  (try (brackets $ sepBy (RConc <$> predP) semi)) -       <|> liftM ((:[]) . RConc) predP+refaP :: Parser Refa+refaP  =  try (refa <$> (brackets $ sepBy predP semi))+       <|> Refa <$> predP -predicatesP -   =  try (angles $ sepBy1 predicate1P comma) +predicatesP+   =  try (angles $ sepBy1 predicate1P comma)   <|> return [] -predicate1P +predicate1P    =  try (RProp <$> symsP <*> refP bbaseP)   <|> (RPropP [] . predUReft <$> monoPredicate1P)-  <|> (braces $ bRProp <$> symsP' <*> refasP)-   where +  <|> (braces $ bRProp <$> symsP' <*> refaP)+   where     symsP'       = do ss    <- symsP                       fs    <- mapM refreshSym (fst <$> ss)                       return $ zip ss fs     refreshSym s = intSymbol s <$> freshIntP -mmonoPredicateP -   = try (angles $ angles monoPredicate1P) +mmonoPredicateP+   = try (angles $ angles monoPredicate1P)   <|> return mempty -monoPredicateP -   = try (angles monoPredicate1P) +monoPredicateP+   = try (angles monoPredicate1P)   <|> return mempty  monoPredicate1P    =  try (reserved "True" >> return mempty)   <|> try (pdVar <$> parens predVarUseP)   <|> (pdVar <$> predVarUseP)-      -predVarUseP -  = do (p, xs) <- funArgsP ++predVarUseP+  = do (p, xs) <- funArgsP        return   $ PV p (PVProp dummyTyId) dummySymbol [ (dummyTyId, dummySymbol, x) | x <- xs ]  funArgsP  = try realP <|> empP   where     empP  = (,[]) <$> predVarIdP     realP = do EApp lp xs <- funAppP-               return (val lp, xs) +               return (val lp, xs) -   ++boundP = do+  name   <- locParserP upperIdP+  reservedOp "="+  vs     <- bvsP+  params <- many (parens tyBindP)+  args   <- bargsP+  body   <- predP+  return $ Bound name vs params args body+ where+    bargsP = try ( do reservedOp "\\"+                      xs <- many (parens tyBindP)+                      reservedOp  "->"+                      return xs+                 )+           <|> return []+    bvsP   = try ( do reserved "forall"+                      xs <- many symbolP+                      reserved  "."+                      return ((`RVar` mempty) <$> xs)+                 )+           <|> return []+ ------------------------------------------------------------------------ ----------------------- Wrapped Constructors --------------------------- ------------------------------------------------------------------------@@ -426,7 +440,7 @@   where     (ss, (v, _))  = (init syms, last syms)     syms          = [(y, s) | ((_, s), y) <- syms']-    su            = mkSubst [(x, EVar y) | ((x, _), y) <- syms'] +    su            = mkSubst [(x, EVar y) | ((x, _), y) <- syms']     r             = su `subst` Reft (v, expr)  bRVar α s p r             = RVar α (U r p s)@@ -434,7 +448,7 @@ bLst (Nothing) rs r       = RApp (dummyLoc listConName) []  rs (reftUReft r)  bTup [t] _ r | isTauto r  = t-             | otherwise  = t `strengthen` (reftUReft r) +             | otherwise  = t `strengthen` (reftUReft r) bTup ts rs r              = RApp (dummyLoc tupConName) ts rs (reftUReft r)  @@ -478,6 +492,8 @@   | Lazy    LocSymbol   | HMeas   LocSymbol   | Inline  LocSymbol+  | HBound  LocSymbol+  | PBound  (Bound ty Pred)   | Pragma  (Located String)   | CMeas   (Measure ty ())   | IMeas   (Measure ty ctor)@@ -487,31 +503,33 @@  -- | For debugging instance Show (Pspec a b) where-  show (Meas   _) = "Meas"   -  show (Assm   _) = "Assm"   -  show (Asrt   _) = "Asrt"   -  show (LAsrt  _) = "LAsrt"  -  show (Asrts  _) = "Asrts"  -  show (Impt   _) = "Impt"   -  show (DDecl  _) = "DDecl"  -  show (Incl   _) = "Incl"   -  show (Invt   _) = "Invt"   -  show (IAlias _) = "IAlias" -  show (Alias  _) = "Alias"  -  show (PAlias _) = "PAlias" -  show (EAlias _) = "EAlias" -  show (Embed  _) = "Embed"  -  show (Qualif _) = "Qualif" -  show (Decr   _) = "Decr"   -  show (LVars  _) = "LVars"  -  show (Lazy   _) = "Lazy"   -  show (HMeas  _) = "HMeas" -  show (Inline _) = "Inline"  -  show (Pragma _) = "Pragma" -  show (CMeas  _) = "CMeas"  -  show (IMeas  _) = "IMeas"  -  show (Class  _) = "Class" +  show (Meas   _) = "Meas"+  show (Assm   _) = "Assm"+  show (Asrt   _) = "Asrt"+  show (LAsrt  _) = "LAsrt"+  show (Asrts  _) = "Asrts"+  show (Impt   _) = "Impt"+  show (DDecl  _) = "DDecl"+  show (Incl   _) = "Incl"+  show (Invt   _) = "Invt"+  show (IAlias _) = "IAlias"+  show (Alias  _) = "Alias"+  show (PAlias _) = "PAlias"+  show (EAlias _) = "EAlias"+  show (Embed  _) = "Embed"+  show (Qualif _) = "Qualif"+  show (Decr   _) = "Decr"+  show (LVars  _) = "LVars"+  show (Lazy   _) = "Lazy"+  show (HMeas  _) = "HMeas"+  show (HBound _) = "HBound"+  show (Inline _) = "Inline"+  show (Pragma _) = "Pragma"+  show (CMeas  _) = "CMeas"+  show (IMeas  _) = "IMeas"+  show (Class  _) = "Class"   show (Varia  _) = "Varia"+  show (PBound _) = "Bound"   show (RInst  _) = "RInst"  @@ -535,26 +553,30 @@   , Measure.qualifiers = [q | Qualif q <- xs]   , Measure.decr       = [d | Decr d   <- xs]   , Measure.lvars      = [d | LVars d  <- xs]-  , Measure.lazy       = S.fromList [s | Lazy s  <- xs]-  , Measure.hmeas      = S.fromList [s | HMeas s <- xs]+  , Measure.lazy       = S.fromList [s | Lazy   s <- xs]+  , Measure.hmeas      = S.fromList [s | HMeas  s <- xs]   , Measure.inlines    = S.fromList [s | Inline s <- xs]+  , Measure.hbounds    = S.fromList [s | HBound s <- xs]   , Measure.pragmas    = [s | Pragma s <- xs]   , Measure.cmeasures  = [m | CMeas  m <- xs]   , Measure.imeasures  = [m | IMeas  m <- xs]   , Measure.classes    = [c | Class  c <- xs]   , Measure.dvariance  = [v | Varia  v <- xs]   , Measure.rinstance  = [i | RInst  i <- xs]+  , Measure.bounds     = M.fromList [(bname i, i) | PBound i <- xs]   , Measure.termexprs  = [(y, es) | Asrts (ys, (_, Just es)) <- xs, y <- ys]   }  specP :: Parser (Pspec BareType LocSymbol)-specP +specP   = try (reservedToken "assume"    >> liftM Assm   tyBindP   )     <|> (reservedToken "assert"    >> liftM Asrt   tyBindP   )     <|> (reservedToken "Local"     >> liftM LAsrt  tyBindP   )-    <|> try (reservedToken "measure"  >> liftM Meas   measureP  ) -    <|> (reservedToken "measure"   >> liftM HMeas  hmeasureP ) -    <|> (reservedToken "inline"   >> liftM Inline  inlineP ) +    <|> try (reservedToken "measure"  >> liftM Meas   measureP  )+    <|> (reservedToken "measure"   >> liftM HMeas  hmeasureP )+    <|> (reservedToken "inline"   >> liftM Inline  inlineP )+    <|> try (reservedToken "bound" >> liftM PBound  boundP)+    <|> (reservedToken "bound"    >> liftM HBound  hboundP)     <|> try (reservedToken "class"    >> reserved "measure" >> liftM CMeas cMeasureP)     <|> try (reservedToken "instance" >> reserved "measure" >> liftM IMeas iMeasureP)     <|> (reservedToken "instance"  >> liftM RInst  instanceP )@@ -577,7 +599,7 @@     <|> (reservedToken "LIQUID"    >> liftM Pragma pragmaP   )     <|> ({- DEFAULT -}           liftM Asrts  tyBindsP  ) -reservedToken str = try(string str >> spaces1) +reservedToken str = try(string str >> spaces1)  spaces1 = satisfy isSpace >> spaces @@ -590,6 +612,9 @@ hmeasureP :: Parser LocSymbol hmeasureP = locParserP binderP +hboundP :: Parser LocSymbol+hboundP = locParserP binderP+ inlineP :: Parser LocSymbol inlineP = locParserP binderP @@ -599,12 +624,12 @@  filePathP     :: Parser FilePath filePathP     = angles $ many1 pathCharP-  where -    pathCharP = choice $ char <$> pathChars +  where+    pathCharP = choice $ char <$> pathChars     pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/']  datavarianceP = liftM2 (,) (locUpperIdP) (spaces >> many varianceP)-  + varianceP = (reserved "bivariant"     >> return Bivariant)         <|> (reserved "invariant"     >> return Invariant)         <|> (reserved "covariant"     >> return Covariant)@@ -620,18 +645,18 @@ termBareTypeP :: Parser (BareType, Maybe [Expr]) termBareTypeP    = try termTypeP-  <|> (, Nothing) <$> genBareTypeP +  <|> (, Nothing) <$> genBareTypeP -termTypeP +termTypeP   = do t <- genBareTypeP        reserved "/"        es <- brackets $ sepBy exprP comma        return (t, Just es) -invariantP   = locParserP genBareTypeP +invariantP   = locParserP genBareTypeP -invaliasP   -  = do t  <- locParserP genBareTypeP +invaliasP+  = do t  <- locParserP genBareTypeP        reserved "as"        ta <- locParserP genBareTypeP        return (t, ta)@@ -639,7 +664,7 @@ genBareTypeP   = bareTypeP -embedP +embedP   = xyP locUpperIdP (reserved "as") fTyConP  @@ -647,26 +672,27 @@ paliasP = rtAliasP symbol predP ealiasP = rtAliasP symbol exprP -rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (RTAlias tv ty) +rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (RTAlias tv ty) rtAliasP f bodyP   = do pos  <- getPosition        name <- upperIdP        spaces        args <- sepBy aliasIdP blanks        whiteSpace >> reservedOp "=" >> whiteSpace-       body <- bodyP +       body <- bodyP+       posE <- getPosition        let (tArgs, vArgs) = partition (isLower . headSym) args-       return $ RTA name (f <$> tArgs) (f <$> vArgs) body pos+       return $ RTA name (f <$> tArgs) (f <$> vArgs) body pos posE  aliasIdP :: Parser Symbol-aliasIdP = condIdP (['A' .. 'Z'] ++ ['a'..'z'] ++ ['0'..'9']) (isAlpha . head) +aliasIdP = condIdP (['A' .. 'Z'] ++ ['a'..'z'] ++ ['0'..'9']) (isAlpha . head)  measureP :: Parser (Measure BareType LocSymbol)-measureP -  = do (x, ty) <- tyBindP  +measureP+  = do (x, ty) <- tyBindP        whiteSpace        eqns    <- grabs $ measureDefP $ (rawBodyP <|> tyBodyP ty)-       return   $ Measure.mkM x ty eqns +       return   $ Measure.mkM x ty eqns  cMeasureP :: Parser (Measure BareType ()) cMeasureP@@ -676,13 +702,13 @@ iMeasureP :: Parser (Measure BareType LocSymbol) iMeasureP = measureP -instanceP +instanceP   = do c  <- locUpperIdP        t  <- locUpperIdP-       as <- classParams  +       as <- classParams        ts <- sepBy tyBindP semi        return $ RI c (RApp t ((`RVar` mempty) <$> as) [] mempty) ts-  where +  where     classParams        =  (reserved "where" >> return [])       <|> (liftM2 (:) lowerIdP classParams)@@ -705,15 +731,15 @@ --     toRCls t@(RCls _ _)     = t --     toRCls t                = errorstar $ "Parse.toRCls called with" ++ show t -rawBodyP +rawBodyP   = braces $ do-      v <- symbolP +      v <- symbolP       reserved "|"       p <- predP <* spaces       return $ R v p  tyBodyP :: BareType -> Parser Body-tyBodyP ty +tyBodyP ty   = case outTy ty of       Just bt | isPropBareType bt                 -> P <$> predP@@ -726,27 +752,27 @@ binderP :: Parser Symbol binderP    =  try $ symbol <$> idP badc           <|> pwr <$> parens (idP bad)-  where +  where     idP p  = many1 (satisfy (not . p))     badc c = (c == ':') || (c == ',') || bad c     bad c  = isSpace c || c `elem` "(,)"     pwr s  = symbol $ "(" `mappend` s `mappend` ")"-             -grabs p = try (liftM2 (:) p (grabs p)) ++grabs p = try (liftM2 (:) p (grabs p))        <|> return [] -measureDefP :: Parser Body -> Parser (Def LocSymbol)+measureDefP :: Parser Body -> Parser (Def BareType LocSymbol) measureDefP bodyP   = do mname   <- locParserP symbolP        (c, xs) <- measurePatP        whiteSpace >> reservedOp "=" >> whiteSpace-       body    <- bodyP +       body    <- bodyP        whiteSpace        let xs'  = (symbol . val) <$> xs-       return   $ Def mname (symbol <$> c) xs' body+       return   $ Def mname [] (symbol <$> c) Nothing ((,Nothing) <$> xs') body  measurePatP :: Parser (LocSymbol, [LocSymbol])-measurePatP +measurePatP   =  parens (try conPatP <|> try consPatP <|> nilPatP <|> tupPatP)  <|> nullaryConPatP @@ -767,7 +793,7 @@ --------------------------------- Predicates ---------------------------------- ------------------------------------------------------------------------------- -dataConFieldsP +dataConFieldsP   =   (braces $ sepBy predTypeDDP comma)   <|> (sepBy dataConFieldP spaces) @@ -781,7 +807,7 @@            t <- bareTypeP            return (v,t) -predTypeDDP +predTypeDDP   = liftM2 (,) bbindP bareTypeP  dataConP@@ -790,20 +816,20 @@        xts <- dataConFieldsP        return (x, xts) -dataConNameP +dataConNameP   =  try upperIdP  <|> pwr <$> parens (idP bad)-  where +  where      idP p  = symbol <$> many1 (satisfy (not . p))      bad c  = isSpace c || c `elem` "(,)"      pwr s  = "(" <> s <> ")" -dataSizeP +dataSizeP   = (brackets $ (Just . mkFun) <$> locLowerIdP)   <|> return Nothing   where mkFun s = \x -> EApp (symbol <$> s) [EVar x] -dataDeclP :: Parser DataDecl +dataDeclP :: Parser DataDecl dataDeclP = try dataDeclFullP <|> dataDeclSizeP  @@ -832,12 +858,12 @@ ------------ Interacting with Fixpoint ------------------------------ --------------------------------------------------------------------- -grabUpto p  +grabUpto p   =  try (lookAhead p >>= return . Just)  <|> try (eof         >> return Nothing)  <|> (anyChar >> grabUpto p) -betweenMany leftP rightP p +betweenMany leftP rightP p   = do z <- grabUpto leftP        case z of          Just _  -> liftM2 (:) (between leftP rightP p) (betweenMany leftP rightP p)@@ -851,7 +877,7 @@ ---------------------------------------------------------------  instance Inputable BareType where-  rr' = doParse' bareTypeP +  rr' = doParse' bareTypeP  instance Inputable (Measure BareType LocSymbol) where   rr' = doParse' measureP
src/Language/Haskell/Liquid/PredType.hs view
@@ -15,7 +15,7 @@    -- * Compute @RType@ of a given @PVar@   , pvarRType-    +   , substParg   , pApp   , wiredSortedSyms@@ -29,12 +29,12 @@  import qualified Data.HashMap.Strict as M import Data.List        (partition, foldl')-import Data.Monoid      (mempty, mappend)+import Data.Monoid      (mempty, mappend, mconcat)  import Language.Fixpoint.Misc import Language.Fixpoint.Types hiding (Predicate, Expr) import qualified Language.Fixpoint.Types as F-import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.RefType  hiding (generalize) import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.Misc@@ -48,26 +48,26 @@  mkRTyCon ::  TC.TyCon -> TyConP -> RTyCon mkRTyCon tc (TyConP αs' ps _ tyvariance predvariance size) = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size)-  where τs   = [rVar α :: RSort |  α <- TC.tyConTyVars tc]+  where τs   = [rVar α :: RSort |  α <- tyConTyVarsDef tc]         pvs' = subts (zip αs' τs) <$> ps -dataConPSpecType :: DataCon -> DataConP -> SpecType -dataConPSpecType dc (DataConP _ vs ps ls cs yts rt) = mkArrow vs ps ls ts' rt'-  where +dataConPSpecType :: DataCon -> DataConP -> SpecType+dataConPSpecType dc (DataConP _ vs ps ls cs yts rt _) = mkArrow vs ps ls ts' rt'+  where     (xs, ts) = unzip $ reverse yts     mkDSym   = (`mappend` symbol dc) . (`mappend` "_") . symbol     ys       = mkDSym <$> xs     tx _  []     []     []     = []-    tx su (x:xs) (y:ys) (t:ts) = (y, subst (F.mkSubst su) t)+    tx su (x:xs) (y:ys) (t:ts) = (y, subst (F.mkSubst su) t, mempty)                                : tx ((x, F.EVar y):su) xs ys ts-    tx _ _ _ _ = errorstar "PredType.dataConPSpecType.tx called on invalid inputs"                           +    tx _ _ _ _ = errorstar "PredType.dataConPSpecType.tx called on invalid inputs"     yts'     = tx [] xs ys ts-    ts'      = map ("" ,) cs ++ yts'+    ts'      = map ("" , , mempty) cs ++ yts'     su       = F.mkSubst [(x, F.EVar y) | (x, y) <- zip xs ys]     rt'      = subst su rt  instance PPrint TyConP where-  pprint (TyConP vs ps ls _ _ _) +  pprint (TyConP vs ps ls _ _ _)     = (parens $ hsep (punctuate comma (map pprint vs))) <+>       (parens $ hsep (punctuate comma (map pprint ps))) <+>       (parens $ hsep (punctuate comma (map pprint ls)))@@ -76,7 +76,7 @@  show = showpp -- showSDoc . ppr  instance PPrint DataConP where-  pprint (DataConP _ vs ps ls cs yts t)+  pprint (DataConP _ vs ps ls cs yts t _)      = (parens $ hsep (punctuate comma (map pprint vs))) <+>        (parens $ hsep (punctuate comma (map pprint ps))) <+>        (parens $ hsep (punctuate comma (map pprint ls))) <+>@@ -87,51 +87,54 @@ instance Show DataConP where   show = showpp -dataConTy m (TyVarTy v)            +dataConTy m (TyVarTy v)   = M.lookupDefault (rVar v) (RTV v) m-dataConTy m (FunTy t1 t2)          +dataConTy m (FunTy t1 t2)   = rFun dummySymbol (dataConTy m t1) (dataConTy m t2)-dataConTy m (ForAllTy α t)          +dataConTy m (ForAllTy α t)   = RAllT (rTyVar α) (dataConTy m t)-dataConTy m (TyConApp c ts)        +dataConTy m (TyConApp c ts)   = rApp c (dataConTy m <$> ts) [] mempty dataConTy _ _   = error "ofTypePAppTy"- + ---------------------------------------------------------------------------- ----- Interface: Replace Predicate With Uninterprented Function Symbol ----- ---------------------------------------------------------------------------- -replacePredsWithRefs (p, r) (U (Reft(v, rs)) (Pr ps) s) -  = U (Reft (v, rs ++ rs')) (Pr ps2) s-  where rs'              = r . (v,) . pargs <$> ps1-        (ps1, ps2)       = partition (==p) ps+replacePredsWithRefs (p, r) (U (Reft(v, Refa rs)) (Pr ps) s)+  = U (Reft (v, Refa rs'')) (Pr ps2) s+  where+    rs''             = mconcat $ rs : rs'+    rs'              = r . (v,) . pargs <$> ps1+    (ps1, ps2)       = partition (== p) ps -pVartoRConc p (v, args) | length args == length (pargs p) -  = RConc $ pApp (pname p) $ EVar v:(thd3 <$> args)+pVartoRConc p (v, args) | length args == length (pargs p)+  = pApp (pname p) $ EVar v : (thd3 <$> args)  pVartoRConc p (v, args)-  = RConc $ pApp (pname p) $ EVar v : args'-  where args' = (thd3 <$> args) ++ (drop (length args) (thd3 <$> pargs p))+  = pApp (pname p) $ EVar v : args'+  where+    args' = (thd3 <$> args) ++ (drop (length args) (thd3 <$> pargs p))  ----------------------------------------------------------------------- -- | @pvarRType π@ returns a trivial @RType@ corresponding to the --   function signature for a @PVar@ @π@. For example, if --      @π :: T1 -> T2 -> T3 -> Prop@ --   then @pvarRType π@ returns an @RType@ with an @RTycon@ called---   @predRTyCon@ `RApp predRTyCon [T1, T2, T3]` +--   @predRTyCon@ `RApp predRTyCon [T1, T2, T3]` ----------------------------------------------------------------------- pvarRType :: (PPrint r, Reftable r) => PVar RSort -> RRType r ----------------------------------------------------------------------- pvarRType (PV _ k {- (PVProp τ) -} _ args) = rpredType k (fst3 <$> args) -- (ty:tys)   -- where-  --   ty  = uRTypeGen τ +  --   ty  = uRTypeGen τ   --   tys = uRTypeGen . fst3 <$> args-         + -- rpredType    :: (PPrint r, Reftable r) => PVKind (RRType r) -> [RRType r] -> RRType r rpredType (PVProp t) ts = RApp predRTyCon  (uRTypeGen <$> t : ts) [] mempty-rpredType PVHProp    ts = RApp wpredRTyCon (uRTypeGen <$>     ts) [] mempty  +rpredType PVHProp    ts = RApp wpredRTyCon (uRTypeGen <$>     ts) [] mempty  predRTyCon   :: RTyCon predRTyCon   = symbolRTyCon predName@@ -149,12 +152,12 @@ --   predicate with a concrete Ref, that is either an `RProp` or `RHProp` --   type. The substitution is invoked to obtain the `SpecType` resulting --   at /predicate application/ sites in 'Language.Haskell.Liquid.Constraint'.---   The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`. +--   The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`. --   That is, there are no further _quantified_ `PVar` in the target. --------------------------------------------------------------------------------------replacePreds                 :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType +replacePreds                 :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType --------------------------------------------------------------------------------------replacePreds msg             = foldl' go +replacePreds msg             = foldl' go   where     go z (π, t@(RProp _ _)) = substPred msg   (π, t)     z     go _ (_, RPropP _ _)    = error "replacePreds on RPropP"@@ -164,8 +167,8 @@ -- instance SubsTy RPVar (Ref RReft SpecType) SpecType where --   subt (pv, r) t = replacePreds "replacePred" t (pv, r) --- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType --- replacePreds msg       = foldl' go +-- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType+-- replacePreds msg       = foldl' go --   where go z (π, RProp t) = substPred msg   (π, t)     z --         go z (π, RPropP r) = replacePVarReft (π, r) <$> z @@ -179,10 +182,10 @@   | otherwise                   = t   where     (r2', πs)                   = splitRPvar π r2-    isPredInReft                = not $ null πs +    isPredInReft                = not $ null πs  substPred msg su@(π, _ ) (RApp c ts rs r)-  | null πs                     = t' +  | null πs                     = t'   | otherwise                   = substRCon msg su t' πs r2'   where     t'                          = RApp c (substPred msg su <$> ts) (substPredP msg su <$> rs) r@@ -190,11 +193,11 @@  substPred msg (p, tp) (RAllP (q@(PV _ _ _ _)) t)   | p /= q                      = RAllP q $ substPred msg (p, tp) t-  | otherwise                   = RAllP q t +  | otherwise                   = RAllP q t  substPred msg su (RAllT a t)    = RAllT a (substPred msg su t) -substPred msg su@(π,_ ) (RFun x t t' r) +substPred msg su@(π,_ ) (RFun x t t' r)   | null πs                     = RFun x (substPred msg su t) (substPred msg su t') r   | otherwise                   = {-meetListWithPSubs πs πt -}(RFun x t t' r')   where (r', πs)                = splitRPvar π r@@ -221,19 +224,19 @@  substRCon msg su t _ _        = errorstar $ msg ++ " substRCon " ++ showpp (su, t) -substPredP msg su@(p, RProp ss _) (RProp s t)       +substPredP msg su@(p, RProp ss _) (RProp s t)   = RProp ss' $ substPred (msg ++ ": substPredP") su t  where    ss' = drop n ss ++  s    n   = length ss - length (freeArgsPs p t) -substPredP _ _  (RHProp _ _)       +substPredP _ _  (RHProp _ _)   = errorstar "TODO:EFFECTS:substPredP" -substPredP _ su p@(RPropP _ _) +substPredP _ su p@(RPropP _ _)   = errorstar ("PredType.substPredP1 called on invalid inputs" ++ showpp (su, p)) -substPredP _ su p +substPredP _ su p   = errorstar ("PredType.substPredP called on invalid inputs" ++ showpp (su, p))  @@ -241,34 +244,34 @@   where     (epvs, pvs')               = partition (uPVar pv ==) pvs -freeArgsPs p (RVar _ r) +freeArgsPs p (RVar _ r)   = freeArgsPsRef p r-freeArgsPs p (RFun _ t1 t2 r) +freeArgsPs p (RFun _ t1 t2 r)   = nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs p (RAllT _ t)-  = freeArgsPs p t +  = freeArgsPs p t freeArgsPs p (RAllS _ t)-  = freeArgsPs p t +  = freeArgsPs p t freeArgsPs p (RAllP p' t)   | p == p'   = []-  | otherwise = freeArgsPs p t -freeArgsPs p (RApp _ ts _ r) +  | otherwise = freeArgsPs p t+freeArgsPs p (RApp _ ts _ r)   = nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts-freeArgsPs p (RAllE _ t1 t2) -  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2 -freeArgsPs p (REx _ t1 t2) -  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2 -freeArgsPs p (RAppTy t1 t2 r) +freeArgsPs p (RAllE _ t1 t2)+  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (REx _ t1 t2)+  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (RAppTy t1 t2 r)   = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs _ (RExprArg _)              +freeArgsPs _ (RExprArg _)   = [] freeArgsPs p (RHole r)   = freeArgsPsRef p r freeArgsPs p (RRTy env r _ t)-  = nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t   +  = nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t  freeArgsPsRef p (U _ (Pr ps) _) = [x | (_, x, w) <- (concatMap pargs ps'),  (EVar x) == w]-  where +  where    ps' = f <$> filter (uPVar p ==) ps    f q = q {pargs = pargs q ++ drop (length (pargs q)) (pargs $ uPVar p)} @@ -281,14 +284,14 @@   = r2 `meet` r1   | all (\(_, x, EVar y) -> x /= y) (pargs π)   = r2 `meet` (subst su r1)-  | otherwise +  | otherwise   = errorstar $ "PredType.meetListWithPSub partial application to " ++ showpp π-  where +  where     su  = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]  meetListWithPSubRef ss (RProp s1 r1) (RProp s2 r2) π   | all (\(_, x, EVar y) -> x == y) (pargs π)-  = RProp s1 $ r2 `meet` r1      +  = RProp s1 $ r2 `meet` r1   | all (\(_, x, EVar y) -> x /= y) (pargs π)   = RProp s2 $ r2 `meet` (subst su r1)   | otherwise@@ -300,14 +303,14 @@ ---------------------------------------------------------------------------- -- | Interface: Modified CoreSyn.exprType due to predApp ------------------- -----------------------------------------------------------------------------predType   :: Type +predType   :: Type predType   = symbolType predName  wpredName, predName   :: Symbol predName   = "Pred" wpredName  = "WPred" -symbolType = TyVarTy . symbolTyVar +symbolType = TyVarTy . symbolTyVar   substParg :: Functor f => (Symbol, F.Expr) -> f Predicate -> f Predicate@@ -326,7 +329,7 @@   where ptycon = fApp (Left predFTyCon) $ FVar <$> [0..n-1]         args   = FVar <$> [n..(2*n-1)]         bSort  = FApp boolFTyCon []- + wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]  predFTyCon = symbolFTycon $ dummyLoc predName
src/Language/Haskell/Liquid/PrettyPrint.hs view
@@ -28,7 +28,7 @@ import HscTypes                         (SourceError) import SrcLoc                           -- (RealSrcSpan, SrcSpan (..)) import GHC                              (Name, Class)-import VarEnv                           (emptyTidyEnv)+--import VarEnv                           (emptyTidyEnv) import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.GhcMisc import Text.PrettyPrint.HughesPJ@@ -39,6 +39,7 @@ import TypeRep          hiding (maybeParen, pprArrowChain)   import Text.Parsec.Error (ParseError, errorMessages, showErrorMessages) import Var              (Var)+import TyCon            (TyCon) import Control.Applicative ((<$>)) import Data.Maybe   (fromMaybe) import Data.List    (sort, sortBy)@@ -79,8 +80,11 @@ instance PPrint Name where   pprint = pprDoc  +instance PPrint TyCon where+  pprint = pprDoc+ instance PPrint Type where-  pprint = pprDoc . tidyType emptyTidyEnv+  pprint = pprDoc -- . tidyType emptyTidyEnv -- WHY WOULD YOU DO THIS???  instance PPrint Class where   pprint = pprDoc@@ -122,8 +126,8 @@   = ppr_forall bb p t ppr_rtype _ _ (RVar a r)            = ppTy r $ pprint a-ppr_rtype bb p (RFun x t t' _)  -  = pprArrowChain p $ ppr_dbind bb FunPrec x t : ppr_fun_tail bb t'+ppr_rtype bb p t@(RFun _ _ _ _)+  = maybeParen p FunPrec $ ppr_rty_fun bb empty t ppr_rtype bb p (RApp c [t] rs r)   | isList c    = ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb rs@@ -148,7 +152,7 @@   = braces $ pprint e ppr_rtype bb p (RAppTy t t' r)   = ppTy r $ ppr_rtype bb p t <+> ppr_rtype bb p t'-ppr_rtype bb p (RRTy [(_, e)] _ OCons t)         +ppr_rtype bb p (RRTy e _ OCons t)            = sep [braces (ppr_rsubtype bb p e) <+> "=>", ppr_rtype bb p t] ppr_rtype bb p (RRTy e r o t)            = sep [ppp (pprint o <+> ppe <+> pprint r), ppr_rtype bb p t]@@ -158,12 +162,13 @@   = ppTy r $ text "_"  -ppr_rsubtype bb p e = pprint_env <+> text "|-" <+> ppr_rtype bb p tl <+> "<:" <+> ppr_rtype bb p tr+ppr_rsubtype bb p e +  = pprint_env <+> text "|-" <+> ppr_rtype bb p tl <+> "<:" <+> ppr_rtype bb p tr   where-    trep = toRTypeRep e-    tr   = ty_res trep-    tl   = last $ ty_args trep-    env  = zip (init $ ty_binds trep) (init $ ty_args trep)+    (el, r)  = (init e,  last e)+    (env, l) = (init el, last el)+    tr   = snd $ r+    tl   = snd $ l     pprint_bind (x, t) = pprint x <+> colon <> colon <+> ppr_rtype bb p t      pprint_env         = hsep $ punctuate comma (pprint_bind <$> env) @@ -181,13 +186,6 @@ ppSpine (RRTy _ _ _ _)   = text "RRTy"  -- | From GHC: TypeRep --- pprArrowChain p [a,b,c]  generates   a -> b -> c-pprArrowChain :: Prec -> [Doc] -> Doc-pprArrowChain _ []         = empty-pprArrowChain p (arg:args) = maybeParen p FunPrec $-                             sep [arg, sep (map (arrow <+>) args)]---- | From GHC: TypeRep  maybeParen :: Prec -> Prec -> Doc -> Doc maybeParen ctxt_prec inner_prec pretty   | ctxt_prec < inner_prec = pretty@@ -220,11 +218,15 @@   | otherwise   = pprint x <> colon <> ppr_rtype bb p t --- ppr_fun_tail :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> RType p c tv r -> [Doc]-ppr_fun_tail bb (RFun b t t' _)  -  = (ppr_dbind bb FunPrec b t) : (ppr_fun_tail bb t')-ppr_fun_tail bb t-  = [ppr_rtype bb TopPrec t]++ppr_rty_fun bb prefix t+  = prefix <+> ppr_rty_fun' bb t++ppr_rty_fun' bb (RFun b t t' _)+  = ppr_dbind bb FunPrec b t <+> ppr_rty_fun bb arrow t'+ppr_rty_fun' bb t+  = ppr_rtype bb TopPrec t+  -- ppr_forall :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc ppr_forall bb p t
src/Language/Haskell/Liquid/Qualifier.hs view
@@ -16,7 +16,7 @@ import Data.List                (delete, nub) import Data.Maybe               (fromMaybe) import qualified Data.HashSet as S-import Data.Bifunctor           (second) +import Data.Bifunctor           (second)  ----------------------------------------------------------------------------------- specificationQualifiers :: Int -> GhcInfo -> [Qualifier]@@ -31,24 +31,24 @@     ]  -- GRAVEYARD: scraping quals from imports kills the system with too much crap--- specificationQualifiers info = {- filter okQual -} qs +-- specificationQualifiers info = {- filter okQual -} qs --   where---     qs                       = concatMap refTypeQualifiers ts ---     refTypeQualifiers        = refTypeQuals $ tcEmbeds spc ---     ts                       = val <$> t1s ++ t2s ---     t1s                      = [t | (x, t) <- tySigs spc, x `S.member` definedVars] +--     qs                       = concatMap refTypeQualifiers ts+--     refTypeQualifiers        = refTypeQuals $ tcEmbeds spc+--     ts                       = val <$> t1s ++ t2s+--     t1s                      = [t | (x, t) <- tySigs spc, x `S.member` definedVars] --     t2s                      = [] -- [t | (_, t) <- ctor spc                            ] --     definedVars              = S.fromList $ defVars info --     spc                      = spec info--- --- okQual                       = not . any isPred . map snd . q_params +--+-- okQual                       = not . any isPred . map snd . q_params --   where---     isPred (FApp tc _)       = tc == stringFTycon "Pred" +--     isPred (FApp tc _)       = tc == stringFTycon "Pred" --     isPred _                 = False  -refTypeQuals l tce t  = quals ++ pAppQuals l tce preds quals -  where +refTypeQuals l tce t  = quals ++ pAppQuals l tce preds quals+  where     quals             = refTypeQuals' l tce t     preds             = filter isPropPV $ ty_preds $ toRTypeRep t @@ -56,15 +56,15 @@   where     mkE s             = concatMap (expressionsOfSort (rTypeSort tce s)) qs -expressionsOfSort sort (Q _ pars (PAtom Eq (EVar v) e2) _) +expressionsOfSort sort (Q _ pars (PAtom Eq (EVar v) e2) _)   | (v, sort) `elem` pars   = [(filter (/=(v, sort)) pars, e2)] -expressionsOfSort _ _  -  = [] +expressionsOfSort _ _+  = []  pAppQual l tce p args (v, expr) =  Q "Auto" freeVars pred l-  where +  where     freeVars                  = (vv, tyvv) : (predv, typred) : args     pred                      = pApp predv $ EVar vv:predArgs     vv                        = "v"@@ -72,23 +72,23 @@     tyvv                      = rTypeSort tce $ pvType p     typred                    = rTypeSort tce (pvarRType p :: RSort)     predArgs                  = mkexpr <$> (snd3 <$> pargs p)-    mkexpr x                  = if x == v then expr else EVar x +    mkexpr x                  = if x == v then expr else EVar x --- refTypeQuals :: SpecType -> [Qualifier] +-- refTypeQuals :: SpecType -> [Qualifier] refTypeQuals' l tce t0        = go emptySEnv t0-  where -    go γ t@(RVar _ _)         = refTopQuals l tce t0 γ t     -    go γ (RAllT _ t)          = go γ t -    go γ (RAllP _ t)          = go γ t +  where+    go γ t@(RVar _ _)         = refTopQuals l tce t0 γ t+    go γ (RAllT _ t)          = go γ t+    go γ (RAllP _ t)          = go γ t     go γ t@(RAppTy t1 t2 _)   = go γ t1 ++ go γ t2 ++ refTopQuals l tce t0 γ t-    go γ (RFun x t t' _)      = (go γ t) +    go γ (RFun x t t' _)      = (go γ t)                                 ++ (go (insertSEnv x (rTypeSort tce t) γ) t')-    go γ t@(RApp c ts rs _)   = (refTopQuals l tce t0 γ t) -                                ++ concatMap (go (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ)) ts -                                ++ goRefs c (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ) rs -    go γ (RAllE x t t')       = (go γ t) +    go γ t@(RApp c ts rs _)   = (refTopQuals l tce t0 γ t)+                                ++ concatMap (go (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ)) ts+                                ++ goRefs c (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ) rs+    go γ (RAllE x t t')       = (go γ t)                                 ++ (go (insertSEnv x (rTypeSort tce t) γ) t')-    go γ (REx x t t')         = (go γ t) +    go γ (REx x t t')         = (go γ t)                                 ++ (go (insertSEnv x (rTypeSort tce t) γ) t')     go _ _                    = []     goRefs c g rs             = concat $ zipWith (goRef g) rs (rTyConPVs c)@@ -97,39 +97,37 @@     goRef _ (RHProp _ _)  _   = errorstar "TODO: EFFECTS"     insertsSEnv               = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ) -refTopQuals l tce t0 γ t -  = [ mkQual l t0 γ v so pa  | let (RR so (Reft (v, ras))) = rTypeSortedReft tce t -                             , RConc p                    <- ras                 -                             , pa                         <- atoms p+refTopQuals l tce t0 γ t+  = [ mkQual l t0 γ v so pa  | let (RR so (Reft (v, ra))) = rTypeSortedReft tce t+                             , pa                        <- conjuncts $ raPred ra+                             , not $ isHole pa     ] ++     [ mkPQual l tce t0 γ s e | let (U _ (Pr ps) _) = fromMaybe (msg t) $ stripRTypeBase t-                             , p <- (findPVar (ty_preds $ toRTypeRep t0)) <$> ps+                             , p <- findPVar (ty_preds $ toRTypeRep t0) <$> ps                              , (s, _, e) <- pargs p-    ] -    where +    ]+    where       msg t = errorstar $ "Qualifier.refTopQuals: no typebase" ++ showpp t  mkPQual l tce t0 γ t e = mkQual l t0 γ' v so pa-  where +  where     v                  = "vv"     so                 = rTypeSort tce t     γ'                 = insertSEnv v so γ-    pa                 = PAtom Eq (EVar v) e   +    pa                 = PAtom Eq (EVar v) e -mkQual l t0 γ v so p   = Q "Auto" ((v, so) : yts) p' l -  where +mkQual l t0 γ v so p   = Q "Auto" ((v, so) : yts) p' l+  where     yts                = [(y, lookupSort t0 x γ) | (x, y) <- xys ]     p'                 = subst (mkSubst (second EVar <$> xys)) p     xys                = zipWith (\x i -> (x, symbol ("~A" ++ show i))) xs [0..]     xs                 = delete v $ orderedFreeVars γ p -lookupSort t0 x γ  = fromMaybe (errorstar msg) $ lookupSEnv x γ -  where +lookupSort t0 x γ  = fromMaybe (errorstar msg) $ lookupSEnv x γ+  where     msg            = "Unknown freeVar " ++ show x ++ " in specification " ++ show t0 -orderedFreeVars γ = nub . filter (`memberSEnv` γ) . syms --atoms (PAnd ps)   = concatMap atoms ps-atoms p           = [p]-+orderedFreeVars γ = nub . filter (`memberSEnv` γ) . syms +-- atoms (PAnd ps)   = concatMap atoms ps+-- atoms p           = [p]
+ src/Language/Haskell/Liquid/RefSplit.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Haskell.Liquid.RefSplit (++	splitXRelatedRefs++	) where++import Control.Applicative+import Data.List (partition)+import Text.PrettyPrint.HughesPJ++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.PrettyPrint ()++import Language.Fixpoint.Types +import Language.Fixpoint.Misc ++splitXRelatedRefs :: Symbol -> SpecType -> (SpecType, SpecType)+splitXRelatedRefs x t = splitRType x t+   +++splitRType f (RVar a r) = (RVar a r1, RVar a r2)+  where+  	(r1, r2) = splitRef f r++splitRType f (RFun x tx t r) = (RFun x tx1 t1 r1, RFun x tx2 t2 r2) +  where+  	(tx1, tx2) = splitRType f tx+  	(t1,  t2)  = splitRType f t+  	(r1,  r2)  = splitRef   f r++splitRType f (RAllT v t) = (RAllT v t1, RAllT v t2)+  where+  	(t1, t2) = splitRType f t ++splitRType f (RAllP p t) = (RAllP p t1, RAllP p t2)+  where+  	(t1, t2) = splitRType f t++splitRType f (RAllS s t) = (RAllS s t1, RAllS s t2)+  where+  	(t1, t2) = splitRType f t+++splitRType f (RApp c ts rs r) = (RApp c ts1 rs1 r1, RApp c ts2 rs2 r2)+  where+  	(ts1, ts2) = unzip (splitRType f <$> ts)+  	(rs1, rs2) = unzip (splitUReft f <$> rs)+  	(r1,  r2)  = splitRef f r ++splitRType f (RAllE x tx t) = (RAllE x tx1 t1, RAllE x tx2 t2)+  where+  	(tx1, tx2) = splitRType f tx+  	(t1, t2)   = splitRType f t++splitRType f (REx x tx t) = (REx x tx1 t1, REx x tx2 t2)+  where+  	(tx1, tx2) = splitRType f tx+  	(t1, t2)   = splitRType f t++splitRType _ (RExprArg e) = (RExprArg e, RExprArg e)++splitRType f (RAppTy tx t r) = (RAppTy tx1 t1 r1, RAppTy tx2 t2 r2)+  where+  	(tx1, tx2) = splitRType f tx+  	(t1,  t2)  = splitRType f t+  	(r1,  r2)  = splitRef   f r++splitRType f (RRTy xs r o t) = (RRTy xs1 r1 o t1, RRTy xs2 r2 o t2)+  where+  	(xs1, xs2) = unzip (go <$> xs)+  	(r1, r2) = splitRef   f r +  	(t1, t2) = splitRType f t++  	go (x, t) = let (t1, t2) = splitRType f t in ((x,t1), (x, t2))+++splitRType f (RHole r) = (RHole r1, RHole r2)+  where+  	(r1, r2) = splitRef f r ++splitUReft :: Symbol -> RTProp c tv (UReft Reft) -> (RTProp c tv (UReft Reft), RTProp c tv (UReft Reft))+splitUReft x (RPropP xs r) = (RPropP xs r1, RPropP xs r2)+  where +  	(r1, r2) = splitRef x r++splitUReft x (RProp xs t) = (RProp xs t1, RProp xs t2)+  where +  	(t1, t2) = splitRType x t++splitUReft _ (RHProp xs _) = (RHProp xs w1, RHProp xs w2)+  where +  	(w1, w2) = error "TODO: RefSplit.splitUReft"++splitRef f (U r p s) = (U r1 p1 s, U r2 p2 s)+	where+		(r1, r2) = splitReft f r +		(p1, p2) = splitPred f p++splitReft f (Reft (v, Refa xs)) = (Reft (v, Refa $ pAnd xs1), Reft (v, Refa $ pAnd xs2))+  where+    (xs1, xs2)       = partition (isFree f) (unPAnd xs)++    unPAnd (PAnd ps) = concatMap unPAnd ps +    unPAnd p         = [p]++splitPred f (Pr ps) = (Pr ps1, Pr ps2)+  where+    (ps1, ps2) = partition g ps+    g p = any (isFree f) (thd3 <$> pargs p) 	+++class IsFree a where+	isFree :: Symbol -> a -> Bool++instance (Subable x) => (IsFree x) where+	isFree x p = x `elem` syms p++instance Show (UReft Reft) where+	 show = render . pprint
src/Language/Haskell/Liquid/RefType.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts          #-} +{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE TypeSynonymInstances      #-}@@ -20,12 +20,12 @@    -- * Functions for lifting Reft-values to Spec-values     uTop, uReft, uRType, uRType', uRTypeGen, uPVar-  -  -- * Applying a solution to a SpecType ++  -- * Applying a solution to a SpecType   , applySolution    -- * Functions for decreasing arguments-  , isDecreasing, makeDecrType+  , isDecreasing, makeDecrType, makeNumEnv   , makeLexRefa    -- * Functions for manipulating `Predicate`s@@ -35,7 +35,7 @@    -- TODO: categorize these!   , ofType, toType-  , rTyVar, rVar, rApp, rEx +  , rTyVar, rVar, rApp, rEx   , symbolRTyVar   , addTyConInfo   -- , expandRApp@@ -45,16 +45,21 @@   , generalize, normalizePds   , subts, subvPredicate, subvUReft   , subsTyVar_meet, subsTyVars_meet, subsTyVar_nomeet, subsTyVars_nomeet-  , dataConSymbol, dataConMsReft, dataConReft  +  , dataConSymbol, dataConMsReft, dataConReft   , classBinds- -  -- * Manipulating Refinements in RTypes ++  -- * Manipulating Refinements in RTypes   , rTypeSortedReft   , rTypeSort   , shiftVV    , mkDataConIdsTy   , mkTyConInfo +++  , strengthenRefTypeGen+  , strengthenDataConType+   ) where  import WwLib@@ -63,18 +68,18 @@ import GHC              hiding (Located) import DataCon import qualified TyCon  as TC-import TypeRep          hiding (maybeParen, pprArrowChain)  +import TypeRep          hiding (maybeParen, pprArrowChain) import Type             (splitFunTys, expandTypeSynonyms, substTyWith, isClassPred)-import TysWiredIn       (listTyCon, intDataCon, trueDataCon, falseDataCon, +import TysWiredIn       (listTyCon, intDataCon, trueDataCon, falseDataCon,                          intTyCon, charTyCon)  import           Data.Monoid      hiding ((<>)) import           Data.Maybe               (fromMaybe, isJust) import           Data.Hashable import qualified Data.HashMap.Strict  as M-import qualified Data.HashSet         as S +import qualified Data.HashSet         as S import qualified Data.List as L-import Control.Applicative  hiding (empty)   +import Control.Applicative  hiding (empty) import Control.DeepSeq import Control.Monad  (void) import Text.Printf@@ -83,41 +88,53 @@ import Language.Haskell.Liquid.PrettyPrint import qualified Language.Fixpoint.Types as F import Language.Fixpoint.Types hiding (shiftVV, Predicate)+import Language.Fixpoint.Visitor (mapKVars) import Language.Haskell.Liquid.Types hiding (R, DataConP (..), sort)  import Language.Haskell.Liquid.Variance  import Language.Haskell.Liquid.Misc import Language.Fixpoint.Misc-import Language.Haskell.Liquid.GhcMisc (typeUniqueString, tvId, showPpr, stringTyVar)+import Language.Haskell.Liquid.GhcMisc (typeUniqueString, tvId, showPpr, stringTyVar, tyConTyVarsDef) import Language.Fixpoint.Names (listConName, tupConName) import Data.List (sort, foldl')  +strengthenDataConType (x, t) = (x, fromRTypeRep trep{ty_res = tres}) +    where +      trep = toRTypeRep t +      tres = ty_res trep `strengthen` U (exprReft expr) mempty mempty+      xs   = ty_binds trep +      as   = ty_vars  trep+      x'   = symbol x +      expr | null xs && null as = EVar x'+           | null xs            = EApp (dummyLoc x') []+           | otherwise          = EApp (dummyLoc x') (EVar <$> xs)+ pdVar v        = Pr [uPVar v]  findPVar :: [PVar (RType c tv ())] -> UsedPVar -> PVar (RType c tv ())-findPVar ps p +findPVar ps p   = PV name ty v (zipWith (\(_, _, e) (t, s, _) -> (t, s, e)) (pargs p) args)-  where PV name ty v args = fromMaybe (msg p) $ L.find ((== pname p) . pname) ps +  where PV name ty v args = fromMaybe (msg p) $ L.find ((== pname p) . pname) ps         msg p = errorstar $ "RefType.findPVar" ++ showpp p ++ "not found"  -- | Various functions for converting vanilla `Reft` to `Spec`  uRType          ::  RType c tv a -> RType c tv (UReft a)-uRType          = fmap uTop +uRType          = fmap uTop -uRType'         ::  RType c tv (UReft a) -> RType c tv a +uRType'         ::  RType c tv (UReft a) -> RType c tv a uRType'         = fmap ur_reft  uRTypeGen       :: Reftable b => RType c tv a -> RType c tv b uRTypeGen       = fmap $ const mempty  uPVar           :: PVar t -> UsedPVar-uPVar           = void -- fmap (const ())+uPVar           = void -uReft           ::  (Symbol, [Refa]) -> UReft Reft -uReft           = uTop . Reft  +uReft           :: (Symbol, Refa) -> UReft Reft+uReft           = uTop . Reft  uTop            ::  r -> UReft r uTop r          = U r mempty mempty@@ -132,8 +149,9 @@ instance ( SubsTy tv (RType c tv ()) (RType c tv ())          , SubsTy tv (RType c tv ()) c          , RefTypable c tv ()-         , RefTypable c tv r +         , RefTypable c tv r          , PPrint (RType c tv r)+         , FreeVar c tv           )         => Monoid (RType c tv r)  where   mempty  = errorstar "mempty: RType"@@ -142,34 +160,38 @@ -- MOVE TO TYPES instance ( SubsTy tv (RType c tv ()) (RType c tv ())          , SubsTy tv (RType c tv ()) c-         , Reftable r +         , Reftable r          , RefTypable c tv ()-         , RefTypable c tv (UReft r)) +         , RefTypable c tv (UReft r))          => Monoid (Ref (RType c tv ()) r (RType c tv (UReft r))) where   mempty      = errorstar "mempty: RType 2"   mappend _ _ = errorstar "mappend: RType 2"-  -instance ( Monoid r, Reftable r, RefTypable b c r, RefTypable b c ()) => Monoid (RTProp b c r) where++instance (SubsTy c (RType b c ()) b, Monoid r, Reftable r, RefTypable b c r, RefTypable b c (), FreeVar b c, SubsTy c (RType b c ()) (RType b c ())) +         => Monoid (RTProp b c r) where   mempty         = errorstar "mempty: RTProp" -  mappend (RPropP s1 r1) (RPropP s2 r2) +  mappend (RPropP s1 r1) (RPropP s2 r2)     | isTauto r1 = RPropP s2 r2     | isTauto r2 = RPropP s1 r1-    | otherwise  = RPropP (s1 ++ s2) $ r1 `meet` r2+    | otherwise  = RPropP s1 $ r1 `meet` +                               (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2)      mappend (RProp s1 t1) (RProp s2 t2)      | isTrivial t1 = RProp s2 t2     | isTrivial t2 = RProp s1 t1-    | otherwise    = RProp (s1 ++ s2) $ t1  `strengthenRefType` t2+    | otherwise    = RProp s1 $ t1  `strengthenRefType` +                                (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2)    mappend _ _ = errorstar "Reftable.mappend on invalid inputs" -instance (Reftable r, RefTypable c tv r, RefTypable c tv ()) => Reftable (RTProp c tv r) where+instance (Reftable r, RefTypable c tv r, RefTypable c tv (), FreeVar c tv, SubsTy tv (RType c tv ()) (RType c tv ()), SubsTy tv (RType c tv ()) c) +    => Reftable (RTProp c tv r) where   isTauto (RPropP _ r) = isTauto r   isTauto (RProp  _ t) = isTrivial t   isTauto (RHProp _ _) = errorstar "RefType: Reftable isTauto in RHProp"-  top (RProp xs t)     = RProp xs $ mapReft top t -  top _                = errorstar "RefType: Reftable top"  +  top (RProp xs t)     = RProp xs $ mapReft top t+  top _                = errorstar "RefType: Reftable top"   ppTy (RPropP _ r) d  = ppTy r d   ppTy (RProp  _ _) _  = errorstar "RefType: Reftable ppTy in RProp"   ppTy (RHProp _ _) _  = errorstar "RefType: Reftable ppTy in RProp"@@ -187,25 +209,25 @@   syms (RPropP ss r)     = (fst <$> ss) ++ syms r   syms (RProp ss t)      = (fst <$> ss) ++ syms t   syms _                 = error "TODO:EFFECTS"-  -  subst su (RPropP ss r) = RPropP (mapSnd (subst su) <$> ss) $ subst su r ++  subst su (RPropP ss r) = RPropP (mapSnd (subst su) <$> ss) $ subst su r   subst su (RProp ss r)  = RProp  (mapSnd (subst su) <$> ss) $ subst su r   subst _  _             = error "TODO:EFFECTS"-  +   substf f (RPropP ss r) = RPropP (mapSnd (substf f) <$> ss) $ substf f r   substf f (RProp  ss r) = RProp  (mapSnd (substf f) <$> ss) $ substf f r   substf _ _             = error "TODO:EFFECTS"   substa f (RPropP ss r) = RPropP (mapSnd (substa f) <$> ss) $ substa f r   substa f (RProp  ss r) = RProp  (mapSnd (substa f) <$> ss) $ substa f r   substa _ _             = error "TODO:EFFECTS"-  + ------------------------------------------------------------------------------- -- | Reftable Instances ------------------------------------------------------- -------------------------------------------------------------------------------  instance (PPrint r, Reftable r) => Reftable (RType RTyCon RTyVar r) where   isTauto     = isTrivial-  ppTy        = errorstar "ppTy RProp Reftable" +  ppTy        = errorstar "ppTy RProp Reftable"   toReft      = errorstar "toReft on RType"   params      = errorstar "params on RType"   bot         = errorstar "bot on RType"@@ -219,14 +241,14 @@  -- MOVE TO TYPES instance Fixpoint String where-  toFix = text +  toFix = text  -- MOVE TO TYPES instance Fixpoint Class where   toFix = text . showPpr  -- MOVE TO TYPES-instance (TyConable c, Reftable r, PPrint r, PPrint c) => RefTypable c Symbol r where+instance (SubsTy Symbol (RType c Symbol ()) c, TyConable c, Reftable r, PPrint r, PPrint c, FreeVar c Symbol, SubsTy Symbol (RType c Symbol ()) (RType c Symbol ())) => RefTypable c Symbol r where --   ppCls   = ppClassSymbol   ppRType = ppr_rtype ppEnv @@ -236,12 +258,12 @@   ppRType = ppr_rtype ppEnv  -- MOVE TO TYPES-class FreeVar a v where +class FreeVar a v where   freeVars :: a -> [v]  -- MOVE TO TYPES instance FreeVar RTyCon RTyVar where-  freeVars = (RTV <$>) . tyConTyVars . rtc_tc+  freeVars = (RTV <$>) . tyConTyVarsDef . rtc_tc  -- MOVE TO TYPES instance FreeVar LocSymbol Symbol where@@ -252,27 +274,31 @@  -- MOVE TO TYPES instance (RefTypable c tv ()) => Eq (RType c tv ()) where-  (==) = eqRSort M.empty +  (==) = eqRSort M.empty -eqRSort m (RAllP _ t) (RAllP _ t') +eqRSort m (RAllP _ t) (RAllP _ t')   = eqRSort m t t'-eqRSort m (RAllS _ t) (RAllS _ t') +eqRSort m (RAllS _ t) (RAllS _ t')   = eqRSort m t t'-eqRSort m (RAllP _ t) t' +eqRSort m (RAllP _ t) t'   = eqRSort m t t' eqRSort m (RAllT a t) (RAllT a' t')   | a == a'   = eqRSort m t t'   | otherwise-  = eqRSort (M.insert a' a m) t t' -eqRSort m (RFun _ t1 t2 _) (RFun _ t1' t2' _) +  = eqRSort (M.insert a' a m) t t'+eqRSort m (RAllT _ t) t'+  = eqRSort m t t'+eqRSort m t (RAllT _ t')+  = eqRSort m t t'+eqRSort m (RFun _ t1 t2 _) (RFun _ t1' t2' _)   = eqRSort m t1 t1' && eqRSort m t2 t2'-eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _) +eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _)   = eqRSort m t1 t1' && eqRSort m t2 t2' eqRSort m (RApp c ts _ _) (RApp c' ts' _ _)   = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts') eqRSort m (RVar a _) (RVar a' _)-  = a == M.lookupDefault a' a' m +  = a == M.lookupDefault a' a' m eqRSort _ (RHole _) _   = True eqRSort _ _         (RHole _)@@ -287,7 +313,7 @@ instance Eq Predicate where   (==) = eqpd -eqpd (Pr vs) (Pr ws) +eqpd (Pr vs) (Pr ws)   = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']     where vs' = sort vs           ws' = sort ws@@ -306,13 +332,13 @@   compare x y = compare (rtc_tc x) (rtc_tc y)  instance Hashable RTyCon where-  hashWithSalt i = hashWithSalt i . rtc_tc  +  hashWithSalt i = hashWithSalt i . rtc_tc  -------------------------------------------------------------------- ---------------------- Helper Functions ---------------------------- -------------------------------------------------------------------- -rVar        = (`RVar` mempty) . RTV +rVar        = (`RVar` mempty) . RTV rTyVar      = RTV  symbolRTyVar = rTyVar . stringTyVar . symbolString@@ -321,21 +347,21 @@   where (t', ps) = nlzP [] t  rPred     = RAllP-rEx xts t = foldr (\(x, tx) t -> REx x tx t) t xts   -rApp c    = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing)) +rEx xts t = foldr (\(x, tx) t -> REx x tx t) t xts+rApp c    = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing))  --- NV TODO : remove this code!!!  addPds ps (RAllT v t) = RAllT v $ addPds ps t addPds ps t           = foldl' (flip rPred) t ps -nlzP ps t@(RVar _ _ ) +nlzP ps t@(RVar _ _ )  = (t, ps)-nlzP ps (RFun b t1 t2 r) +nlzP ps (RFun b t1 t2 r)  = (RFun b t1' t2' r, ps ++ ps1 ++ ps2)   where (t1', ps1) = nlzP [] t1         (t2', ps2) = nlzP [] t2-nlzP ps (RAppTy t1 t2 r) +nlzP ps (RAppTy t1 t2 r)  = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2)   where (t1', ps1) = nlzP [] t1         (t2', ps2) = nlzP [] t2@@ -349,81 +375,128 @@ nlzP ps (RAllP p t)  = (t', [p] ++ ps ++ ps')   where (t', ps') = nlzP [] t-nlzP ps t@(REx _ _ _) - = (t, ps) -nlzP ps t@(RRTy _ _ _ t') +nlzP ps t@(REx _ _ _)+ = (t, ps)+nlzP ps t@(RRTy _ _ _ t')  = (t, ps ++ ps')  where ps' = snd $ nlzP [] t'-nlzP ps t@(RAllE _ _ _) - = (t, ps) +nlzP ps t@(RAllE _ _ _)+ = (t, ps) nlzP _ t  = errorstar $ "RefType.nlzP: cannot handle " ++ show t ++strengthenRefTypeGen, strengthenRefType :: +         ( RefTypable c tv ()+         , RefTypable c tv r +         , PPrint (RType c tv r)+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) c+         ) => RType c tv r -> RType c tv r -> RType c tv r+strengthenRefType_ :: +         ( RefTypable c tv ()+         , RefTypable c tv r +         , PPrint (RType c tv r)+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) c+         ) => (RType c tv r -> RType c tv r -> RType c tv r) +           ->  RType c tv r -> RType c tv r -> RType c tv r+           +strengthenRefTypeGen t1 t2 = strengthenRefType_ f t1 t2+  where+    f (RVar v1 r1) t  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))+    f t (RVar v1 r1)  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))+    f t1 t2           = error $ printf "strengthenRefTypeGen on differently shaped types \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" +                         (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))+ + -- NEWISH: with unifying type variables: causes big problems with TUPLES? --strengthenRefType t1 t2 = maybe (errorstar msg) (strengthenRefType_ t1) (unifyShape t1 t2)---  where msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" +--  where msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" --                 (render t1) (render (toRSort t1)) (render t2) (render (toRSort t2))  -- OLD: without unifying type variables, but checking α-equivalence strengthenRefType t1 t2    | eqt t1 t2 -  = strengthenRefType_ t1 t2+  = strengthenRefType_ (\x _ -> x) t1 t2   | otherwise-  = errorstar msg -  where +  = errorstar msg+  where     eqt t1 t2 = {- render -} toRSort t1 == {- render -} toRSort t2-    msg       = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" +    msg       = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"                   (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2)) -         --- strengthenRefType_ :: RefTypable c tv r => RType c tv r -> RType c tv r -> RType c tv r-strengthenRefType_ (RAllT a1 t1) (RAllT _ t2)-  = RAllT a1 $ strengthenRefType_ t1 t2 -strengthenRefType_ (RAllP p1 t1) (RAllP _ t2)-  = RAllP p1 $ strengthenRefType_ t1 t2+strengthenRefType_ f (RAllT a1 t1) (RAllT a2 t2)+  = RAllT a1 $ strengthenRefType_ f t1 (subsTyVar_meet (a2, toRSort t, t) t2)+  where t = RVar a1 mempty -strengthenRefType_ (RAllS s t1) t2-  = RAllS s $ strengthenRefType_ t1 t2+strengthenRefType_ f (RAllT a t1) t2+  = RAllT a $ strengthenRefType_ f t1 t2 -strengthenRefType_ t1 (RAllS s t2)-  = RAllS s $ strengthenRefType_ t1 t2+strengthenRefType_ f t1 (RAllT a t2)+  = RAllT a $ strengthenRefType_ f t1 t2 -strengthenRefType_ (RAppTy t1 t1' r1) (RAppTy t2 t2' r2) +strengthenRefType_ f (RAllP p1 t1) (RAllP _ t2)+  = RAllP p1 $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllP p t1) t2+  = RAllP p $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllP p t2)+  = RAllP p $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllS s t1) t2+  = RAllS s $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllS s t2)+  = RAllS s $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllE x tx t1) (RAllE y ty t2) | x == y+  = RAllE x (strengthenRefType_ f tx ty) $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllE x tx t1) t2+  = RAllE x tx $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllE x tx t2)+  = RAllE x tx $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAppTy t1 t1' r1) (RAppTy t2 t2' r2)    = RAppTy t t' (r1 `meet` r2)-    where t  = strengthenRefType_ t1 t2-          t' = strengthenRefType_ t1' t2'+    where t  = strengthenRefType_ f t1 t2+          t' = strengthenRefType_ f t1' t2' -strengthenRefType_ (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2) -  = RFun x1 t t' (r1 `meet` r2)-    where t  = strengthenRefType_ t1 t2-          t' = strengthenRefType_ t1' $ subst1 t2' (x2, EVar x1)+strengthenRefType_ f (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2) +  = RFun x2 t t' (r1 `meet` r2)+    where t  = strengthenRefType_ f t1 t2+          t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'  -strengthenRefType_ (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)+strengthenRefType_ f (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)   = RApp tid ts rs (r1 `meet` r2)-    where ts  = zipWith strengthenRefType_ t1s t2s+    where ts  = zipWith (strengthenRefType_ f) t1s t2s           rs  = meets rs1 rs2  -strengthenRefType_ (RVar v1 r1)  (RVar _ r2)+strengthenRefType_ _ (RVar v1 r1)  (RVar v2 r2) | v1 == v2   = RVar v1 (r1 `meet` r2)- -strengthenRefType_ t1 _ -  = t1+strengthenRefType_ f t1 t2  +  = f t1 t2  meets [] rs                 = rs meets rs []                 = rs-meets rs rs' +meets rs rs'   | length rs == length rs' = zipWith meet rs rs'   | otherwise               = errorstar "meets: unbalanced rs"   strengthen :: Reftable r => RType c tv r -> r -> RType c tv r-strengthen (RApp c ts rs r) r'  = RApp c ts rs (r `meet` r') -strengthen (RVar a r) r'        = RVar a       (r `meet` r') +strengthen (RApp c ts rs r) r'  = RApp c ts rs (r `meet` r')+strengthen (RVar a r) r'        = RVar a       (r `meet` r') strengthen (RFun b t1 t2 r) r'  = RFun b t1 t2 (r `meet` r') strengthen (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `meet` r')-strengthen t _                  = t +strengthen t _                  = t   @@ -451,9 +524,9 @@     rs'                        = applyNonNull rs0 (rtPropPV rc pvs) rs     rs0                        = rtPropTop <$> pvs     n                          = length fVs-    fVs                        = tyConTyVars $ rtc_tc rc+    fVs                        = tyConTyVarsDef $ rtc_tc rc     as                         = choosen n ts (rVar <$> fVs)-  +     choosen 0 _ _           = []     choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys     choosen i []     (y:ys) = y:choosen (i-1) [] ys@@ -466,27 +539,27 @@                  PVHProp  -> RProp xts $ mempty                where                  xts      =  pvArgs pv-                 + rtPropPV rc = safeZipWith msg mkRTProp   where     msg     = "appRefts: " ++ showFix rc -mkRTProp pv (RPropP ss r) -  = RProp ss $ (ofRSort $ pvType pv) `strengthen` r  +mkRTProp pv (RPropP ss r)+  = RProp ss $ (ofRSort $ pvType pv) `strengthen` r -mkRTProp pv (RProp ss t) -  | length (pargs pv) == length ss +mkRTProp pv (RProp ss t)+  | length (pargs pv) == length ss   = RProp ss t   | otherwise   = RProp (pvArgs pv) t-    -mkRTProp pv (RHProp ss w) -  | length (pargs pv) == length ss ++mkRTProp pv (RHProp ss w)+  | length (pargs pv) == length ss   = RHProp ss w-  | otherwise          +  | otherwise   = RHProp (pvArgs pv) w -pvArgs pv = [(s, t) | (t, s, _) <- pargs pv]    +pvArgs pv = [(s, t) | (t, s, _) <- pargs pv]   appRTyCon tce tyi rc ts = RTyCon c ps' (rtc_info rc'')@@ -495,29 +568,29 @@     ps'  = subts (zip (RTV <$> αs) ts') <$> rTyConPVs rc'     ts'  = if null ts then rVar <$> βs else toRSort <$> ts     rc'  = M.lookupDefault rc c tyi-    αs   = TC.tyConTyVars $ rtc_tc rc'-    βs   = TC.tyConTyVars c+    αs   = tyConTyVarsDef $ rtc_tc rc'+    βs   = tyConTyVarsDef c     rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc' -isNumeric tce c -  =  fromMaybe (symbolFTycon . dummyLoc $ tyConName (rtc_tc c))-       (M.lookup (rtc_tc c) tce) == intFTyCon+isNumeric tce c+  =  (fromMaybe (symbolFTycon . dummyLoc $ tyConName (rtc_tc c))+       (M.lookup (rtc_tc c) tce) == intFTyCon) -addNumSizeFun c +addNumSizeFun c   = c {rtc_info = (rtc_info c) {sizeFunction = Just EVar} }   generalize :: (RefTypable c tv r) => RType c tv r -> RType c tv r-generalize t = mkUnivs (freeTyVars t) [] [] t -         +generalize t = mkUnivs (freeTyVars t) [] [] t+ freeTyVars (RAllP _ t)     = freeTyVars t freeTyVars (RAllS _ t)     = freeTyVars t freeTyVars (RAllT α t)     = freeTyVars t L.\\ [α]-freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t' +freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t' freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts-freeTyVars (RVar α _)      = [α] -freeTyVars (RAllE _ _ t)   = freeTyVars t-freeTyVars (REx _ _ t)     = freeTyVars t+freeTyVars (RVar α _)      = [α]+freeTyVars (RAllE _ tx t)  = freeTyVars tx `L.union` freeTyVars t+freeTyVars (REx _ tx t)    = freeTyVars tx `L.union` freeTyVars t freeTyVars (RExprArg _)    = [] freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t' freeTyVars (RHole _)       = []@@ -531,12 +604,12 @@ tyClasses (REx _ _ t)     = tyClasses t tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t' tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t'-tyClasses (RApp c ts _ _) -  | Just cl <- tyConClass_maybe $ rtc_tc c -  = [(cl, ts)] -  | otherwise       +tyClasses (RApp c ts _ _)+  | Just cl <- tyConClass_maybe $ rtc_tc c+  = [(cl, ts)]+  | otherwise   = []-tyClasses (RVar _ _)      = [] +tyClasses (RVar _ _)      = [] tyClasses (RRTy _ _ _ t)  = tyClasses t tyClasses (RHole _)       = [] tyClasses t               = errorstar ("RefType.tyClasses cannot handle" ++ show t)@@ -552,7 +625,7 @@   rnf (RHProp _ _) = errorstar "TODO RHProp.rnf"  instance (NFData b, NFData c, NFData e) => NFData (RType b c e) where-  rnf (RVar α r)       = rnf α `seq` rnf r +  rnf (RVar α r)       = rnf α `seq` rnf r   rnf (RAllT α t)      = rnf α `seq` rnf t   rnf (RAllP π t)      = rnf π `seq` rnf t   rnf (RAllS s t)      = rnf s `seq` rnf t@@ -586,7 +659,7 @@  instance PPrint REnv where   pprint (REnv m)  = pprint m- + ------------------------------------------------------------------------------------------ -- TODO: Rewrite subsTyvars with Traversable ------------------------------------------------------------------------------------------@@ -598,20 +671,20 @@ subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats subsTyVar meet        = subsFree meet S.empty -subsFree m s z (RAllS l t)         +subsFree m s z (RAllS l t)   = RAllS l (subsFree m s z t)-subsFree m s z@(α, τ,_) (RAllP π t)         +subsFree m s z@(α, τ,_) (RAllP π t)   = RAllP (subt (α, τ) π) (subsFree m s z t)-subsFree m s z (RAllT α t)         +subsFree m s z (RAllT α t)   = RAllT α $ subsFree m (α `S.insert` s) z t-subsFree m s z@(_, _, _) (RFun x t t' r)       +subsFree m s z@(_, _, _) (RFun x t t' r)   = RFun x (subsFree m s z t) (subsFree m s z t') r-subsFree m s z@(α, τ, _) (RApp c ts rs r)     -  = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) r  +subsFree m s z@(α, τ, _) (RApp c ts rs r)+  = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) r     where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?-subsFree meet s (α', _, t') t@(RVar α r) -  | α == α' && not (α `S.member` s) -  = if meet then t' `strengthen` r else t' +subsFree meet s (α', _, t') t@(RVar α r)+  | α == α' && not (α `S.member` s)+  = if meet then t' `strengthen` r else t'   | otherwise   = t subsFree m s z (RAllE x t t')@@ -620,9 +693,9 @@   = REx x (subsFree m s z t) (subsFree m s z t') subsFree m s z@(_, _, _) (RAppTy t t' r)   = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') r-subsFree _ _ _ t@(RExprArg _)        +subsFree _ _ _ t@(RExprArg _)   = t-subsFree m s z (RRTy e r o t)        +subsFree m s z (RRTy e r o t)   = RRTy (mapSnd (subsFree m s z) <$> e) r o (subsFree m s z t) subsFree _ _ _ t@(RHole _)   = t@@ -638,7 +711,7 @@ mkRApp m s c ts rs r r'   | isFun c, [t1, t2] <- ts   = RFun dummySymbol t1 t2 $ refAppTyToFun r'-  | otherwise +  | otherwise   = subsFrees m s zs $ RApp c ts rs $ r `meet` r' -- (refAppTyToApp r')   where     zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts]@@ -647,18 +720,18 @@   | isTauto r = r   | otherwise = errorstar "RefType.refAppTyToFun" -subsFreeRef m s (α', τ', t')  (RProp ss t) +subsFreeRef m s (α', τ', t')  (RProp ss t)   = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t-subsFreeRef _ _ (α', τ', _) (RPropP ss r) +subsFreeRef _ _ (α', τ', _) (RPropP ss r)   = RPropP (mapSnd (subt (α', τ')) <$> ss) r subsFreeRef _ _ _ (RHProp _ _)-  = errorstar "TODO RHProp.subsFreeRef"  +  = errorstar "TODO RHProp.subsFreeRef"  ------------------------------------------------------------------- ------------------- Type Substitutions ---------------------------- ------------------------------------------------------------------- -subts = flip (foldr subt) +subts = flip (foldr subt)  instance SubsTy tv ty ()   where   subt _ = id@@ -669,11 +742,11 @@ instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where   subt su (PVProp t) = PVProp (subt su t)   subt _   PVHProp   = PVHProp-  + instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where   subt su (PV n t v xts) = PV n (subt su t) v [(subt su t, x, y) | (t,x,y) <- xts] -instance SubsTy RTyVar RSort RTyCon where  +instance SubsTy RTyVar RSort RTyCon where    subt z c = RTyCon tc ps' i      where        tc   = rtc_tc c@@ -681,20 +754,20 @@        i    = rtc_info c  -- NOTE: This DOES NOT substitute at the binders-instance SubsTy RTyVar RSort PrType where   +instance SubsTy RTyVar RSort PrType where   subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) -instance SubsTy RTyVar RSort SpecType where   +instance SubsTy RTyVar RSort SpecType where   subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) -instance SubsTy RTyVar RTyVar SpecType where   +instance SubsTy RTyVar RTyVar SpecType where   subt (α, a) = subt (α, RVar a () :: RSort)  -instance SubsTy RTyVar RSort RSort where   +instance SubsTy RTyVar RSort RSort where   subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) --- Here the "String" is a Bare-TyCon. TODO: wrap in newtype +-- Here the "String" is a Bare-TyCon. TODO: wrap in newtype instance SubsTy Symbol BSort LocSymbol where   subt _ t = t @@ -705,30 +778,30 @@   subt m (RPropP ss p) = RPropP ((mapSnd (subt m)) <$> ss) $ subt m p   subt m (RProp  ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t   subt _ (RHProp _  _) = errorstar "TODO: RHProp.subt"- + subvUReft     :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft subvUReft f (U r p s) = U r (subvPredicate f p) s -subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate +subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate subvPredicate f (Pr pvs) = Pr (f <$> pvs)  --------------------------------------------------------------- -ofType = ofType_ . expandTypeSynonyms +ofType = ofType_ . expandTypeSynonyms -ofType_ (TyVarTy α)     +ofType_ (TyVarTy α)   = rVar α-ofType_ (FunTy τ τ')    -  = rFun dummySymbol (ofType_ τ) (ofType_ τ') -ofType_ (ForAllTy α τ)  -  = RAllT (rTyVar α) $ ofType_ τ  +ofType_ (FunTy τ τ')+  = rFun dummySymbol (ofType_ τ) (ofType_ τ')+ofType_ (ForAllTy α τ)+  = RAllT (rTyVar α) $ ofType_ τ ofType_ (TyConApp c τs)   | Just (αs, τ) <- TC.synTyConDefn_maybe c   = ofType_ $ substTyWith αs τs τ   | otherwise-  = rApp c (ofType_ <$> τs) [] mempty +  = rApp c (ofType_ <$> τs) [] mempty ofType_ (AppTy t1 t2)-  = RAppTy (ofType_ t1) (ofType t2) mempty             +  = RAppTy (ofType_ t1) (ofType t2) mempty ofType_ (LitTy x)   = fromTyLit x   where@@ -748,23 +821,26 @@  -- TODO: turn this into a map lookup? dataConReft ::  DataCon -> [Symbol] -> Reft-dataConReft c [] +dataConReft c []   | c == trueDataCon-  = Reft (vv_, [RConc $ eProp vv_]) +  = predReft $ eProp vv_   | c == falseDataCon-  = Reft (vv_, [RConc $ PNot $ eProp vv_]) -dataConReft c [x] -  | c == intDataCon -  = Reft (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))]) -dataConReft c _ +  = predReft $ PNot $ eProp vv_++dataConReft c [x]+  | c == intDataCon+  = symbolReft x -- OLD (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))])+dataConReft c _   | not $ isBaseDataCon c   = mempty dataConReft c xs-  = Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])-  where dcValue | null xs && null (dataConUnivTyVars c) -                = EVar $ dataConSymbol c-                | otherwise-                = EApp (dummyLoc $ dataConSymbol c) (EVar <$> xs)+  = exprReft dcValue -- OLD Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])+  where+    dcValue+      | null xs && null (dataConUnivTyVars c)+      = EVar $ dataConSymbol c+      | otherwise+      = EApp (dummyLoc $ dataConSymbol c) (eVar <$> xs)  isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c @@ -775,40 +851,45 @@ isBaseTy (ForAllTy _ _)  = False isBaseTy (LitTy _)       = True -vv_ = vv Nothing -dataConMsReft ty ys  = subst su (rTypeReft (ignoreOblig $ ty_res trep)) -  where trep = toRTypeRep ty-        xs   = ty_binds trep-        ts   = ty_args  trep-        su   = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys]+dataConMsReft ty ys  = subst su (rTypeReft (ignoreOblig $ ty_res trep))+  where+    trep = toRTypeRep ty+    xs   = ty_binds trep+    ts   = ty_args  trep+    su   = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys]  --------------------------------------------------------------- ---------------------- Embedding RefTypes --------------------- ------------------------------------------------------------------ TODO: remove toType, generalize typeSort +-- TODO: remove toType, generalize typeSort toType  :: (Reftable r, PPrint r) => RRType r -> Type-toType (RFun _ t t' _)   +toType (RFun _ t t' _)   = FunTy (toType t) (toType t')-toType (RAllT (RTV α) t)      +toType (RAllT (RTV α) t)   = ForAllTy α (toType t) toType (RAllP _ t)   = toType t toType (RAllS _ t)   = toType t-toType (RVar (RTV α) _)        +toType (RVar (RTV α) _)   = TyVarTy α-toType (RApp (RTyCon {rtc_tc = c}) ts _ _)   -  = TyConApp c (toType <$> ts)+toType (RApp (RTyCon {rtc_tc = c}) ts _ _)+  = TyConApp c (toType <$> filter notExprArg ts)+  where+  notExprArg (RExprArg _) = False+  notExprArg _            = True toType (RAllE _ _ t)   = toType t toType (REx _ _ t)   = toType t-toType (RAppTy t t' _)   +toType (RAppTy t (RExprArg _) _)+  = toType t+toType (RAppTy t t' _)   = AppTy (toType t) (toType t') toType t@(RExprArg _)-  = errorstar $ "RefType.toType cannot handle 1: " ++ show t-toType (RRTy _ _ _ t)      +  = errorstar $ "CANNOT HAPPEN: RefType.toType called with: " ++ show t+toType (RRTy _ _ _ t)   = toType t toType t   = errorstar $ "RefType.toType cannot handle: " ++ show t@@ -825,33 +906,36 @@ rTypeSort tce = typeSort tce . toType  --------------------------------------------------------------------------------applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType +applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType --------------------------------------------------------------------------------applySolution = fmap . fmap . mapReft . map . appSolRefa -  where -    appSolRefa _ ra@(RConc _)        = ra -    -- appSolRefa _ p@(RPvar _)  = p  -    appSolRefa s (RKvar k su)        = RConc $ subst su $ M.lookupDefault PTop k s  -    mapReft f (U (Reft (x, zs)) p s) = U (Reft (x, squishRefas $ f zs)) p s+applySolution = fmap . fmap . mapReft . appSolRefa+  where+    mapReft f (U (Reft (x, z)) p s) = U (Reft (x, f z)) p s+-- OLD    appSolRefa _ ra@(RConc _)        = ra+-- OLD    appSolRefa s (RKvar k su)        = RConc $ subst su $ M.lookupDefault PTop k s +appSolRefa s (Refa p) = Refa $ mapKVars f p+  where+    f k               = Just $ M.lookupDefault PTop k s+ ------------------------------------------------------------------------------- shiftVV :: SpecType -> Symbol -> SpecType ------------------------------------------------------------------------------- -shiftVV t@(RApp _ ts _ r) vv' -  = t { rt_args = subst1 ts (rTypeValueVar t, EVar vv') } +shiftVV t@(RApp _ ts _ r) vv'+  = t { rt_args = subst1 ts (rTypeValueVar t, EVar vv') }       { rt_reft = (`F.shiftVV` vv') <$> r } -shiftVV t@(RFun _ _ _ r) vv' +shiftVV t@(RFun _ _ _ r) vv'   = t { rt_reft = (`F.shiftVV` vv') <$> r } -shiftVV t@(RAppTy _ _ r) vv' +shiftVV t@(RAppTy _ _ r) vv'   = t { rt_reft = (`F.shiftVV` vv') <$> r }  shiftVV t@(RVar _ r) vv'   = t { rt_reft = (`F.shiftVV` vv') <$> r } -shiftVV t _ +shiftVV t _   = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t  @@ -861,21 +945,21 @@  -- MOVE TO TYPES instance (Show tv, Show ty) => Show (RTAlias tv ty) where-  show (RTA n as xs t p) = printf "type %s %s %s = %s -- defined at %s" (symbolString n)-                           (L.intercalate " " (show <$> as)) -                           (L.intercalate " " (show <$> xs))-                           (show t) (show p) +  show (RTA n as xs t p _) =+    printf "type %s %s %s = %s -- defined at %s" (symbolString n)+      (L.intercalate " " (show <$> as))+      (L.intercalate " " (show <$> xs))+      (show t) (show p)  ---------------------------------------------------------------- ------------ From Old Fixpoint --------------------------------- ---------------------------------------------------------------- --typeUniqueSymbol :: Type -> Symbol +typeUniqueSymbol :: Type -> Symbol typeUniqueSymbol = symbol . typeUniqueString -typeSort :: TCEmb TyCon -> Type -> Sort -typeSort tce τ@(ForAllTy _ _) +typeSort :: TCEmb TyCon -> Type -> Sort+typeSort tce τ@(ForAllTy _ _)   = typeSortForAll tce τ typeSort tce t@(FunTy _ _)   = typeSortFun tce t@@ -888,16 +972,16 @@  tyConFTyCon tce c    = fromMaybe (symbolFTycon $ dummyLoc $ tyConName c) (M.lookup c tce) -typeSortForAll tce τ +typeSortForAll tce τ   = genSort $ typeSort tce tbody   where genSort (FFunc _ t) = FFunc n (sortSubst su <$> t)         genSort t           = FFunc n [sortSubst su t]-        (as, tbody)         = splitForAllTys τ +        (as, tbody)         = splitForAllTys τ         su                  = M.fromList $ zip sas (FVar <$>  [0..])         sas                 = (typeUniqueSymbol . TyVarTy) <$> as-        n                   = length as +        n                   = length as -tyConName c +tyConName c   | listTyCon == c    = listConName   | TC.isTupleTyCon c = tupConName   | otherwise         = symbol c@@ -914,29 +998,29 @@  mkDataConIdsTy (dc, t) = [expandProductType id t | id <- dataConImplicitIds dc] -expandProductType x t +expandProductType x t   | ofType (varType x) == toRSort t = (x, t)   | otherwise                       = (x, t')-     where t'         = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}+     where t'         = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_refts = rs'}            τs         = fst $ splitFunTys $ toType t            trep       = toRTypeRep t-           (xs', ts') = unzip $ concatMap mkProductTy $ zip3 τs (ty_binds trep) (ty_args trep)-          -mkProductTy (τ, x, t) = maybe [(x, t)] f $ deepSplitProductType_maybe menv τ-  where f    = ((<$>) ((,) dummySymbol . ofType)) . third4+           (xs', ts', rs') = unzip3 $ concatMap mkProductTy $ zip4 τs (ty_binds trep) (ty_args trep) (ty_refts trep)++mkProductTy (τ, x, t, r) = maybe [(x, t, r)] f $ deepSplitProductType_maybe menv τ+  where f    = ((<$>) ((dummySymbol, , mempty) . ofType)) . third4         menv = (emptyFamInstEnv, emptyFamInstEnv)-          + ----------------------------------------------------------------------------------------- -- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum) ----------------------------------------------------------------------------------------- -classBinds (RApp c ts _ _) +classBinds (RApp c ts _ _)    | isFracCls c-   = [(rTyVarSymbol a, trueSortedReft FReal) | (RVar a _) <- ts]+   = [(rTyVarSymbol a, trueSortedReft FFrac) | (RVar a _) <- ts]    | isNumCls c    = [(rTyVarSymbol a, trueSortedReft FNum) | (RVar a _) <- ts]-classBinds _       -  = [] +classBinds _+  = []  rTyVarSymbol (RTV α) = typeUniqueSymbol $ TyVarTy α @@ -944,62 +1028,78 @@ --------------------------- Termination Predicates -------------------------------------- ----------------------------------------------------------------------------------------- -isDecreasing (RApp c _ _ _) -  = isJust (sizeFunction (rtc_info c)) -isDecreasing _ +makeNumEnv = concatMap go +  where+    go (RApp c ts _ _) | isNumCls c || isFracCls c = [ a | (RVar a _) <- ts]+    go _ = []++isDecreasing _ (RApp c _ _ _)+  = isJust (sizeFunction (rtc_info c))+isDecreasing cenv (RVar v _)+  = v `elem` cenv +isDecreasing _ _    = False  makeDecrType = mkDType [] [] -mkDType xvs acc [(v, (x, t@(RApp c _ _ _)))] +mkDType xvs acc [(v, (x, t))]   = (x, ) $ t `strengthen` tr-  where tr     = uTop $ Reft (vv, [RConc $ pOr (r:acc)])-        r      = cmpLexRef xvs (v', vv, f)-        v'     = symbol v-        Just f = sizeFunction $ rtc_info c-        vv     = "vvRec"+  where+    tr = uTop $ Reft (vv, Refa $ pOr (r:acc))+    r  = cmpLexRef xvs (v', vv, f)+    v' = symbol v+    f  = mkDecrFun t +    vv = "vvRec" -mkDType xvs acc ((v, (x, (RApp c _ _ _))):vxts)+mkDType xvs acc ((v, (x, t)):vxts)   = mkDType ((v', x, f):xvs) (r:acc) vxts-  where r      = cmpLexRef xvs  (v', x, f)-        v'     = symbol v-        Just f = sizeFunction $ rtc_info c+  where +    r  = cmpLexRef xvs  (v', x, f)+    v' = symbol v+    f  = mkDecrFun t++ mkDType _ _ _   = errorstar "RefType.mkDType called on invalid input" +mkDecrFun (RApp c _ _ _) | Just f <- sizeFunction $ rtc_info c = f +mkDecrFun (RVar _ _)     = EVar +mkDecrFun _              = errorstar "RefType.mkDecrFun called on invalid input"+ cmpLexRef vxs (v, x, g)   = pAnd $  (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero)          :  [PAtom Eq (f y) (f z) | (y, z, f) <- vxs]          ++ [PAtom Ge (f y) zero  | (y, _, f) <- vxs]   where zero = ECon $ I 0 -makeLexRefa es' es = uTop $ Reft (vv, [RConc $ PIff (PBexp $ EVar vv) $ pOr rs])-  where rs = makeLexReft [] [] es es'-        vv = "vvRec"+makeLexRefa es' es = uTop $ Reft (vv, Refa $ PIff (PBexp $ EVar vv) $ pOr rs)+  where+    rs = makeLexReft [] [] es es'+    vv = "vvRec" -makeLexReft _ acc [] [] +makeLexReft _ acc [] []   = acc-makeLexReft old acc (e:es) (e':es') +makeLexReft old acc (e:es) (e':es')   = makeLexReft ((e,e'):old) (r:acc) es es'-  where -    r    = pAnd $  (PAtom Lt e' e) +  where+    r    = pAnd $  (PAtom Lt e' e)                 :  (PAtom Ge e' zero)-                :  [PAtom Eq o' o    | (o,o') <- old] -                ++ [PAtom Ge o' zero | (_,o') <- old] +                :  [PAtom Eq o' o    | (o,o') <- old]+                ++ [PAtom Ge o' zero | (_,o') <- old]     zero = ECon $ I 0 makeLexReft _ _ _ _-  = errorstar "RefType.makeLexReft on invalid input"    +  = errorstar "RefType.makeLexReft on invalid input"  -------------------------------------------------------------------------------  mkTyConInfo :: TyCon -> VarianceInfo -> VarianceInfo -> (Maybe (Symbol -> Expr)) -> TyConInfo -mkTyConInfo c usertyvar userprvariance f        +mkTyConInfo c usertyvar userprvariance f   = TyConInfo (if null usertyvar then defaulttyvar else usertyvar) userprvariance f-  where +  where         defaulttyvar      = varSignToVariance <$> [0 ..n] -        varSignToVariance i = case filter (\p -> fst p == i) varsigns of +        varSignToVariance i = case filter (\p -> fst p == i) varsigns of                                 []       -> Invariant                                 [(_, b)] -> if b then Covariant else Contravariant                                 _        -> Bivariant@@ -1016,8 +1116,7 @@         go _ _   (LitTy _)       = []          varLookup v m = fromMaybe (errmsg v) $ L.lookup v m-        tyvars        = TC.tyConTyVars c+        tyvars        = tyConTyVarsDef c         n             = (TC.tyConArity c) - 1         errmsg v      = error $ "GhcMisc.getTyConInfo: var not found" ++ showPpr v         dindex        = -1-
src/Language/Haskell/Liquid/Simplify.hs view
@@ -1,32 +1,43 @@ module Language.Haskell.Liquid.Simplify (simplifyBounds) where  import Language.Haskell.Liquid.Types- import Language.Fixpoint.Types--import Control.Applicative                 ((<$>))--simplifyLen = 5+import Language.Fixpoint.Visitor+-- import Control.Applicative                 ((<$>))+import Data.Monoid  simplifyBounds :: SpecType -> SpecType-simplifyBounds = fmap go +simplifyBounds = fmap go   where-  	go x = x{ur_reft = go' $ ur_reft x}+    go x       = x { ur_reft = go' $ ur_reft x }+    -- OLD go' (Reft (v, rs)) = Reft(v, filter (not . isBoundLike) rs)+    go' (Reft (v, Refa p)) = Reft(v, Refa $ dropBoundLike p) -  	go' (Reft (v, rs)) = Reft(v, filter (not . isBoundLike) rs)+dropBoundLike :: Pred -> Pred+dropBoundLike p+  | isKvar p          = p+  | isBoundLikePred p = mempty+  | otherwise         = p+  where+    isKvar            = not . null . kvars -  	isBoundLike (RConc pred) = isBoundLikePred pred-  	isBoundLike (RKvar _ _)  = False+isBoundLikePred :: Pred -> Bool+isBoundLikePred (PAnd ps) = simplifyLen <= length [p | p <- ps, isImp p ]+isBoundLikePred _         = False -  	isBoundLikePred (PAnd ps)-  	  = moreThan simplifyLen (isImp <$> ps)-  	isBoundLikePred _ = False+isImp :: Pred -> Bool+isImp (PImp _ _) = True+isImp _          = False -  	isImp (PImp _ _) = True-  	isImp _          = False+-- OLD isBoundLike (RConc pred)  = isBoundLikePred pred+-- OLD isBoundLike (RKvar _ _)   = False -  	moreThan 0 _          = True-  	moreThan _ []         = False-  	moreThan i (True:xs)  = moreThan (i-1) xs-  	moreThan i (False:xs) = moreThan i xs++-- OLD moreThan 0 _            = True+-- OLD moreThan _ []           = False+-- OLD moreThan i (True  : xs) = moreThan (i-1) xs+-- OLD moreThan i (False : xs) = moreThan i xs++simplifyLen :: Int+simplifyLen = 5
src/Language/Haskell/Liquid/Tidy.hs view
@@ -23,7 +23,7 @@  import Language.Fixpoint.Names              (symSepName, isPrefixOfSym, takeWhileSym) import Language.Fixpoint.Types-import Language.Haskell.Liquid.GhcMisc      (stringTyVar) +import Language.Haskell.Liquid.GhcMisc      (stringTyVar) import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.RefType hiding (shiftVV) @@ -40,50 +40,49 @@   --------------------------------------------------------------------------tidySpecType :: Tidy -> SpecType -> SpecType  +tidySpecType :: Tidy -> SpecType -> SpecType ------------------------------------------------------------------------- tidySpecType k = tidyValueVars                . tidyDSymbols-               . tidySymbols -               . tidyLocalRefas k +               . tidySymbols+               . tidyLocalRefas k                . tidyFunBinds-               . tidyTyVars +               . tidyTyVars  tidyValueVars :: SpecType -> SpecType tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u }  tidyVV r@(Reft (va,_))   | isJunk va = shiftVV r v'-  | otherwise = r  +  | otherwise = r   where     v'        = if v `elem` xs then symbol ("v'" :: T.Text) else v     v         = symbol ("v" :: T.Text)     xs        = syms r     isJunk    = isPrefixOfSym "x"-    + tidySymbols :: SpecType -> SpecType-tidySymbols t = substa tidySymbol $ mapBind dropBind t  -  where +tidySymbols t = substa tidySymbol $ mapBind dropBind t+  where     xs         = S.fromList (syms t)-    dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol  +    dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol   tidyLocalRefas   :: Tidy -> SpecType -> SpecType tidyLocalRefas k = mapReft (txStrata . txReft' k)   where-    txReft' Full                  = id +    txReft' Full                  = id     txReft' Lossy                 = txReft-    txStrata (U r p l)            = U r p (txStr l) -    txReft (U (Reft (v,ras)) p l) = U (Reft (v, dropLocals ras)) p l-    dropLocals                    = filter (not . any isTmp . syms) . flattenRefas+    txStrata (U r p l)            = U r p (txStr l)+    txReft u                      = u { ur_reft = mapPredReft dropLocals $ ur_reft u }+    dropLocals                    = pAnd . filter (not . any isTmp . syms) . conjuncts     isTmp x                       = any (`isPrefixOfSym` x) [anfPrefix, "ds_"]-    txStr                         = filter (not . isSVar) -+    txStr                         = filter (not . isSVar)  -tidyDSymbols :: SpecType -> SpecType  +tidyDSymbols :: SpecType -> SpecType tidyDSymbols t = mapBind tx $ substa tx t-  where +  where     tx         = bindersTx [x | x <- syms t, isTmp x]     isTmp      = (tempPrefix `isPrefixOfSym`) @@ -92,28 +91,28 @@   where     tx         = bindersTx $ filter isTmpSymbol $ funBinds t -tidyTyVars :: SpecType -> SpecType  -tidyTyVars t = subsTyVarsAll αβs t -  where -    αβs  = zipWith (\α β -> (α, toRSort β, β)) αs βs +tidyTyVars :: SpecType -> SpecType+tidyTyVars t = subsTyVarsAll αβs t+  where+    αβs  = zipWith (\α β -> (α, toRSort β, β)) αs βs     αs   = L.nub (tyVars t)     βs   = map (rVar . stringTyVar) pool     pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]]  -bindersTx ds   = \y -> M.lookupDefault y y m  -  where +bindersTx ds   = \y -> M.lookupDefault y y m+  where     m          = M.fromList $ zip ds $ var <$> [1..]     var        = symbol . ('x' :) . show-  + tyVars (RAllP _ t)     = tyVars t tyVars (RAllS _ t)     = tyVars t tyVars (RAllT α t)     = α : tyVars t-tyVars (RFun _ t t' _) = tyVars t ++ tyVars t' -tyVars (RAppTy t t' _) = tyVars t ++ tyVars t' +tyVars (RFun _ t t' _) = tyVars t ++ tyVars t'+tyVars (RAppTy t t' _) = tyVars t ++ tyVars t' tyVars (RApp _ ts _ _) = concatMap tyVars ts-tyVars (RVar α _)      = [α] +tyVars (RVar α _)      = [α] tyVars (RAllE _ _ t)   = tyVars t tyVars (REx _ _ t)     = tyVars t tyVars (RExprArg _)    = []@@ -121,7 +120,7 @@ tyVars (RHole _)       = []  subsTyVarsAll ats = go-  where +  where     abm            = M.fromList [(a, b) | (a, _, (RVar b _)) <- ats]     go (RAllT a t) = RAllT (M.lookupDefault a a abm) (go t)     go t           = subsTyVars_meet ats t@@ -134,9 +133,8 @@ funBinds (RApp _ ts _ _)  = concatMap funBinds ts funBinds (RAllE b t1 t2)  = b : funBinds t1 ++ funBinds t2 funBinds (REx b t1 t2)    = b : funBinds t1 ++ funBinds t2-funBinds (RVar _ _)       = [] +funBinds (RVar _ _)       = [] funBinds (RRTy _ _ _ t)   = funBinds t funBinds (RAppTy t1 t2 _) = funBinds t1 ++ funBinds t2 funBinds (RExprArg _)     = [] funBinds (RHole _)        = []-
src/Language/Haskell/Liquid/Types.hs view
@@ -8,10 +8,11 @@ {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-} +{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE OverlappingInstances       #-} {-# LANGUAGE ViewPatterns               #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}  -- | This module should contain all the global type definitions and basic instances. @@ -19,10 +20,10 @@    -- * Options     Config (..)-  +   -- * Ghc Information   , GhcInfo (..)-  , GhcSpec (..) +  , GhcSpec (..)   , TargetVars (..)    -- * Located Things@@ -36,14 +37,14 @@   -- * Default unknown name   , dummyName, isDummy -  -- * Refined Type Constructors +  -- * Refined Type Constructors   , RTyCon (RTyCon, rtc_tc, rtc_info)   , TyConInfo(..), defaultTyConInfo-  , rTyConPVs +  , rTyConPVs   , rTyConPropVs-  , isClassRTyCon, isClassType - -  -- * Refinement Types +  , isClassRTyCon, isClassType++  -- * Refinement Types   , RType (..), Ref(..), RTProp   , RTyVar (..)   , RTAlias (..)@@ -51,13 +52,13 @@   -- * Worlds   , HSeg (..)   , World (..)-    -  -- * Classes describing operations on `RTypes` ++  -- * Classes describing operations on `RTypes`   , TyConable (..)   , RefTypable (..)   , SubsTy (..) -  -- * Predicate Variables +  -- * Predicate Variables   , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType   , PVKind (..)   , Predicate (..)@@ -76,30 +77,30 @@    -- * Instantiated RType   , BareType, PrType-  , SpecType, SpecProp +  , SpecType, SpecProp   , RSort   , UsedPVar, RPVar, RReft   , REnv (..)    -- * Constructing & Destructing RTypes   , RTypeRep(..), fromRTypeRep, toRTypeRep-  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow +  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow   , mkUnivs, bkUniv, bkClass   , rFun, rCls, rRCls    -- * Manipulating `Predicates`-  , pvars, pappSym, pToRef, pApp+  , pvars, pappSym, pApp    -- * Some tests on RTypes   , isBase   , isFunTy   , isTrivial -  -- * Traversing `RType` +  -- * Traversing `RType`   , efoldReft, foldReft   , mapReft, mapReftM   , mapBot, mapBind- +   -- * ???   , Oblig(..)   , ignoreOblig@@ -107,7 +108,7 @@   , addInvCond  -  -- * Inferred Annotations +  -- * Inferred Annotations   , AnnInfo (..)   , Annot (..) @@ -121,13 +122,13 @@   , ofRSort, toRSort   , rTypeValueVar   , rTypeReft-  , stripRTypeBase +  , stripRTypeBase -  -- * Class for values that can be pretty printed +  -- * Class for values that can be pretty printed   , PPrint (..)   , showpp-   -  -- * Printer Configuration ++  -- * Printer Configuration   , PPEnv (..)   , Tidy  (..)   , ppEnv@@ -153,6 +154,7 @@   , ErrorResult   , errSpan   , errOther+  , errToFCrash    -- * Source information (associated with constraints)   , Cinfo (..)@@ -172,7 +174,7 @@   , emptyKVProf   -- empty profile   , updKVProf     -- extend profile -  -- * Misc +  -- * Misc   , mapRTAVars   , insertsSEnv @@ -188,20 +190,23 @@   -- * Refined Instances   , RDEnv, DEnv(..), RInstance(..) +  -- * Ureftable Instances+  , UReftable(..)+   )   where  import SrcLoc                                   (noSrcSpan, SrcSpan)-import TyCon +import TyCon import DataCon import NameSet import Module                                   (moduleNameFS)-import TypeRep                          hiding  (maybeParen, pprArrowChain)  +import TypeRep                          hiding  (maybeParen, pprArrowChain) import Var import Text.Printf import GHC                                      (HscEnv, ModuleName, moduleNameString) import GHC.Generics-import Language.Haskell.Liquid.GhcMisc +import Language.Haskell.Liquid.GhcMisc  import PrelInfo         (isNumericClass) @@ -213,7 +218,7 @@ import Control.DeepSeq import Control.Applicative                      ((<$>)) import Data.Typeable                            (Typeable)-import Data.Generics                            (Data)   +import Data.Generics                            (Data) import Data.Monoid                              hiding ((<>)) import qualified  Data.Foldable as F import            Data.Hashable@@ -224,18 +229,18 @@ import            Data.List                    (nub) import            Data.Text                    (Text) import qualified  Data.Text                    as T-import Text.Parsec.Pos              (SourcePos) -import Text.Parsec.Error            (ParseError) -import Text.PrettyPrint.HughesPJ    -import Language.Fixpoint.Config     hiding (Config) +import Text.Parsec.Pos              (SourcePos)+import Text.Parsec.Error            (ParseError)+import Text.PrettyPrint.HughesPJ+import Language.Fixpoint.Config     hiding (Config) import Language.Fixpoint.Misc-import Language.Fixpoint.Types      hiding (Predicate, Def, R)+import Language.Fixpoint.Types      hiding (Result, Predicate, Def, R) import Language.Fixpoint.Names      (funConName, listConName, tupConName) import qualified Language.Fixpoint.PrettyPrint as F import CoreSyn (CoreBind)  import Language.Haskell.Liquid.Variance-import Language.Haskell.Liquid.Misc (mapSndM)+import Language.Haskell.Liquid.Misc (mapSndM, safeZip3WithError)   import Data.Default@@ -244,12 +249,13 @@ -----------------------------------------------------------------------------  -- NOTE: adding strictness annotations breaks the help message-data Config = Config { +data Config = Config {     files          :: [FilePath] -- ^ source files to check   , idirs          :: [FilePath] -- ^ path to directory for including specs-  , diffcheck      :: Bool       -- ^ check subset of binders modified (+ dependencies) since last check +  , diffcheck      :: Bool       -- ^ check subset of binders modified (+ dependencies) since last check   , real           :: Bool       -- ^ supports real number arithmetic   , fullcheck      :: Bool       -- ^ check all binders (overrides diffcheck)+  , native         :: Bool       -- ^ use native (Haskell) fixpoint constraint solver   , binders        :: [String]   -- ^ set of binders to check   , noCheckUnknown :: Bool       -- ^ whether to complain about specifications for unexported and unused values   , notermination  :: Bool       -- ^ disable termination check@@ -263,7 +269,7 @@   , maxParams      :: Int        -- ^ the maximum number of parameters to accept when mining qualifiers   , smtsolver      :: Maybe SMTSolver  -- ^ name of smtsolver to use [default: try z3, cvc4, mathsat in order]   , shortNames     :: Bool       -- ^ drop module qualifers from pretty-printed names.-  , shortErrors    :: Bool       -- ^ don't show subtyping errors and contexts. +  , shortErrors    :: Bool       -- ^ don't show subtyping errors and contexts.   , ghcOptions     :: [String]   -- ^ command-line options to pass to GHC   , cFiles         :: [String]   -- ^ .c files to compile and link against (for GHC)   } deriving (Data, Typeable, Show, Eq)@@ -281,8 +287,8 @@   pprintTidy :: Tidy -> a -> Doc   pprintTidy _ = pprint -showpp :: (PPrint a) => a -> String -showpp = render . pprint +showpp :: (PPrint a) => a -> String+showpp = render . pprint  instance PPrint a => PPrint (Maybe a) where   pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint)@@ -293,7 +299,7 @@ instance (PPrint a, PPrint b) => PPrint (a,b) where   pprint (x, y)  = pprint x <+> text ":" <+> pprint y -data PPEnv +data PPEnv   = PP { ppPs    :: Bool        , ppTyVar :: Bool -- TODO if set to True all Bare fails        , ppSs    :: Bool@@ -310,8 +316,8 @@ ------------------------------------------------------------------ -- | GHC Information :  Code & Spec ------------------------------ ------------------------------------------------------------------- -data GhcInfo = GI { ++data GhcInfo = GI {     env      :: !HscEnv   , cbs      :: ![CoreBind]   , derVars  :: ![Var]@@ -333,17 +339,16 @@   , asmSigs    :: ![(Var, Located SpecType)]     -- ^ Assumed Reftypes   , ctors      :: ![(Var, Located SpecType)]     -- ^ Data Constructor Measure Sigs                                                  -- eg.  (:) :: a -> xs:[a] -> {v: Int | v = 1 + len(xs) }-  , meas       :: ![(Symbol, Located SpecType)]  -- ^ Measure Types  +  , meas       :: ![(Symbol, Located SpecType)]  -- ^ Measure Types                                                  -- eg.  len :: [a] -> Int   , invariants :: ![Located SpecType]            -- ^ Data Type Invariants--  , ialiases   :: ![(Located SpecType, Located SpecType)] -- ^ Data Type Invariant Aliases                                                  -- eg.  forall a. {v: [a] | len(v) >= 0}+  , ialiases   :: ![(Located SpecType, Located SpecType)] -- ^ Data Type Invariant Aliases   , dconsP     :: ![(DataCon, DataConP)]         -- ^ Predicated Data-Constructors                                                  -- e.g. see tests/pos/Map.hs   , tconsP     :: ![(TyCon, TyConP)]             -- ^ Predicated Type-Constructors                                                  -- eg.  see tests/pos/Map.hs-  , freeSyms   :: ![(Symbol, Var)]               -- ^ List of `Symbol` free in spec and corresponding GHC var +  , freeSyms   :: ![(Symbol, Var)]               -- ^ List of `Symbol` free in spec and corresponding GHC var                                                  -- eg. (Cons, Cons#7uz) from tests/pos/ex1.hs   , tcEmbeds   :: TCEmb TyCon                    -- ^ How to embed GHC Tycons into fixpoint sorts                                                  -- e.g. "embed Set as Set_set" from include/Data/Set.spec@@ -358,26 +363,26 @@   , exports    :: !NameSet                       -- ^ `Name`s exported by the module being verified   , measures   :: [Measure SpecType DataCon]   , tyconEnv   :: M.HashMap TyCon RTyCon-  , dicts      :: DEnv Var SpecType                  -- ^ Dictionary Environment+  , dicts      :: DEnv Var SpecType              -- ^ Dictionary Environment   } -type LogicMap = M.HashMap Symbol LMap +type LogicMap = M.HashMap Symbol LMap  data LMap = LMap { lvar  :: Symbol-                 , largs :: [Symbol] +                 , largs :: [Symbol]                  , lexpr :: Expr                  }  instance Show LMap where-  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t|->\t" ++ show e           +  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t|->\t" ++ show e   toLogicMap = M.fromList . map toLMap-  where +  where     toLMap (x, xs, e) = (x, LMap {lvar = x, largs = xs, lexpr = e})  eAppWithMap lmap f es def-  | Just (LMap _ xs e) <- M.lookup (val f) lmap +  | Just (LMap _ xs e) <- M.lookup (val f) lmap   = subst (mkSubst $ zip xs es) e   | otherwise   = def@@ -387,7 +392,7 @@                      , freePredTy   :: ![PVar RSort]                      , freeLabelTy  :: ![Symbol]                      , varianceTs   :: !VarianceInfo-                     , variancePs   :: !VarianceInfo +                     , variancePs   :: !VarianceInfo                      , sizeFun      :: !(Maybe (Symbol -> Expr))                      } deriving (Data, Typeable) @@ -398,6 +403,7 @@                          , tyConsts   :: ![SpecType] -- ^ FIXME: WHAT IS THIS??                          , tyArgs     :: ![(Symbol, SpecType)] -- ^ These are backwards, why??                          , tyRes      :: !SpecType+                         , dc_locE    :: !SourcePos                          } deriving (Data, Typeable)  @@ -419,8 +425,8 @@  pvType p = case ptype p of              PVProp t -> t-             PVHProp  -> errorstar "pvType on HProp-PVar" -             +             PVHProp  -> errorstar "pvType on HProp-PVar"+ data PVKind t   = PVProp t | PVHProp     deriving (Generic, Data, Typeable, F.Foldable, Traversable, Show)@@ -441,7 +447,7 @@ instance (NFData a) => NFData (PVKind a) where   rnf (PVProp t) = rnf t   rnf (PVHProp)  = ()-  + instance (NFData a) => NFData (PVar a) where   rnf (PV n t v txys) = rnf n `seq` rnf v `seq` rnf t `seq` rnf txys @@ -461,7 +467,7 @@ --------------------------------------------------------------------  type UsedPVar      = PVar ()-newtype Predicate  = Pr [UsedPVar] deriving (Generic, Data, Typeable) +newtype Predicate  = Pr [UsedPVar] deriving (Generic, Data, Typeable)  instance NFData Predicate where   rnf _ = ()@@ -479,15 +485,15 @@ pdAnd ps       = Pr (nub $ concatMap pvars ps) pvars (Pr pvs) = pvs -instance Subable UsedPVar where +instance Subable UsedPVar where   syms pv         = [ y | (_, x, EVar y) <- pargs pv, x /= y ]-  subst s pv      = pv { pargs = mapThd3 (subst s)  <$> pargs pv }  -  substf f pv     = pv { pargs = mapThd3 (substf f) <$> pargs pv }  -  substa f pv     = pv { pargs = mapThd3 (substa f) <$> pargs pv }  +  subst s pv      = pv { pargs = mapThd3 (subst s)  <$> pargs pv }+  substf f pv     = pv { pargs = mapThd3 (substf f) <$> pargs pv }+  substa f pv     = pv { pargs = mapThd3 (substa f) <$> pargs pv }   instance Subable Predicate where-  syms (Pr pvs)     = concatMap syms pvs +  syms (Pr pvs)     = concatMap syms pvs   subst s (Pr pvs)  = Pr (subst s <$> pvs)   substf f (Pr pvs) = Pr (substf f <$> pvs)   substa f (Pr pvs) = Pr (substa f <$> pvs)@@ -497,7 +503,7 @@   subst  = mapQualBody . subst   substf = mapQualBody . substf   substa = mapQualBody . substa-  + mapQualBody f q = q { q_body = f (q_body q) }  instance NFData r => NFData (UReft r) where@@ -520,7 +526,7 @@   symbol (RTV tv) = symbol . T.pack . showPpr $ tv  -data RTyCon = RTyCon +data RTyCon = RTyCon   { rtc_tc    :: TyCon         -- ^ GHC Type Constructor   , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters   , rtc_info  :: !TyConInfo    -- ^ TyConInfo@@ -546,7 +552,7 @@ isProp (PVProp _) = True isProp _          = False -               + defaultTyConInfo = TyConInfo [] [] Nothing  instance Default TyConInfo where@@ -554,17 +560,17 @@   -------------------------------------------------------------------------- | Co- and Contra-variance for TyCon -------------------------------- +-- | Co- and Contra-variance for TyCon -------------------------------- -----------------------------------------------------------------------  -- | Indexes start from 0 and type or predicate arguments can be both --   covariant and contravaariant e.g., for the below Foo dataType--- +-- --     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop> --       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>) -----  there will be: --- +--  there will be:+-- --    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant] --    variancePsArgs     = [Covariant, Contravatiant, Bivariant] --@@ -576,7 +582,7 @@   } deriving (Generic, Data, Typeable)  -instance Show TyConInfo where +instance Show TyConInfo where   show (TyConInfo x y _) = show x ++ "\n" ++ show y  --------------------------------------------------------------------@@ -585,20 +591,20 @@  -- MOVE TO TYPES data RType c tv r-  = RVar { +  = RVar {       rt_var    :: !tv-    , rt_reft   :: !r +    , rt_reft   :: !r     }-  +   | RFun  {       rt_bind   :: !Symbol     , rt_in     :: !(RType c tv r)-    , rt_out    :: !(RType c tv r) +    , rt_out    :: !(RType c tv r)     , rt_reft   :: !r     } -  | RAllT { -      rt_tvbind :: !tv       +  | RAllT {+      rt_tvbind :: !tv     , rt_ty     :: !(RType c tv r)     } @@ -612,26 +618,26 @@     , rt_ty     :: !(RType c tv r)     } -  | RApp  { +  | RApp  {       rt_tycon  :: !c-    , rt_args   :: ![RType  c tv r]     -    , rt_pargs  :: ![RTProp c tv r] +    , rt_args   :: ![RType  c tv r]+    , rt_pargs  :: ![RTProp c tv r]     , rt_reft   :: !r     } -  | RAllE { +  | RAllE {       rt_bind   :: !Symbol     , rt_allarg :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r) +    , rt_ty     :: !(RType c tv r)     } -  | REx { +  | REx {       rt_bind   :: !Symbol-    , rt_exarg  :: !(RType c tv r) -    , rt_ty     :: !(RType c tv r) +    , rt_exarg  :: !(RType c tv r)+    , rt_ty     :: !(RType c tv r)     } -  | RExprArg Expr                               -- ^ For expression arguments to type aliases+  | RExprArg (Located Expr)                     -- ^ For expression arguments to type aliases                                                 --   see tests/pos/vector2.hs   | RAppTy{       rt_arg   :: !(RType c tv r)@@ -642,15 +648,15 @@   | RRTy  {       rt_env   :: ![(Symbol, RType c tv r)]     , rt_ref   :: !r-    , rt_obl   :: !Oblig +    , rt_obl   :: !Oblig     , rt_ty    :: !(RType c tv r)     }    | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`             --   see tests/pos/Holes.hs   deriving (Generic, Data, Typeable)-  -data Oblig ++data Oblig   = OTerm -- ^ Obligation that proves termination   | OInv  -- ^ Obligation that proves invariants   | OCons -- ^ Obligation that proves constraints@@ -669,27 +675,27 @@  -- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors. --   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)---   * the `RProp`  denoted by `{\h -> v > h}` to +--   * the `RProp`  denoted by `{\h -> v > h}` to --   * the `RTyCon` denoted by `[]`. --   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated --   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type. --   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies --   directly to any type and has semantics _independent of_ the data-type.-  -data Ref τ r t ++data Ref τ r t   = RPropP {       rf_args :: [(Symbol, τ)]     , rf_reft :: r-    }                              -- ^ Parse-time `RProp` +    }                              -- ^ Parse-time `RProp`    | RProp  {-      rf_args :: [(Symbol, τ)] -    , rf_body :: t                 +      rf_args :: [(Symbol, τ)]+    , rf_body :: t     }                              -- ^ Abstract refinement associated with `RTyCon`-    +   | RHProp {       rf_args :: [(Symbol, τ)]-    , rf_heap :: World t           +    , rf_heap :: World t     }                              -- ^ Abstract heap-refinement associated with `RTyCon`   deriving (Generic, Data, Typeable) @@ -704,11 +710,11 @@ --   2. There is at most one `HVar` in a list.  newtype World t = World [HSeg t]-                deriving (Generic, Data, Typeable) +                deriving (Generic, Data, Typeable)  data    HSeg  t = HBind {hs_addr :: !Symbol, hs_val :: t}                 | HVar UsedPVar-                deriving (Generic, Data, Typeable) +                deriving (Generic, Data, Typeable)  data UReft r   = U { ur_reft :: !r, ur_pred :: !Predicate, ur_strata :: !Strata }@@ -723,15 +729,15 @@ type BPVar      = PVar      BSort type RPVar      = PVar      RSort -type RReft      = UReft     Reft +type RReft      = UReft     Reft type PrType     = RRType    Predicate type BareType   = BRType    RReft-type SpecType   = RRType    RReft +type SpecType   = RRType    RReft type SpecProp   = RRProp    RReft type RRProp r   = Ref       RSort r (RRType r)  -data Stratum    = SVar Symbol | SDiv | SWhnf | SFin +data Stratum    = SVar Symbol | SDiv | SWhnf | SFin                   deriving (Generic, Data, Typeable, Eq)  type Strata = [Stratum]@@ -765,10 +771,10 @@       , Hashable tv       , Reftable r       , PPrint r-      ) => RefTypable c tv r +      ) => RefTypable c tv r   where --     ppCls    :: p -> [RType c tv r] -> Doc-    ppRType  :: Prec -> RType c tv r -> Doc +    ppRType  :: Prec -> RType c tv r -> Doc   @@ -780,9 +786,9 @@ instance TyConable RTyCon where   isFun      = isFunTyCon . rtc_tc   isList     = (listTyCon ==) . rtc_tc-  isTuple    = TyCon.isTupleTyCon   . rtc_tc +  isTuple    = TyCon.isTupleTyCon   . rtc_tc   isClass    = isClassRTyCon-  ppTycon    = toFix +  ppTycon    = toFix    isNumCls c  = maybe False isNumericClass    (tyConClass_maybe $ rtc_tc c)   isFracCls c = maybe False isFractionalClass (tyConClass_maybe $ rtc_tc c)@@ -809,18 +815,18 @@   instance PPrint RTyCon where-  pprint = text . showPpr . rtc_tc  +  pprint = text . showPpr . rtc_tc   instance Show RTyCon where-  show = showpp  +  show = showpp  -------------------------------------------------------------------------- -- | Refined Instances --------------------------------------------------- --------------------------------------------------------------------------  data RInstance t = RI { riclass :: LocSymbol-                      , ritype  :: t +                      , ritype  :: t                       , risigs  :: [(LocSymbol, t)]                       } @@ -829,7 +835,7 @@ type RDEnv = DEnv Var SpecType  instance Functor RInstance where-  fmap f (RI x t xts) = RI x (f t) (mapSnd f <$> xts) +  fmap f (RI x t xts) = RI x (f t) (mapSnd f <$> xts)   --------------------------------------------------------------------------@@ -853,7 +859,7 @@                     , tycSFun   :: (Maybe (Symbol -> Expr))                                 -- ^ Measure that should decrease in recursive calls                     }-     --              deriving (Show) +     --              deriving (Show)   instance Eq DataDecl where@@ -864,18 +870,19 @@  -- | For debugging. instance Show DataDecl where-  show dd = printf "DataDecl: data = %s, tyvars = %s" -              (show $ tycName   dd) -              (show $ tycTyVars dd) +  show dd = printf "DataDecl: data = %s, tyvars = %s"+              (show $ tycName   dd)+              (show $ tycTyVars dd)  -- | Refinement Type Aliases -data RTAlias tv ty +data RTAlias tv ty   = RTA { rtName  :: Symbol         , rtTArgs :: [tv]-        , rtVArgs :: [tv] -        , rtBody  :: ty  -        , rtPos   :: SourcePos +        , rtVArgs :: [tv]+        , rtBody  :: ty+        , rtPos   :: SourcePos+        , rtPosE  :: SourcePos         }  mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt@@ -891,51 +898,54 @@              , ty_preds  :: [PVar (RType c tv ())]              , ty_labels :: [Symbol]              , ty_binds  :: [Symbol]+             , ty_refts  :: [r]              , ty_args   :: [RType c tv r]              , ty_res    :: (RType c tv r)              } -fromRTypeRep rep -  = mkArrow (ty_vars rep) (ty_preds rep) (ty_labels rep) (zip (ty_binds rep) (ty_args rep)) (ty_res rep)+fromRTypeRep (RTypeRep {..})+  = mkArrow ty_vars ty_preds ty_labels arrs ty_res+  where+    arrs = safeZip3WithError "fromRTypeRep" ty_binds ty_args ty_refts  toRTypeRep           :: RType c tv r -> RTypeRep c tv r-toRTypeRep t         = RTypeRep αs πs ls xs ts t''+toRTypeRep t         = RTypeRep αs πs ls xs rs ts t''   where-    (αs, πs, ls, t') = bkUniv  t-    (xs, ts, t'')    = bkArrow t'+    (αs, πs, ls, t')  = bkUniv  t+    (xs, ts, rs, t'') = bkArrow t' -mkArrow αs πs ls xts = mkUnivs αs πs ls . mkArrs xts -  where -    mkArrs xts t  = foldr (uncurry rFun) t xts +mkArrow αs πs ls xts = mkUnivs αs πs ls . mkArrs xts+  where+    mkArrs xts t  = foldr (\(b,t1,r) t2 -> RFun b t1 t2 r) t xts  bkArrowDeep (RAllT _ t)     = bkArrowDeep t bkArrowDeep (RAllP _ t)     = bkArrowDeep t bkArrowDeep (RAllS _ t)     = bkArrowDeep t-bkArrowDeep (RFun x t t' _) = let (xs, ts, t'') = bkArrowDeep t'  in (x:xs, t:ts, t'')-bkArrowDeep t               = ([], [], t)+bkArrowDeep (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrowDeep t'  in (x:xs, t:ts, r:rs, t'')+bkArrowDeep t               = ([], [], [], t) -bkArrow (RFun x t t' _) = let (xs, ts, t'') = bkArrow t'  in (x:xs, t:ts, t'')-bkArrow t               = ([], [], t)+bkArrow (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrow t'  in (x:xs, t:ts, r:rs, t'')+bkArrow t               = ([], [], [], t)  safeBkArrow (RAllT _ _) = errorstar "safeBkArrow on RAllT" safeBkArrow (RAllP _ _) = errorstar "safeBkArrow on RAllP"-safeBkArrow (RAllS _ t) = safeBkArrow t +safeBkArrow (RAllS _ t) = safeBkArrow t safeBkArrow t           = bkArrow t -mkUnivs αs πs ls t = foldr RAllT (foldr RAllP (foldr RAllS t ls) πs) αs +mkUnivs αs πs ls t = foldr RAllT (foldr RAllP (foldr RAllS t ls) πs) αs  bkUniv :: RType t1 a t2 -> ([a], [PVar (RType t1 a ())], [Symbol], RType t1 a t2)-bkUniv (RAllT α t)      = let (αs, πs, ls, t') = bkUniv t in  (α:αs, πs, ls, t') -bkUniv (RAllP π t)      = let (αs, πs, ls, t') = bkUniv t in  (αs, π:πs, ls, t') -bkUniv (RAllS s t)      = let (αs, πs, ss, t') = bkUniv t in  (αs, πs, s:ss, t') +bkUniv (RAllT α t)      = let (αs, πs, ls, t') = bkUniv t in  (α:αs, πs, ls, t')+bkUniv (RAllP π t)      = let (αs, πs, ls, t') = bkUniv t in  (αs, π:πs, ls, t')+bkUniv (RAllS s t)      = let (αs, πs, ss, t') = bkUniv t in  (αs, πs, s:ss, t') bkUniv t                = ([], [], [], t) -bkClass (RFun _ (RApp c t _ _) t' _)  -  | isClass c +bkClass (RFun _ (RApp c t _ _) t' _)+  | isClass c   = let (cs, t'') = bkClass t' in ((c, t):cs, t'') bkClass (RRTy e r o t)   = let (cs, t') = bkClass t in (cs, RRTy e r o t')-bkClass t                                              +bkClass t   = ([], t)  rFun b t t' = RFun b t t' mempty@@ -945,25 +955,26 @@ addTermCond = addObligation OTerm  addInvCond :: SpecType -> RReft -> SpecType-addInvCond t r' -  | null rv +addInvCond t r'+  | isTauto $ ur_reft r' -- null rv   = t   | otherwise   = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}-  where trep = toRTypeRep t-        tbd  = ty_res trep-        r    = r'{ur_reft = Reft (v, rx)}-        su   = (v, EVar x')-        x'   = "xInv"-        rx   = [RConc $ PIff (PBexp $ EVar v) $ subst1 r su | RConc r <- rv]--        Reft(v, rv) = ur_reft r'+  where+    trep = toRTypeRep t+    tbd  = ty_res trep+    r    = r' {ur_reft = Reft (v, Refa rx)}+    su   = (v, EVar x')+    x'   = "xInv"+    rx   = PIff (PBexp $ EVar v) $ subst1 (raPred rv) su+    Reft(v, rv) = ur_reft r'  addObligation :: Oblig -> SpecType -> RReft -> SpecType-addObligation o t r = mkArrow αs πs ls xts $ RRTy [] r o t2-  where (αs, πs, ls, t1) = bkUniv t-        (xs, ts, t2)     = bkArrow t1-        xts              = zip xs ts+addObligation o t r  = mkArrow αs πs ls xts $ RRTy [] r o t2+  where+    (αs, πs, ls, t1) = bkUniv t+    (xs, ts, rs, t2) = bkArrow t1+    xts              = zip3 xs ts rs  -------------------------------------------- @@ -987,7 +998,7 @@   isTauto []         = True   isTauto _          = False -  ppTy _             = error "ppTy on Strata" +  ppTy _             = error "ppTy on Strata"   toReft _           = mempty   params s           = [l | SVar l <- s]   bot _              = []@@ -995,35 +1006,47 @@    ofReft = error "TODO: Strata.ofReft" ++class Reftable r => UReftable r where+  ofUReft :: UReft Reft -> r+  ofUReft (U r _ _) = ofReft r+++instance UReftable (UReft Reft) where+   ofUReft r = r++instance UReftable () where+   ofUReft _ = mempty+ instance (PPrint r, Reftable r) => Reftable (UReft r) where-  isTauto            = isTauto_ureft +  isTauto            = isTauto_ureft   ppTy               = ppTy_ureft-  toReft (U r ps _)  = toReft r `meet` toReft ps +  toReft (U r ps _)  = toReft r `meet` toReft ps   params (U r _ _)   = params r   bot (U r _ s)      = U (bot r) (Pr []) (bot s)   top (U r p s)      = U (top r) (top p) (top s) -  ofReft = error "TODO: UReft.ofReft"+  ofReft r = U (ofReft r) mempty mempty  isTauto_ureft u      = isTauto (ur_reft u) && isTauto (ur_pred u) -- && (isTauto $ ur_strata u) -ppTy_ureft u@(U r p s) d +ppTy_ureft u@(U r p s) d   | isTauto_ureft  u  = d   | otherwise         = ppr_reft r (ppTy p d) s -ppr_reft r d s       = braces (toFix v <+> colon <+> d <> ppr_str s <+> text "|" <+> pprint r')-  where +ppr_reft r d s       = braces (pprint v <+> colon <+> d <> ppr_str s <+> text "|" <+> pprint r')+  where     r'@(Reft (v, _)) = toReft r  ppr_str [] = empty ppr_str s  = text "^" <> pprint s  instance Subable r => Subable (UReft r) where-  syms (U r p _)     = syms r ++ syms p +  syms (U r p _)     = syms r ++ syms p   subst s (U r z l)  = U (subst s r) (subst s z) (subst s l)-  substf f (U r z l) = U (substf f r) (substf f z) (substf f l) +  substf f (U r z l) = U (substf f r) (substf f z) (substf f l)   substa f (U r z l) = U (substa f r) (substa f z) (substa f l)- + instance (Reftable r, RefTypable c tv r) => Subable (RTProp c tv r) where   syms (RPropP ss r)     = (fst <$> ss) ++ syms r   syms (RProp  ss r)     = (fst <$> ss) ++ syms r@@ -1033,17 +1056,17 @@   subst su (RProp  ss t) = RProp ss (subst su <$> t)   subst _  (RHProp _  _) = error "TODO: PHProp.subst" -  substf f (RPropP ss r) = RPropP ss (substf f r) +  substf f (RPropP ss r) = RPropP ss (substf f r)   substf f (RProp  ss t) = RProp ss (substf f <$> t)   substf _ (RHProp _  _) = error "TODO PHProp.substf"-  substa f (RPropP ss r) = RPropP ss (substa f r) +  substa f (RPropP ss r) = RPropP ss (substa f r)   substa f (RProp  ss t) = RProp ss (substa f <$> t)   substa _ (RHProp _  _) = error "TODO PHProp.substa"  instance (Subable r, RefTypable c tv r) => Subable (RType c tv r) where-  syms        = foldReft (\r acc -> syms r ++ acc) [] -  substa f    = mapReft (substa f) -  substf f    = emapReft (substf . substfExcept f) [] +  syms        = foldReft (\r acc -> syms r ++ acc) []+  substa f    = mapReft (substa f)+  substf f    = emapReft (substf . substfExcept f) []   subst su    = emapReft (subst  . substExcept su) []   subst1 t su = emapReft (\xs r -> subst1Except xs r su) [] t @@ -1056,18 +1079,17 @@   bot (Pr _)           = errorstar "No BOT instance for Predicate"   -- NV: This does not print abstract refinements....   -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX.-  ppTy r d | isTauto r        = d +  ppTy r d | isTauto r        = d            | not (ppPs ppEnv) = d            | otherwise        = d <> (angleBrackets $ pprint r)-  -  toReft (Pr ps@(p:_))        = Reft (parg p, pToRef <$> ps)++  toReft (Pr ps@(p:_))        = Reft (parg p, refa $ pToRef <$> ps)   toReft _                    = mempty   params                      = errorstar "TODO: instance of params for Predicate"    ofReft = error "TODO: Predicate.ofReft" --pToRef p = RConc $ pApp (pname p) $ (EVar $ parg p) : (thd3 <$> pargs p)+pToRef p = pApp (pname p) $ (EVar $ parg p) : (thd3 <$> pargs p)  pApp      :: Symbol -> [Expr] -> Pred pApp p es = PBexp $ EApp (dummyLoc $ pappSym $ length es) (EVar p:es)@@ -1084,7 +1106,7 @@   fmap f (U r p s) = U (f r) p s  instance Functor (RType a b) where-  fmap  = mapReft +  fmap  = mapReft  -- instance Fold.Foldable (RType a b c) where --   foldr = foldReft@@ -1116,6 +1138,7 @@ -- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t  -- isBase :: RType a -> Bool+isBase (RAllT _ t)      = isBase t isBase (RAllP _ t)      = isBase t isBase (RVar _ _)       = True isBase (RApp _ ts _ _)  = all isBase ts@@ -1142,7 +1165,7 @@ mapReftM f (RApp c ts rs r)   = liftM3  (RApp  c)   (mapM (mapReftM f) ts)  (mapM (mapRefM f) rs) (f r) mapReftM f (RAllE z t t')     = liftM2  (RAllE z)   (mapReftM f t)          (mapReftM f t') mapReftM f (REx z t t')       = liftM2  (REx z)     (mapReftM f t)          (mapReftM f t')-mapReftM _ (RExprArg e)       = return  $ RExprArg e +mapReftM _ (RExprArg e)       = return  $ RExprArg e mapReftM f (RAppTy t t' r)    = liftM3  RAppTy (mapReftM f t) (mapReftM f t') (f r) mapReftM f (RHole r)          = liftM   RHole       (f r) mapReftM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t)@@ -1153,39 +1176,39 @@ mapRefM  _ (RHProp _ _)       = error "TODO PHProp.mapRefM"  -- foldReft :: (r -> a -> a) -> a -> RType c tv r -> a-foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptySEnv +foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptySEnv  -- efoldReft :: Reftable r =>(p -> [RType c tv r] -> [(Symbol, a)])-> (RType c tv r -> a)-> (SEnv a -> Maybe (RType c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType c tv r-> c1-efoldReft cb g f fp = go +efoldReft cb g f fp = go   where-    -- folding over RType -    go γ z me@(RVar _ r)                = f γ (Just me) r z +    -- folding over RType+    go γ z me@(RVar _ r)                = f γ (Just me) r z     go γ z (RAllT _ t)                  = go γ z t     go γ z (RAllP p t)                  = go (fp p γ) z t     go γ z (RAllS _ t)                  = go γ z t-    go γ z me@(RFun _ (RApp c ts _ _) t' r) -       | isClass c                      = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')       +    go γ z me@(RFun _ (RApp c ts _ _) t' r)+       | isClass c                      = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')     go γ z me@(RFun x t t' r)           = f γ (Just me) r (go (insertSEnv x (g t) γ) (go γ z t) t')     go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs)-    -    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t' -    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t' ++    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'+    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'     go γ z me@(RRTy [] r _ t)          = f γ (Just me) r (go γ z t)     go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)     go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')     go _ z (RExprArg _)                 = z     go γ z me@(RHole r)                 = f γ (Just me) r z -    -- folding over Ref +    -- folding over Ref     ho  γ z (RPropP ss r)               = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z     ho  γ z (RProp  ss t)               = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t     ho  _ _ (RHProp _  _)               = error "TODO: RHProp.ho"-   +     -- folding over [RType]-    go' γ z ts                 = foldr (flip $ go γ) z ts +    go' γ z ts                 = foldr (flip $ go γ) z ts      -- folding over [Ref]-    ho' γ z rs                 = foldr (flip $ ho γ) z rs +    ho' γ z rs                 = foldr (flip $ ho γ) z rs      envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts) @@ -1198,10 +1221,10 @@ mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2) mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2) mapBot f (RRTy e r o t)    = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t)-mapBot f t'                = f t' +mapBot f t'                = f t' mapBotRef _ (RPropP s r)    = RPropP s $ r mapBotRef f (RProp  s t)    = RProp  s $ mapBot f t-mapBotRef _ (RHProp _ _)    = error "TODO: RHProp.mapBotRef" +mapBotRef _ (RHProp _ _)    = error "TODO: RHProp.mapBotRef"  mapBind f (RAllT α t)      = RAllT α (mapBind f t) mapBind f (RAllP π t)      = RAllP π (mapBind f t)@@ -1222,10 +1245,10 @@   ---------------------------------------------------ofRSort ::  Reftable r => RType c tv () -> RType c tv r +ofRSort ::  Reftable r => RType c tv () -> RType c tv r ofRSort = fmap mempty -toRSort :: RType c tv r -> RType c tv () +toRSort :: RType c tv r -> RType c tv () toRSort = stripAnnotations . mapBind (const dummySymbol) . fmap (const ())  stripAnnotations (RAllT α t)      = RAllT α (stripAnnotations t)@@ -1245,27 +1268,27 @@ insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)  rTypeValueVar :: (Reftable r) => RType c tv r -> Symbol-rTypeValueVar t = vv where Reft (vv,_) =  rTypeReft t +rTypeValueVar t = vv where Reft (vv,_) =  rTypeReft t  rTypeReft :: (Reftable r) => RType c tv r -> Reft-rTypeReft = fromMaybe trueReft . fmap toReft . stripRTypeBase +rTypeReft = fromMaybe trueReft . fmap toReft . stripRTypeBase  -- stripRTypeBase ::  RType a -> Maybe a-stripRTypeBase (RApp _ _ _ x)   +stripRTypeBase (RApp _ _ _ x)   = Just x-stripRTypeBase (RVar _ x)   +stripRTypeBase (RVar _ x)   = Just x-stripRTypeBase (RFun _ _ _ x)   +stripRTypeBase (RFun _ _ _ x)   = Just x-stripRTypeBase (RAppTy _ _ x)   +stripRTypeBase (RAppTy _ _ x)   = Just x-stripRTypeBase _                +stripRTypeBase _   = Nothing  mapRBase f (RApp c ts rs r) = RApp c ts rs $ f r mapRBase f (RVar a r)       = RVar a $ f r mapRBase f (RFun x t1 t2 r) = RFun x t1 t2 $ f r-mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r   +mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r mapRBase _ t                = t  @@ -1276,7 +1299,7 @@         f (U r p _) = U r p [l]  -makeDivType = makeLType SDiv +makeDivType = makeLType SDiv makeFinType = makeLType SFin  getStrata = maybe [] ur_strata . stripRTypeBase@@ -1299,19 +1322,19 @@   pprint ss = hsep (pprint <$> nub ss)  instance PPrint SourcePos where-  pprint = text . show +  pprint = text . show  instance PPrint () where-  pprint = text . show +  pprint = text . show -instance PPrint String where -  pprint = text +instance PPrint String where+  pprint = text  instance PPrint Text where   pprint = text . T.unpack  instance PPrint a => PPrint (Located a) where-  pprint = pprint . val +  pprint = pprint . val  instance PPrint Int where   pprint = F.pprint@@ -1345,7 +1368,7 @@  instance PPrint a => PPrint (PVar a) where   pprint (PV s _ _ xts)   = pprint s <+> hsep (pprint <$> dargs xts)-    where +    where       dargs               = map thd3 . takeWhile (\(_, x, y) -> EVar x /= y)  instance PPrint Predicate where@@ -1353,9 +1376,8 @@   pprint (Pr pvs)      = hsep $ punctuate (text "&") (map pprint pvs)  instance PPrint Refa where-  pprint (RConc p)     = pprint p-  pprint k             = toFix k- +  pprint = pprint . raPred+ instance PPrint Reft where   pprint = F.pprint @@ -1376,21 +1398,27 @@ instance PPrint EMsg where   pprint (EMsg s) = text s --- | In the below, we use EMsg instead of, say, SpecType because ---   the latter is impossible to serialize, as it contains GHC +-- | In the below, we use EMsg instead of, say, SpecType because+--   the latter is impossible to serialize, as it contains GHC --   internals like TyCon and Class inside it.  type Error = TError SpecType   -- | INVARIANT : all Error constructors should have a pos field-data TError t = +data TError t =     ErrSubType { pos  :: !SrcSpan-               , msg  :: !Doc -               , ctx  :: !(M.HashMap Symbol t) +               , msg  :: !Doc+               , ctx  :: !(M.HashMap Symbol t)                , tact :: !t                , texp :: !t                } -- ^ liquid type error+  | ErrFCrash  { pos  :: !SrcSpan+               , msg  :: !Doc+               , ctx  :: !(M.HashMap Symbol t)+               , tact :: !t+               , texp :: !t+               } -- ^ liquid type error   | ErrAssType { pos :: !SrcSpan                , obl :: !Oblig                , msg :: !Doc@@ -1422,12 +1450,12 @@   | ErrDupSpecs { pos :: !SrcSpan                 , var :: !Doc                 , locs:: ![SrcSpan]-                } -- ^ multiple specs for same binder error +                } -- ^ multiple specs for same binder error    | ErrBadData  { pos :: !SrcSpan                 , var :: !Doc                 , msg :: !Doc-                } -- ^ multiple specs for same binder error +                } -- ^ multiple specs for same binder error    | ErrInvt     { pos :: !SrcSpan                 , inv :: !t@@ -1457,7 +1485,7 @@    | ErrUnbound  { pos :: !SrcSpan                 , var :: !Doc-                } -- ^ Unbound symbol in specification +                } -- ^ Unbound symbol in specification    | ErrGhc      { pos :: !SrcSpan                 , msg :: !Doc@@ -1466,11 +1494,11 @@   | ErrMismatch { pos  :: !SrcSpan                 , var  :: !Doc                 , hs   :: !Type-                , texp :: !t+                , lq   :: !Type                 } -- ^ Mismatch between Liquid and Haskell types-  +   | ErrAliasCycle { pos    :: !SrcSpan-                  , acycle :: ![(SrcSpan, Doc)] +                  , acycle :: ![(SrcSpan, Doc)]                   } -- ^ Cyclic Refined Type Alias Definitions    | ErrIllegalAliasApp { pos   :: !SrcSpan@@ -1485,14 +1513,14 @@                 , dargs :: !Int                 } -  | ErrSaved    { pos :: !SrcSpan +  | ErrSaved    { pos :: !SrcSpan                 , msg :: !Doc                 } -- ^ Previously saved error, that carries over after DiffCheck    | ErrTermin   { bind :: ![Var]                 , pos  :: !SrcSpan                 , msg  :: !Doc-                } -- ^ Termination Error +                } -- ^ Termination Error    | ErrRClass   { pos   :: !SrcSpan                 , cls   :: !Doc@@ -1501,24 +1529,33 @@    | ErrOther    { pos :: !SrcSpan                 , msg :: !Doc-                } -- ^ Unexpected PANIC +                } -- ^ Unexpected PANIC   deriving (Typeable, Functor) --- data LParseError = LPE !SourcePos [String] +-- data LParseError = LPE !SourcePos [String] --                    deriving (Data, Typeable, Generic)  +++errToFCrash :: Error -> Error+errToFCrash (ErrSubType l m g t1 t2)+  = ErrFCrash l m g t1 t2+errToFCrash e+  = e++ instance Eq Error where   e1 == e2 = pos e1 == pos e2 -instance Ord Error where +instance Ord Error where   e1 <= e2 = pos e1 <= pos e2  instance Ex.Error Error where   strMsg = errOther . pprint- + errSpan :: TError a -> SrcSpan-errSpan = pos +errSpan = pos  errOther :: Doc -> Error errOther = ErrOther noSrcSpan@@ -1529,10 +1566,10 @@  data Cinfo    = Ci { ci_loc :: !SrcSpan                    , ci_err :: !(Maybe Error)-                   } -                deriving (Eq, Ord) +                   }+                deriving (Eq, Ord) -instance NFData Cinfo +instance NFData Cinfo   ------------------------------------------------------------------------@@ -1546,11 +1583,11 @@   result es = Crash es ""  instance Result Error where-  result (ErrOther _ d) = UnknownError $ render d +  result (ErrOther _ d) = UnknownError $ render d   result e              = result [e]  instance Result (FixResult Cinfo) where-  result = fmap cinfoError  +  result = fmap cinfoError  -------------------------------------------------------------------------------- --- Module Names@@ -1605,11 +1642,10 @@ -------------------------------------------------------------------------------- --- Measures ----------------------------------------------------------------------------------- MOVE TO TYPES-data Measure ty ctor = M { +data Measure ty ctor = M {     name :: LocSymbol   , sort :: ty-  , eqns :: [Def ctor]+  , eqns :: [Def ty ctor]   } deriving (Data, Typeable)  data CMeasure ty@@ -1617,19 +1653,19 @@        , cSort :: ty        } --- MOVE TO TYPES-data Def ctor +data Def ty ctor    = Def {      measure :: LocSymbol+  , dparams :: [(Symbol, ty)]   , ctor    :: ctor -  , binds   :: [Symbol]+  , dsort   :: Maybe ty+  , binds   :: [(Symbol, Maybe ty)]   , body    :: Body   } deriving (Show, Data, Typeable)-deriving instance (Eq ctor) => Eq (Def ctor)+deriving instance (Eq ctor, Eq ty) => Eq (Def ty ctor) --- MOVE TO TYPES-data Body -  = E Expr          -- ^ Measure Refinement: {v | v = e } +data Body+  = E Expr          -- ^ Measure Refinement: {v | v = e }   | P Pred          -- ^ Measure Refinement: {v | (? v) <=> p }   | R Symbol Pred   -- ^ Measure Refinement: {v | p}   deriving (Show, Eq, Data, Typeable)@@ -1640,11 +1676,11 @@   substf f  (M n s es) = M n s $ substf f  <$> es   subst  su (M n s es) = M n s $ subst  su <$> es -instance Subable (Def ctor) where-  syms (Def _ _ _ bd)      = syms bd-  substa f  (Def m c b bd) = Def m c b $ substa f  bd-  substf f  (Def m c b bd) = Def m c b $ substf f  bd-  subst  su (Def m c b bd) = Def m c b $ subst  su bd+instance Subable (Def ty ctor) where+  syms (Def _ sp _ _ sb bd)  = (fst <$> sp) ++ (fst <$> sb) ++ syms bd+  substa f  (Def m p c t b bd) = Def m p c t b $ substa f  bd+  substf f  (Def m p c t b bd) = Def m p c t b $ substf f  bd+  subst  su (Def m p c t b bd) = Def m p c t b $ subst  su bd  instance Subable Body where   syms (E e)       = syms e@@ -1681,9 +1717,9 @@  newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)]) deriving (Generic) -data Annot t      = AnnUse t +data Annot t      = AnnUse t                   | AnnDef t-                  | AnnRDf t +                  | AnnRDf t                   | AnnLoc SrcSpan  instance Monoid (AnnInfo a) where@@ -1695,7 +1731,7 @@   instance NFData a => NFData (AnnInfo a) where-  rnf (AI _) = () +  rnf (AI _) = ()  instance NFData (Annot a) where   rnf (AnnDef _) = ()@@ -1711,18 +1747,18 @@                   , o_errors :: ! [Error]                   , o_types  :: !(AnnInfo a)                   , o_templs :: !(AnnInfo a)-                  , o_bots   :: ![SrcSpan] +                  , o_bots   :: ![SrcSpan]                   , o_result :: FixResult Error                   } deriving (Generic)  emptyOutput = O Nothing [] mempty mempty [] mempty-  -instance Monoid (Output a) where -  mempty        = emptyOutput  ++instance Monoid (Output a) where+  mempty        = emptyOutput   mappend o1 o2 = O { o_vars   = sortNub <$> mappend (o_vars   o1) (o_vars   o2)                     , o_errors = sortNub  $  mappend (o_errors o1) (o_errors o2)-                    , o_types  =             mappend (o_types  o1) (o_types  o2) -                    , o_templs =             mappend (o_templs o1) (o_templs o2) +                    , o_types  =             mappend (o_types  o1) (o_types  o2)+                    , o_templs =             mappend (o_templs o1) (o_templs o2)                     , o_bots   = sortNub  $  mappend (o_bots o1)   (o_bots   o2)                     , o_result =             mappend (o_result o1) (o_result o2)                     }@@ -1732,12 +1768,12 @@ -----------------------------------------------------------  data KVKind-  = RecBindE -  | NonRecBindE -  | TypeInstE +  = RecBindE+  | NonRecBindE+  | TypeInstE   | PredInstE   | LamE-  | CaseE +  | CaseE   | LetE   deriving (Generic, Eq, Ord, Show, Enum, Data, Typeable) @@ -1749,9 +1785,9 @@ emptyKVProf :: KVProf emptyKVProf = KVP M.empty -updKVProf :: KVKind -> [Symbol] -> KVProf -> KVProf +updKVProf :: KVKind -> [KVar] -> KVProf -> KVProf updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + length kvs) m-  where +  where     kn                  = M.lookupDefault 0 k m  instance NFData KVKind where@@ -1761,20 +1797,31 @@   pprint = text . show  instance PPrint KVProf where-  pprint (KVP m) = pprint $ M.toList m +  pprint (KVP m) = pprint $ M.toList m  instance NFData KVProf where-  rnf (KVP m) = rnf m `seq` () +  rnf (KVP m) = rnf m `seq` () -hole = RKvar "HOLE" mempty+-- hasHole (toReft -> (Reft (_, rs))) = any isHole rs -isHole (RKvar ("HOLE") _) = True+hole :: Pred+hole = PKVar "HOLE" mempty++isHole :: Pred -> Bool+isHole (PKVar ("HOLE") _) = True isHole _                  = False -hasHole (toReft -> (Reft (_, rs))) = any isHole rs+hasHole :: Reftable r => r -> Bool+hasHole = any isHole . conjuncts . reftPred . toReft ++-- isHole :: KVar -> Bool+-- isHole "HOLE" = True+-- isHole _      = False++ -- classToRApp :: SpecType -> SpecType--- classToRApp (RCls cl ts) +-- classToRApp (RCls cl ts) --   = RApp (RTyCon (classTyCon cl) def def) ts mempty mempty  instance Symbolic DataCon where
src/Language/Haskell/Liquid/WiredIn.hs view
@@ -23,17 +23,17 @@ -- | LH Primitive TyCons ---------------------------------------------- ----------------------------------------------------------------------- -propTyCon, hpropTyCon :: TyCon +propTyCon, hpropTyCon :: TyCon propTyCon  = symbolTyCon 'w' 24 propConName-hpropTyCon = symbolTyCon 'w' 24 hpropConName  +hpropTyCon = symbolTyCon 'w' 24 hpropConName   ----------------------------------------------------------------------- -- | LH Primitive Types ---------------------------------------------- ----------------------------------------------------------------------- -propType :: Reftable r => RRType r -propType = RApp (RTyCon propTyCon [] defaultTyConInfo) [] [] mempty 	+propType :: Reftable r => RRType r+propType = RApp (RTyCon propTyCon [] defaultTyConInfo) [] [] mempty   @@ -41,7 +41,7 @@ ------ Predicate Types for WiredIns -------------------------------- -------------------------------------------------------------------- -maxArity :: Arity +maxArity :: Arity maxArity = 7  wiredTyCons     = fst wiredTyDataCons@@ -49,25 +49,25 @@  wiredTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, Located DataConP)]) wiredTyDataCons = (concat tcs, mapSnd dummyLoc <$> concat dcs)-  where +  where     (tcs, dcs)  = unzip l     l           = [listTyDataCons] ++ map tupleTyDataCons [2..maxArity]  listTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)]) listTyDataCons   = ( [(c, TyConP [(RTV tyv)] [p] [] [Covariant] [Covariant] (Just fsize))]-                   , [(nilDataCon, DataConP l0 [(RTV tyv)] [p] [] [] [] lt)-                   , (consDataCon, DataConP l0 [(RTV tyv)] [p] [] [] cargs  lt)])+                   , [(nilDataCon, DataConP l0 [(RTV tyv)] [p] [] [] [] lt l0)+                   , (consDataCon, DataConP l0 [(RTV tyv)] [p] [] [] cargs  lt l0)])     where       l0         = dummyPos "LH.Bare.listTyDataCons"       c          = listTyCon-      [tyv]      = tyConTyVars c+      [tyv]      = tyConTyVarsDef c       t          = rVar tyv :: RSort       fld        = "fldList"       x          = "xListSelector"       xs         = "xsListSelector"       p          = PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar fld)]-      px         = pdVarReft $ PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar x)] -      lt         = rApp c [xt] [RPropP [] $ pdVarReft p] mempty                 +      px         = pdVarReft $ PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar x)]+      lt         = rApp c [xt] [RPropP [] $ pdVarReft p] mempty       xt         = rVar tyv       xst        = rApp c [RVar (RTV tyv) px] [RPropP [] $ pdVarReft p] mempty       cargs      = [(xs, xst), (x, xt)]@@ -75,14 +75,14 @@  tupleTyDataCons :: Int -> ([(TyCon, TyConP)] , [(DataCon, DataConP)]) tupleTyDataCons n = ( [(c, TyConP (RTV <$> tyvs) ps [] tyvarinfo pdvarinfo Nothing)]-                    , [(dc, DataConP l0 (RTV <$> tyvs) ps [] []  cargs  lt)])-  where +                    , [(dc, DataConP l0 (RTV <$> tyvs) ps [] []  cargs  lt l0)])+  where     tyvarinfo     = replicate n     Covariant     pdvarinfo     = replicate (n-1) Covariant     l0            = dummyPos "LH.Bare.tupleTyDataCons"     c             = tupleTyCon BoxedTuple n-    dc            = tupleCon BoxedTuple n -    tyvs@(tv:tvs) = tyConTyVars c+    dc            = tupleCon BoxedTuple n+    tyvs@(tv:tvs) = tyConTyVarsDef c     (ta:ts)       = (rVar <$> tyvs) :: [RSort]     flds          = mks "fld_Tuple"     fld           = "fld_Tuple"@@ -98,7 +98,7 @@     mks_ x        = (\i -> symbol (x++ show i)) <$> [2..n]  -pdVarReft = (\p -> U mempty p mempty) . pdVar +pdVarReft = (\p -> U mempty p mempty) . pdVar  mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] [] mkps _  _      _           = error "Bare : mkps"@@ -109,4 +109,3 @@     p                                   = PV n (PVProp t) (vv Nothing) args     a                                   = (t, f, x) mkps_ _     _       _          _    _ = error "Bare : mkps_"-
+ tests/crash/AbsRef.hs view
@@ -0,0 +1,11 @@+module Fixme where+++foo :: [a] -> ()+{-@ foo :: [{v:a | v = 5}] -> () @-}+foo _ = ()+++bar :: a -> b -> a+{-@ bar :: forall<p :: a -> b -> Prop>. x:a -> {xx:b<p> | xx > xx} -> a @-}+bar x y = x
+ tests/crash/BadExprArg.hs view
@@ -0,0 +1,7 @@+module BadExprArg where++{-@ type ListN a N = {v:[a] | len v = N} @-}++{-@ foo :: ListN 0 0 @-}+foo :: [a]+foo = undefined
+ tests/crash/BadSyn1.hs view
@@ -0,0 +1,9 @@+module Zoo where++type Foo = Int++{-@ type Fooz = {v:Int | 1 < v} @-}++{-@ bob :: Fooz 1000 @-}+bob = 10 :: Int+
+ tests/crash/BadSyn2.hs view
@@ -0,0 +1,7 @@+module Zoo where++type Foo = Int++{-@ bob :: Foo 1000 @-}+bob = 10 :: Int+
+ tests/crash/BadSyn3.hs view
@@ -0,0 +1,7 @@+module Zoo where++type Foo = Int++{-@ bob :: Foo String @-}+bob = 10 :: Int+
+ tests/crash/BadSyn4.hs view
@@ -0,0 +1,8 @@+module Foo where++type List a = [a]+type Point  = List Double++{-@ foo :: n:Nat -> Point n @-}+foo :: Int -> List Double+foo _ = []
+ tests/crash/CyclicExprAlias0.hs view
@@ -0,0 +1,4 @@+module Test0 () where++{-@ expression CyclicA1 Q = CyclicA1 Q @-}+
+ tests/crash/CyclicExprAlias1.hs view
@@ -0,0 +1,5 @@+module Test2 () where++{-@ expression CyclicB1 Q = CyclicB2 Q @-}+{-@ expression CyclicB2 Q = CyclicB1 Q @-}+
+ tests/crash/CyclicExprAlias2.hs view
@@ -0,0 +1,7 @@+module Test3 () where++{-@ expression CyclicC1 Q = (CyclicC2 Q) / (CyclicC3 Q) @-}+{-@ expression CyclicC2 Q = CyclicC1 Q @-}+{-@ expression CyclicC3 Q = CyclicC1 Q @-}++
+ tests/crash/CyclicExprAlias3.hs view
@@ -0,0 +1,6 @@+module Test3 () where++{-@ expression CyclicD1 Q = CyclicD2 Q @-}+{-@ expression CyclicD2 Q = CyclicD3 Q @-}+{-@ expression CyclicD3 Q = CyclicD1 Q @-}+
+ tests/crash/CyclicPredAlias0.hs view
@@ -0,0 +1,4 @@+module Test0 () where++{-@ predicate CyclicA1 Q = CyclicA1 Q @-}+
+ tests/crash/CyclicPredAlias1.hs view
@@ -0,0 +1,5 @@+module Test1 () where++{-@ predicate CyclicB1 Q = CyclicB2 Q @-}+{-@ predicate CyclicB2 Q = CyclicB1 Q @-}+
+ tests/crash/CyclicPredAlias2.hs view
@@ -0,0 +1,6 @@+module Test2 () where++{-@ predicate CyclicC1 Q = CyclicC2 Q && CyclicC3 Q @-}+{-@ predicate CyclicC2 Q = CyclicC1 Q @-}+{-@ predicate CyclicC3 Q = CyclicC1 Q @-}+
+ tests/crash/CyclicPredAlias3.hs view
@@ -0,0 +1,6 @@+module Test3 () where++{-@ predicate CyclicD1 Q = CyclicD2 Q @-}+{-@ predicate CyclicD2 Q = CyclicD3 Q @-}+{-@ predicate CyclicD3 Q = CyclicD1 Q @-}+
+ tests/crash/CyclicTypeAlias0.hs view
@@ -0,0 +1,5 @@+module Test0 () where++{-@ type CyclicA1 = CyclicA2 @-}+{-@ type CyclicA2 = CyclicA1 @-}+
+ tests/crash/CyclicTypeAlias1.hs view
@@ -0,0 +1,6 @@+module Test1 () where++{-@ type CyclicB1 = CyclicB2 @-}+{-@ type CyclicB2 = CyclicB3 @-}+{-@ type CyclicB3 = CyclicB1 @-}+
+ tests/crash/CyclicTypeAlias2.hs view
@@ -0,0 +1,4 @@+module Test2 () where++{-@ type CyclicC = [CyclicC] @-}+
+ tests/crash/CyclicTypeAlias3.hs view
@@ -0,0 +1,6 @@+module Test3 () where++{-@ type CyclicD1 = CyclicD2 @-}+{-@ type CyclicD2 = CyclicD3 @-}+{-@ type CyclicD3 = CyclicD2 @-}+
+ tests/crash/FunRef1.hs view
@@ -0,0 +1,4 @@+module Goo where++{-@ foo :: xs:_ -> {v:_ | this = rubbish } @-}+foo _ _ = 0
+ tests/crash/FunRef2.hs view
@@ -0,0 +1,5 @@+module Goo where++{-@ foo :: Num a => { z : (xs:t -> {v : (t -> a) | this = rubbish }) | wow = hi } @-}+foo :: Num a => t -> t -> a+foo _ _ = 0
+ tests/crash/HaskellMeasure.hs view
@@ -0,0 +1,17 @@+module Measures where++llen :: [a] -> Int+llen [] = 0+llen (x:xs) = 1 + llen xs++foo x = x++{-@ measure foo @-}++{-@ measure lllen @-}++{-@ lllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}++lllen :: [a] -> Int	+lllen [] = 0+lllen (x:xs) = 1 + lllen xs
+ tests/crash/LocalHole.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--no-termination" @-}+module LocalHole where++{-@ assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}++mysum xs = go 0 0+  where+    n = length xs+    {-@ go :: i:{Nat | i <= nn} -> _ -> _ @-}+    go i acc+      | i >= n    = acc+      | otherwise = go (i+1) (acc + xs !! i)
+ tests/crash/LocalTermExpr.hs view
@@ -0,0 +1,11 @@+module LocalTermExpr where++{-@ assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}++mysum xs = go 0 0+  where+    n = length xs+    {-@ go :: i:_ -> _ -> _ / [nn - i] @-}+    go i acc+      | i >= n    = acc+      | otherwise = go (i+1) (acc + xs !! i)
+ tests/crash/Mismatch.hs view
@@ -0,0 +1,5 @@+module Mismatch where++{-@ foo :: Nat @-}+foo :: Bool+foo = True
+ tests/crash/MultipleRecordSelectors.hs view
@@ -0,0 +1,24 @@+{-@ LIQUID "--no-termination" @-}+module RedBlack  where+++-- data F = F {fx :: Int, fx :: Int}++data RBTree a = Leaf +              | Node Color a !(RBTree a) !(RBTree a)++data Color = B | R ++{-@ ok :: { v: RBTree Int | false} @-}+ok = Node R (2 :: Int)+         (Node B 1 Leaf Leaf)+         (Node B 3 Leaf Leaf)+++{-@ data RBTree a = Leaf+                  | Node { c     :: Color+                         , key   :: a+                         , left  :: RBTree ({v:a | v < key})+                         , left  :: RBTree ({v:a | key < v})+                         }+  @-}
+ tests/crash/RClass.hs view
@@ -0,0 +1,19 @@+module Crash where++class Foo a where+{-@ class Foo where+      foo :: x:a -> {v:a | v = x}+  @-}+  foo :: a -> a       +++instance Foo Int where+  {-@ instance Foo Int where+       foo :: x:Int -> {v:Int | v = x + 1} @-}+  foo x = x + 1++instance Foo Integer where+  {-@ instance Foo Integer where+       foo :: x:Integer -> {v:Integer | v = x + 1} @-}+  foo x = x + 1+
+ tests/crash/Unbound.hs view
@@ -0,0 +1,7 @@+module Fixme where+++{-@ foo :: forall <p :: s -> s -> Prop>.+                   xs:s<p y> -> s<p xs> @-}+foo :: s -> s+foo s = s
+ tests/crash/funref.hs view
@@ -0,0 +1,9 @@+module Goo () where++cnt   :: Int -> Int+cnt 0 = 0+cnt i = 1 + cnt (i-1)++{-@ three :: {v:Int | (cnt v) = 3} @-}+three :: Int+three = 15
+ tests/crash/hole-crash1.hs view
@@ -0,0 +1,7 @@+module ListDemo where++data Poo a = C { t :: Poo a }++{-@ type Geq N = {v:_ | N <= v} @-}++{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
+ tests/crash/hole-crash2.hs view
@@ -0,0 +1,7 @@+module ListDemo where++data Poo a = C { t :: Poo a }++{-@ type Geq a N = {v:a | N <= v} @-}++{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
+ tests/crash/hole-crash3.hs view
@@ -0,0 +1,18 @@+module ListDemo where++data List a = E | (:::) { h :: a, t :: List a }++infixr  9 ::: ++{-@ countUp :: n:Int -> List Int @-}+countUp n  = n ::: countUp (n + 1)++++++++++
+ tests/crash/num-float-error.hs view
@@ -0,0 +1,9 @@+module Crash where++{-@ f :: (Num a) => {v:a | v > 0.0} -> a @-}+f :: (Num a) => a -> a+f a = a + 1++{-@ g :: (Num a) => {v:a | v > 0.0} -> a @-}+g :: (Num a) => a -> a+g = f
+ tests/crash/num-float-error1.hs view
@@ -0,0 +1,5 @@+module Crash where++{-@ f :: (Num a) => {v:a | v > 0.0} -> a @-}+f :: (Num a) => a -> a+f a = a + 1
+ tests/crash/typeAliasDup.hs view
@@ -0,0 +1,17 @@+module Goo () where++import Language.Haskell.Liquid.Prelude++{-@ type BoundedNat N = {v:Nat | v < N } @-}+{-@ predicate Foo V N = V < N            @-}++-- TODO: Test fails when this second alias is ALSO defined.+-- FIX: should WARN that there are duplicate aliases!++{-@ type BoundedNat N = {v:Nat | v <= N } @-}+{-@ predicate Foo V N = V <= N            @-}+++{-@ foo :: n:Int -> m:(BoundedNat n) -> Nat @-}+foo :: Int -> Int -> Int+foo n m = liquidAssert (m < n) m
+ tests/neg/Baz.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--short-names" @-}++module Baz where++{-@ incr :: x:Int -> {v:Int | v < x } @-}+incr   :: Int -> Int+incr xana = id $ xana + 1+++{-@ iincr :: x:Int -> {v:Int | v < x } @-}+iincr   :: Int -> Int+iincr x = x + 1+++
+ tests/neg/CastedTotality.hs view
@@ -0,0 +1,14 @@+module Fixme where++{-@ LIQUID "--totality" @-}++import Language.Haskell.Liquid.Prelude++main = show x+  where Just x = (Nothing :: Maybe Int)+++main0 = do +     let Just x = Nothing +     print (x :: Int)+
+ tests/neg/Class1.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-@ LIQUID "--no-termination" @-}+module Class () where++import Language.Haskell.Liquid.Prelude+import Prelude hiding (sum, length, (!!), Functor(..))+import qualified Prelude as P++{-@ qualif Sz(v:int, xs:a): v = (sz xs) @-}++{-@ data List a = Nil | Cons (hd::a) (tl::(List a)) @-}+data List a = Nil | Cons a (List a)++{-@ length :: xs:List a -> {v:Nat | v = (sz xs)} @-}+length :: List a -> Int+length Nil         = 0+length (Cons x xs) = 1 + length xs++{-@ (!!) :: xs:List a -> {v:Nat | v < (sz xs)} -> a @-}+(!!) :: List a -> Int -> a+Nil         !! i = undefined+(Cons x _)  !! 0 = x+(Cons x xs) !! i = xs !! (i - 1)++{-@ class measure sz :: forall a. a -> Int @-}+{-@ class Sized s where+      size :: forall a. x:s a -> {v:Nat | v = (sz x)}+  @-}+class Sized s where+  size :: s a -> Int++instance Sized List where+  {-@ instance measure sz :: List a -> Int+      sz (Nil)       = 0+      sz (Cons x xs) = 1 + (sz xs)+    @-}+  size = length++{-@ class (Sized s) => Indexable s where+      index :: forall a. x:s a -> {v:Nat | v < (sz x)} -> a+  @-}+class (Sized s) => Indexable s where+  index :: s a -> Int -> a+++instance Indexable List where+  index = (!!)++{-@ sum :: Indexable s => s Int -> Int @-}+sum :: Indexable s => s Int -> Int+sum xs = go max 0+  where+    max = size xs+    go (d::Int) i+      | i < max   = index xs i + go (d-1) (i+1)+      | otherwise = 0+++{-@ sumList :: List Int -> Int @-}+sumList :: List Int -> Int+sumList xs = go max 0+  where+    max = size xs+    go (d::Int) i+      | i < max   = index xs i + go (d-1) (i+1)+      | otherwise = index xs i++
+ tests/neg/Class2.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-@ LIQUID "--no-termination" @-}+module Class () where++import Language.Haskell.Liquid.Prelude++{-@ class measure sz :: forall a. a -> Int @-}+{-@ class Sized s where+      size :: forall a. x:s a -> {v:Nat | v = (sz x)}+  @-}+class Sized s where+  size :: s a -> Int++instance Sized [] where+  {-@ instance measure sz :: [a] -> Int+      sz ([])   = 0+      sz (x:xs) = 1 + (sz xs)+    @-}+  size []     = 0+  size (x:xs) = 1 + size xs++{-@ class (Sized s) => Indexable s where+      index :: forall a. x:s a -> {v:Nat | v < (sz x)} -> a+  @-}+class (Sized s) => Indexable s where+  index :: s a -> Int -> a+++instance Indexable [] where+  index = (!!)+++
+ tests/neg/Class3.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-@ LIQUID "--no-termination" @-}+module Class where++import Language.Haskell.Liquid.Prelude+import Prelude hiding (sum, length, (!!), Functor(..))+import qualified Prelude as P++{-@ qualif Sz(v:int, xs:a): v = (sz xs) @-}++{-@ data List a = Nil | Cons (hd::a) (tl::(List a)) @-}+data List a = Nil | Cons a (List a)+++{-@ class measure sz :: forall a. a -> Int @-}+{-@ class Sized s where+      size :: forall a. x:s a -> {v:Nat | v = (sz x)}+  @-}+class Sized s where+  size :: s a -> Int++instance Sized List where+  {-@ instance measure sz :: List a -> Int+      sz (Nil)       = 0+      sz (Cons x xs) = 1 + (sz xs)+    @-}+  size Nil         = 0+  size (Cons x xs) = size xs+++
+ tests/neg/Class4.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-@ LIQUID "--no-termination" @-}++module Class4 where++import Language.Haskell.Liquid.Prelude++class Frog a where+  mkInt :: a -> Int+  mkInt _ = liquidAssert (0 > 1) 10++{-@ class Frog a where+      mkInt :: a -> Int+  @-}++instance Frog Int where+
+ tests/neg/Class5.hs view
@@ -0,0 +1,11 @@+module Class5 where++{-@ class Foo a where+      foo :: a -> Nat+  @-}++class Foo a where+  foo :: a -> Int+  foo _ = 0 - 10++
+ tests/neg/CompareConstraints.hs view
@@ -0,0 +1,34 @@+module Foo where++import Language.Haskell.Liquid.Prelude+++{-@ mycmp :: forall <p :: a -> Prop, q :: a -> Prop>. +           {x::a<p>, y::a<q> |-  a <: {v:a | x <= y} } +           Ord a => +           [a<p>] -> [a<q>] -> Bool @-}+mycmp :: Ord a => [a] -> [a] -> Bool+mycmp (x:_) (_:y:_) = liquidAssert (x <= y) True+++{-@ mycmp' :: forall <p :: a -> Prop, q :: a -> Prop>. +           {x::a<p> , y::a<q> |- a <: {v:a | x <= y} } +           Ord a => +           a<p> -> a<q> -> Bool @-}+mycmp' :: Ord a => a -> a -> Bool+mycmp' x y = liquidAssert (x <= y) True++bar :: Bool+bar = let w = choose 0 in +      let x = w + 1 in +      let y = w - 1 in +      let z = w + 2 in +      mycmp [x, y, x, z] [z, x, z]+++bar' :: Bool+bar' = let w = choose 0 in +      let x = w + 1 in +      let y = w - 1 in +      let z = w + 2 in +      mycmp' z y
+ tests/neg/Constraints.hs view
@@ -0,0 +1,39 @@+module Compose where++{-@ +cmp :: forall < pref :: b -> Prop, postf :: b -> c -> Prop+              , pre  :: a -> Prop, postg :: a -> b -> Prop+              , post :: a -> c -> Prop+              >. +       {xx::a<pre>,  w::b<postg xx> |- c<postf w> <: c<post xx>}+       {ww::a<pre> |- b<postg ww> <: b<pref>}+       f:(y:b<pref> -> c<postf y>)+    -> g:(z:a<pre > -> b<postg z>)+    -> x: a<pre> -> c<post x>+@-}++cmp :: (b -> c)+    -> (a -> b)+    ->  a -> c++cmp f g x = f (g x)    ++++{-@ incr :: x:Nat -> {v:Nat | v == x + 1} @-}+incr :: Int -> Int+incr x = x + 1+++{-@ incr2 :: x:Nat -> {v:Nat | v == x + 3} @-}+incr2 :: Int -> Int+incr2 = cmp incr incr+++++++++
+ tests/neg/ConstraintsAppend.hs view
@@ -0,0 +1,40 @@+module ListSort () where++{-@ LIQUID "--no-termination" @-}++import Language.Haskell.Liquid.Prelude++{-@ type OList a = [a]<{\x v -> v >= x}> @-}+++{-@ app :: forall <p :: a -> Prop, q :: a -> Prop, r :: a -> Prop>.+        {x::a<p> |- a<q> <: {v:a| x <= v}} +        {a<p> <: a<r>} +        {a<q> <: a<r>} +        Ord a => OList (a<p>) -> OList (a<q>) -> OList a<r> @-}+app :: Ord a => [a] -> [a] -> [a]+app []     ys = ys+app (x:xs) ys = x:(app xs (x:ys)) ++takeL :: Ord a => a -> [a] -> [a]+{-@ takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}] @-}+takeL x []     = []+takeL x (y:ys) = if (y<x) then y:(takeL x ys) else takeL x ys++takeGE :: Ord a => a -> [a] -> [a]+{-@ takeGE :: Ord a => x:a -> [a] -> [{v:a|v>=x}] @-}+takeGE x []     = []+takeGE x (y:ys) = if (y>=x) then y:(takeGE x ys) else takeGE x ys+++{-@ quicksort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}+quicksort []     = []+quicksort (x:xs) = app xsle (x:xsge)+  where xsle = quicksort (takeL x xs)+        xsge = quicksort (takeGE x xs)++{-@ qsort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}+qsort []     = []+qsort (x:xs) = app  (qsort [y | y <- xs, y < x]) (x:(qsort [z | z <- xs, z >= x])) ++
+ tests/neg/Eval.hs view
@@ -0,0 +1,34 @@+module Eval (eval) where++import Language.Haskell.Liquid.Prelude (liquidError)+import Prelude hiding (lookup)++type Val  = Int++type Bndr = Int++data Expr = Const Int+          | Var   Bndr+          | Plus  Expr Expr+          | Let   Bndr Expr Expr++type Env  = [(Bndr, Val)]++----------------------------------------------------------------+lookup                 :: Bndr -> Env -> Val+---------------------  -------------------------------------------+lookup x ((y,v):env)   +  | x == y             = v+  | otherwise          = lookup x env+lookup x []            = liquidError "Unbound Variable"++----------------------------------------------------------------+eval :: Env -> Expr -> Val+----------------------------------------------------------------+eval env (Const i)     = i+eval env (Var x)       = lookup x env +eval env (Plus e1 e2)  = eval env e1 + eval env e2 +eval env (Let x e1 e2) = eval env' e2 +  where +    env'               = (x, eval env e1) : env+
+ tests/neg/Even.hs view
@@ -0,0 +1,9 @@+module Even () where++{-@ isEven, isOdd :: Nat -> Bool @-}+isEven :: Int -> Bool+isEven 0 = True+isEven n = isOdd  $ n++isOdd  0 = False+isOdd  m = isEven $ m - 1
+ tests/neg/GeneralizedTermination.hs view
@@ -0,0 +1,13 @@+module GenTerm () where++foo :: Int -> Int -> Int+{-@ foo :: n:Nat -> m:Nat -> Nat /[n+m] @-}++foo n m +  | cond 1 = 0+  | cond 2 && n > 1 = foo (n-1) m+  | cond 3 && m > 2 = foo (n+10) (m-2)+ +{-@ cond :: Int -> Bool @-}+cond :: Int -> Bool+cond _ = undefined
+ tests/neg/HasElem.hs view
@@ -0,0 +1,24 @@+module HasElem where++{-@ LIQUID "--no-termination" @-}++data L a = Nil | Cons a (L a)++{-@ measure hasElem @-}+hasElem :: Eq a => a -> L a -> Bool+hasElem x Nil = False+hasElem x (Cons y ys) = x == y || hasElem x ys++{-@ prop, prop1, prop2 :: {v:Bool | Prop v <=> true} @-}+prop :: Bool+prop = hasElem 1 (Cons 1 Nil)++prop1 :: Bool+prop1 = hasElem 1 (Cons 2 Nil)++prop2 :: Bool+prop2 = hasElem 1 Nil+++nil = Nil+cons = Cons
+ tests/neg/HolesTop.hs view
@@ -0,0 +1,8 @@+module HolesTop where++import Language.Haskell.Liquid.Prelude++{-@ foo :: _ -> Bool @-}+foo = liquidAssertB++bar = foo True
+ tests/neg/LazyWhere.hs view
@@ -0,0 +1,13 @@+module LazyWhere () where++import Language.Haskell.Liquid.Prelude++{-@ pos :: Nat -> Int @-}+pos :: Int -> Int+pos = undefined+++{-@ LAZYVAR z @-}+foo = if x > 0 then z else z+  where z = pos x+        x = choose 0
+ tests/neg/LazyWhere1.hs view
@@ -0,0 +1,21 @@+module LazyWhere () where++import Language.Haskell.Liquid.Prelude++{-@ pos :: Nat -> Int @-}+pos :: Int -> Int+pos = undefined++{-@ safeDiv :: Int -> {v:Int| v != 0} -> Int @-}+safeDiv :: Int -> Int -> Int+safeDiv = undefined+++-- Limitations :: Definitions of lazy variables should be alpha renamed,+--  otherwise, internal variables will be created and the expression will be+--  unsafe++{-@ LAZYVAR z @-}+foo = if x > 0 then z else x+  where z  = (42 `safeDiv` x) + ( pos x)+        x = choose 0
+ tests/neg/LiquidClass.hs view
@@ -0,0 +1,43 @@+module LiquidClass where+++-- | Typing classes+-- | Step 1: Refine type dictionaries:++class Compare a where+	cmax :: a -> a -> a+	cmin :: a -> a -> a++instance Compare Int where	+{-@ instance Compare Int where +	cmax :: Odd -> Odd -> Odd ;+	cmin :: Int -> Int -> Int+  @-}++	cmax y x = if x >= y then x else y+  	cmin y x = if x >= y then x else y++-- | creates dictionary environment:+-- | * add the following environment+-- | dictionary $fCompareInt :: Compare Int+-- |               { $ccmax :: Odd -> Odd -> Odd+-- |               , $ccmin :: Int -> Int -> Int+-- |               }+-- |+-- | Important: do not type dictionaries, as preconditions+-- | of fields cannot be satisfied!!!!!+++-- | Dictionary application +-- | ((cmax Int)    @fcompareInt) :: Odd -> Odd -> Odd+-- | ((cmin Int)    @fcompareInt) :: Int -> Int -> Int+-- | (anything_else @fcompareInt) :: default+++{-@ foo :: Odd -> Odd -> Odd @-}+foo :: Int -> Int -> Int+foo x y = cmax x y ++{-@ unsafe :: Odd -> Odd -> Odd @-}+unsafe :: Int -> Int -> Int+unsafe x y = cmin x y
+ tests/neg/LiquidClass1.hs view
@@ -0,0 +1,39 @@+module LiquidClass where+++-- | Typing classes+-- | Step 1: Refine type dictionaries:++class Compare a where+	cmax :: a -> a -> a+	cmin :: a -> a -> a++instance Compare Int where	+{-@ instance Compare Int where +	cmax :: Odd -> Odd -> Odd ;+	cmin :: Int -> Int -> Odd+  @-}++	cmax y x = if x >= y then x else y+  	cmin y x = if x >= y then x else y++-- | creates dictionary environment:+-- | * add the following environment+-- | dictionary $fCompareInt :: Compare Int+-- |               { $ccmax :: Odd -> Odd -> Odd+-- |               , $ccmin :: Int -> Int -> Int+-- |               }+-- |+-- | Important: do not type dictionaries, as preconditions+-- | of fields cannot be satisfied!!!!!+++-- | Dictionary application +-- | ((cmax Int)    @fcompareInt) :: Odd -> Odd -> Odd+-- | ((cmin Int)    @fcompareInt) :: Int -> Int -> Int+-- | (anything_else @fcompareInt) :: default+++{-@ foo :: Odd -> Odd -> Odd @-}+foo :: Int -> Int -> Int+foo x y = cmax x y
+ tests/neg/ListConcat.hs view
@@ -0,0 +1,21 @@+module Foo () where+import Data.Set (Set(..)) +import Prelude hiding (concat)++{-@ measure llElts :: [[a]] -> (Set a) +    llElts([])   = {v | Set_emp v }+    llElts(x:xs) = {v | v = Set_cup (listElts x) (llElts xs) }+  @-}+++{-@ concat :: ys:[[a]] -> {v:[a] | listElts v = llElts ys } @-}+concat :: [[a]] ->  [a]+concat  []         = []+concat ([]: xs)    = concat xs+concat ((y:ys):xs) = concat (ys:xs)++++++
+ tests/neg/ListDataCons.hs view
@@ -0,0 +1,16 @@+module Fixme where++data L a = N +++{-@ lnil :: {v:L a | v == Fixme.N } @-} +lnil :: L a +lnil = N++{-@ hnil :: {v:[Int] | v == []} @-} +hnil :: [Int] +hnil = [0] ++{-@ hcons :: x:a -> a -> xs:[a] -> {v:[a] | v == x:xs} @-} +hcons :: a -> a -> [a] -> [a] +hcons _ = (:)
+ tests/neg/ListElem.hs view
@@ -0,0 +1,15 @@+module ListElem () where++import Data.Set++{-@ listElem :: (Eq a) +             => y:a +             -> xs:[a]+             -> {v:Bool | (Prop(v) <=> Set_mem(y, (listElts(xs))))} +  @-}++listElem :: (Eq a) => a -> [a] -> Bool+listElem _ []     = False+listElem y (x:xs) | x == y    = True+                  | otherwise = True -- listElem y xs+
+ tests/neg/ListISort-LType.hs view
@@ -0,0 +1,52 @@+module ListRange () where++import Language.Haskell.Liquid.Prelude+++data List a = Nil | Cons a (List a)++-- isOdd x = not (isEven x)+-- isEven x = not (isOdd x)++-- foo x = x+1++insert y Nil         +  = Cons y Nil+insert y (Cons x xs) | (y <= x) +  = let ys1 = Cons x xs in+    let ys2 = Cons y ys1 in ys2+insert y (Cons x xs) | (x <  y)+  = let xs1 = insert y xs in+    let xs2 = Cons x xs1 in xs2++chk2 y = +  case y of +   Nil -> True+   Cons x1 xs -> case xs of +                 Nil -> True+                 Cons x2 xs2 -> liquidAssertB (x1 == x2) && chk2 xs2+																	+n, m :: Int+n = choose 0+m = choose 0++-- bar = insert n (range 2 8)+bar = insert n (insert m Nil)++range l h = if l <=h then Cons l (range (l+1) h) else Nil+++mkList :: [a] -> List a																	+mkList = foldr Cons Nil++prop0 = chk2 bar++++++++++
+ tests/neg/ListISort.hs view
@@ -0,0 +1,23 @@+module ListSort () where++import Language.Haskell.Liquid.Prelude++insert y []     = [y]+insert y (x:xs) = if (y<=x) then (y:(x:xs)) else (x:(insert y xs))++chk [] = liquidAssertB True+chk (x1:xs) = case xs of +               []     -> liquidAssertB True+               x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs+																	+sort = foldr insert []++rlist = map choose [1 .. 10]++bar = sort rlist++bar1 :: [Int]+bar1 = [1, 8, 2, 4, 5]++prop0 = chk rlist+prop1 = chk bar1
+ tests/neg/ListKeys.hs view
@@ -0,0 +1,19 @@+module Foo () where+import Data.Set (Set(..)) ++{-@ measure listKeys :: [(k, v)] -> (Set k)+    listKeys([])   = {v | Set_emp v }+    listKeys(x:xs) = {v | v = Set_cup (Set_sng (fst x)) (listKeys xs) }+  @-}+++{-@ getFsts :: ys:[(a, a)] -> {v:[a] | listElts v = listKeys ys } @-}+getFsts ::[(a, a)] ->  [a]+getFsts []           = []+getFsts ((_, x): xs) = x : getFsts xs++++++
+ tests/neg/ListMSort.hs view
@@ -0,0 +1,34 @@+module ListSort () where++import Language.Haskell.Liquid.Prelude+++split :: [a] -> ([a], [a])+split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs+split xs                   = (xs, [])++merge :: Ord a => [a] -> [a] -> [a]+merge xs [] = xs+merge [] ys = ys+merge (x:xs) (y:ys)+  | x <= y+  = x:(merge xs (y:ys))+  | otherwise +  = y:(merge (x:xs) ys)++{-@ mergesort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v < fld)}>  @-}+mergesort :: Ord a => [a] -> [a]+mergesort [] = []+mergesort [x] = [x]+mergesort xs = merge (mergesort xs1) (mergesort xs2) where (xs1, xs2) = split xs++chk [] = liquidAssertB True+chk (x1:xs) = case xs of +               []     -> liquidAssertB True+               x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs+																	+rlist = map choose [1 .. 10]++bar = mergesort rlist++prop0 = chk bar
+ tests/neg/ListQSort.hs view
@@ -0,0 +1,34 @@+module ListSort () where++import Language.Haskell.Liquid.Prelude++append k []     ys = k:ys+append k (x:xs) ys = x:(append k xs ys) ++takeL x []     = []+takeL x (y:ys) = if (y<x) then y:(takeL x ys) else takeL x ys++takeGE x []     = []+takeGE x (y:ys) = if (y>=x) then y:(takeGE x ys) else takeGE x ys+++{-@ quicksort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v < fld)}>  @-}+quicksort []     = []+quicksort (x:xs) = append x xsle xsge+  where xsle = quicksort (takeL x xs)+        xsge = quicksort (takeGE x xs)++++++chk [] = liquidAssertB True+chk (x1:xs) = case xs of +               []     -> liquidAssertB True+               x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs+																	+rlist = map choose [1 .. 10]++bar = quicksort rlist++prop0 = chk bar
+ tests/neg/ListRange.hs view
@@ -0,0 +1,24 @@+module ListRange () where++import Language.Haskell.Liquid.Prelude+++data List a = Nil | Cons a (List a)++{-+low, high :: Int+low  = 0+high = 10+-}++range l h = +  if l <= h then Cons l (range (l+1) h) else Nil++chk y = +  case y of +   Nil -> True+   Cons x1 xs -> case xs of +                 Nil -> True+                 Cons x2 xs2 -> liquidAssertB (x1 == x2) && chk xs2++prop3 = chk $ range 1 100
+ tests/neg/LocalSpec.hs view
@@ -0,0 +1,14 @@+module Foo () where++import Language.Haskell.Liquid.Prelude (choose)+++prop = if x < 0 then bar x else x+  where x = choose 0+    {-@ bar :: Nat -> Nat @-}+        bar :: Int -> Int+        bar x = x++{-@ bar :: a -> {v:Int | v = 9} @-}+bar :: a -> Int+bar _ = 8
+ tests/neg/MeasureContains.hs view
@@ -0,0 +1,26 @@+module Fixme where++import Language.Haskell.Liquid.Prelude++{-@ LIQUID "--no-termination" @-}++{-@ measure containsV @-}+{-@ measure binderContainsV @-}+++binderContainsV ::  Binder n -> Bool+binderContainsV B     = True+binderContainsV (M x) = containsV x++data Binder n = B | M (TT n)+data TT n     = V Int | Other | Bind (Binder n) (TT n)++containsV :: TT n -> Bool+containsV (V i)           = True+containsV (Bind b body) = (binderContainsV b) || (containsV body)+-- containsV (App f arg)     = (containsV f) || (containsV arg)+-- containsV (Proj tm i)     = containsV tm+containsV _               = False+++prop1 = liquidAssert (containsV $ Other)
+ tests/neg/MeasureDups.hs view
@@ -0,0 +1,34 @@+module Measures where++import Data.Set ++{-@ LIQUID "--no-termination" @-}+{-@ measure elements @-}+{-@ measure dups @-}++data F a = F a |  C a (F a) | E ++dups :: Ord a => F a -> Set a+dups E        = empty+dups (F a)    = empty+dups (C x xs) = if member x (elements xs) then singleton x `union` dups xs else dups xs++elements :: Ord a => F a -> Set a+elements E        = empty+elements (F a)    = singleton a+elements (C x xs) = singleton x `union` elements xs++++{-@ foo :: (Ord a) => x:F a -> {v:Set a | (dups x) = v} @-}+foo :: Ord a => F a -> Set a+foo E        = empty+foo (F a)    = empty+foo (C x xs) = if member x (elements xs) then singleton x `union` foo xs else foo xs++++{-@ prop :: { v: Bool  | (Prop v) <=> true } @-}+prop = dups s == empty+  where +  	s = C 1 (C 3 (F 1)) :: F Int
+ tests/neg/NoExhaustiveGuardsError.hs view
@@ -0,0 +1,6 @@+module Foo where++{-@ LIQUID "--totality" @-}+bar :: Int -> Int -> Int+bar x y | x >  y = 1+        | x == y = 0
+ tests/neg/NoMethodBindingError.hs view
@@ -0,0 +1,12 @@+module Foo where++{-@ LIQUID "--totality" @-}++class Foo a where+  foo :: a -> a++instance Foo Int where+-- no method binding error+--+goo :: Int -> Int+goo = foo
+ tests/neg/PairMeasure.hs view
@@ -0,0 +1,18 @@+module Foo () where++{-@ measure getfst :: (a, b) -> a+    getfst (x, y) = x+  @-}++{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}++{-@ type OPList a b = [(Pair a b)]<\h -> {v: (Pair a b) | (getfst v) >= (getfst h)}> @-}++{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}++{-@ getFsts          :: OPList a b -> OList a @-}+getFsts []           = [] +getFsts ((x,_) : xs) = x : getFsts xs++{-@ canary :: a -> {v:a | false} @-}+canary x = x
+ tests/neg/PairMeasure0.hs view
@@ -0,0 +1,20 @@+module Foo () where++{-@ measure getfst :: (a, b) -> a+    getfst (x, y) = x+  @-}++{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}+{-@ type OPList a b = [(Pair a b)]<\h -> {v: (Pair a b) | (getfst v) >= (getfst h)}> @-}+{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}+++-- This is Unsafe, as refinements in Predicate parameters (i.e., Pair a b)+-- are lost, so application `getFsts` cannot be proven safe+{-@ getFsts          :: OPList a b -> OList a @-}+getFsts :: [(a, b)] -> [a]+getFsts []           = [] +getFsts ((x,_) : xs) = x : getFsts xs+++
+ tests/neg/Propability.hs view
@@ -0,0 +1,37 @@+module Propability where++{-@ LIQUID "--real" @-}++{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}++{-@ p :: Propability @-}+p :: Double+p = 0.8++{-@ q :: Propability @-}+q :: Double+q = 1.8++++data DPD k = DPD [Pair k Double]++data Pair x y = P x y+{-@ data DPD k = DPD (val::{v:[Pair k Propability]|(total v) = 1.0 }) @-}++{-@ measure total :: [Pair k Double] -> Double +    total([]) = 0.0+    total(x:xs) = (sndP x) + (total xs)+  @-}++{-@ measure sndP :: (Pair x Double) -> Double+    sndP(P x y) = y+  @-}+++dpd0 :: DPD Int+dpd0 = DPD [P 1 0.8, P 2 0.1, P 3 0.1]++dpd1 :: DPD Int+dpd1 = DPD [P 1 0.8, P 2 0.1, P 3 0.1, P 4 0.1]+
+ tests/neg/Propability0.hs view
@@ -0,0 +1,37 @@+module Propability where+++{- NIKI TO FIX:+   this should be SAFE but z3 doesnot like it because +   snd :: Int -> Int instead of +   snd :: Int -> Real +-}++{-@ LIQUID "--real" @-}++{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}++{-@ p :: Propability @-}+p :: Double+p = 0.8++{-@ q :: Propability @-}+q :: Double+q = 1.8++++data DPD k = DPD [(k, Double)]++{-@ data DPD k = DPD (val::{v:[(k, Propability)]|(total v) = 1.0 }) @-}++{-@ measure total :: [(k, Double)] -> Double +    total([]) = 0.0+    total(x:xs) = (snd x) + (total xs)+  @-}++++dpd0 :: DPD Int+dpd0 = DPD [(1, 0.9), (2, 0.1)]+
+ tests/neg/RG.hs view
@@ -0,0 +1,135 @@+module RG where++import Data.IORef as R++{- Liquid Rely-Guarantee References / RG-Haskell++   This is an embedding of a slightly simplified rely-guarantee reference system.+   (See "Rely-Guarantee References for Refinement Types over Aliased Mutable Data,"+   by Gordon, Ernst, and Grossman, PLDI'13.  I promise to never use such a long paper+   title ever again.)++   The key idea in that paper is to augment each reference with a predicate refining+   the referent and heap reachable from it, and binary relations describing permitted+   local actions (the guarantee) and possible remote actions (the rely):+   +                ref{T|P}[R,G]+   +   The terminology comes from rely-guarantee reasoning, from the concurrent program+   logic literature.  As long as+   each reference's guarantee relation is a subrelation of any alias's rely (plus some+   subtle side conditions about nested references), any predicate P that is /stable/+   with respect to a rely R on a given reference (forall x y, P x -> R x y -> P y)+   is trivially preserved by any update through an alias that respects that alias's+   guarantee relation.++   Embedding into Liquid Haskell instead of Coq requires a few weakenings of the+   original design, so we lose expressiveness but gain substantially from automation+   and being a refinement of a language with real programs!  The main simplifications are:+    - TEMPORARILY, rely and guarantee are the same, until we get rolling.  In general,+      we must always have that the guarantee implies the rely, since Haskell wouldn't+      respect the substructural restrictions.  Leaving them the same makes weakening the+      guarantee unsound, so we should fix this soon.+    - Predicates and relations can refer only to the immediate referent for now.+    - Folding (pushing a local restriction through to new references reached via+      dereference) doesn't exist in this system, mostly because all predicates and+      relations can restrict only one cell.++-}++{- We wrap IORefs in a new constructor to add ghost parameters for the predicate and+   relation(s).  It is a standard GHC optimization to eliminate the overhead since there is a single+   constructor with one physical argument, so at runtime these will look the same as IORefs:+   we won't pay time or space overhead. -}+{-@ data RGRef a <p :: a -> Prop, r :: a -> a -> Prop > +    = Wrap (rr :: R.IORef a<p>) @-}+data RGRef a = Wrap (R.IORef a)++{- A stability proof can be embedded into LH as a function of type:+    x:a<p> -> y:a<r x> -> {v:a<p> | v = y}+    This encodes the requirement that knowing P x and R x y is sufficient to deduce P y.+-}+-- Requires explicit type anno for LH type to refine the inferred Haskell type+{-@ stable_monocount :: x:{v:Int | v > 0 } -> y:{v:Int | x <= v } -> {v:Int | ((v = y) && (v > 0)) } @-}+stable_monocount :: Int -> Int -> Int+stable_monocount x y = y++-- Testing / debugging function+{-@ generic_accept_stable :: forall <p :: a -> Prop, r :: a -> a -> Prop >.+                    f:(x:a<p> -> y:a<r x> -> {v:a<p> | (v = y)}) ->+                    ()+                    @-}+generic_accept_stable :: (a -> a -> a) -> ()+generic_accept_stable pf = ()++{-@ proves_reflexivity :: x:{v:Int | v > 0} -> y:{v:Int | v > 0} -> {v:Int | v > 0} @-}+proves_reflexivity :: Int -> Int -> Int+proves_reflexivity x y = x++test :: ()+test = generic_accept_stable proves_reflexivity++{-@ proves_nothing :: x:a -> y:a -> {v:a | (v = y)} @-}+proves_nothing :: a -> a -> a+proves_nothing x y = y --proves_nothing x y++{- TODO: e2 is a hack to sidestep the inference of false for r,+   it forces r to be inhabited. -}+{-@ newRGRef :: forall <p :: a -> Prop, r :: a -> a -> Prop >.+                    e:a<p> -> +                    e2:a<r e> ->+                    f:(x:a<p> -> y:a<r x> -> {v:a<p> | (v = y)}) ->+                    IO (RGRef <p, r> a) @-}+newRGRef :: a -> a -> (a -> a -> a) -> IO (RGRef a)+newRGRef e e2 stabilityPf = do {+                            r <- newIORef e;+                            return (Wrap r)+                         }++-- LH's assume statement seems to only affect spec files+{-@ readRGRef :: forall <p :: a -> Prop, r :: a -> a -> Prop >.+                    RGRef<p, r> a -> IO (a<p>) @-}+readRGRef (Wrap x) = readIORef x++-- TODO: full spec, fix pf type+writeRGRef :: RGRef a -> a -> (a -> a -> Bool) -> IO ()+writeRGRef  (Wrap x) e pf = writeIORef x e+++{- modifyRGRef :: forall <p :: a -> Prop, r :: a -> a -> Prop >.+                    r:(RGRef<p, r> a) ->+                    f:(x:a<p> -> a<r x>) ->+                    pf:(x:a<p> -> y:a<r x> -> {v:a<p> | (v = y)}) ->+                    IO () @-}+modifyRGRef :: RGRef a -> (a -> a) -> (a -> a -> a) -> IO ()+modifyRGRef (Wrap x) f pf = modifyIORef x (\ v -> pf v (f v))+--+--{- modifyRGRef' :: forall <p :: a -> Prop, r :: a -> a -> Prop >.+--                    RGRef<p, r> a ->+--                    f:(x:a<p> -> a<r x>) ->+--                    IO () @-}+---- TODO: strictify, so we don't de-optimize modifyIORef' calls+--modifyRGRef' (Wrap x) f = modifyIORef x f+--+--+main = do {+          r <- newRGRef 1 3 stable_monocount; -- SHOULD BE ref{Int|>0}[<=,<=]+          -- Instead we get ref{Int|>0}[false,false] !+          r2 <- newRGRef 2 9 proves_nothing;  -- SHOULD BE ref{Int|>0}[havoc,havoc].+          -- Instead we get ref{Int|>0}[false,false] !+          --r3 <- newRGRef 3 10 proves_reflexivity; -- BAD, correctly rejected+          return ()+       }+++-- What are the subtyping rules for data structure params that aren't+-- used within the structure?+{-@ unused_contra :: RGRef <{\x -> x > 0}, {\x y -> x <= y}> Int -> RGRef <{\x -> x > 0}, {\x y -> false}> Int @-}+unused_contra :: RGRef Int -> RGRef Int+unused_contra r = r+++{-@ unused_covar :: RGRef <{\x -> x > 0}, {\x y -> false}> Int -> RGRef <{\x -> x > 0}, {\x y -> x <= y}> Int @-}+unused_covar :: RGRef Int -> RGRef Int+unused_covar r = r+-- It looks like there's simply no constraint!
+ tests/neg/RecQSort.hs view
@@ -0,0 +1,30 @@+module GhcSort () where++{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}++{-@ assert sort3 :: (Ord a) => [a] -> OList a @-}+sort3 :: (Ord a) => [a] -> [a]+sort3 ls = qsort ls +  where d = (length ls) +++qsort:: (Ord a) => [a] -> [a]+{-@ qsort:: (Ord a) => xs:[a] -> OList a / [(len xs), 0] @-}+qsort []     = []+qsort (x:xs) = qpart x xs [] [] ++qpart  :: (Ord a) => a -> [a] -> [a] -> [a] -> [a]+{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | ((true) && (v < x))}] -> p:[{v:a | ((true) && (v >= x))}] -> OList a / [((len r)+(len q)+(len p)), ((len q)+1)]@-}+qpart x [] rlt rge =+    app x (qsort rlt) (x:qsort rge)+qpart x (y:ys) rlt rge =+    case compare x y of+        GT -> qpart x (y:ys) (y:rlt) rge+        _  -> qpart x ys rlt (y:rge)+++{-@ app :: Ord a => x:a -> (OList ({v:a | v < x})) -> (OList ({v:a| v >= x})) -> OList a @-} +app :: Ord a => a -> [a] -> [a] -> [a]+app k []     ys = ys+app k (x:xs) ys = x : (app k xs ys)+
+ tests/neg/RecSelector.hs view
@@ -0,0 +1,15 @@+module Invariant where++data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}++{-@ data F a = F {fxx :: a, fy :: a, fz :: a}+             | G {fxx :: a} +  @-}++{-@ fooG :: x:a -> {v : F a | (fxx v) > x} @-}+fooG :: a -> F a+fooG x = G x ++{-@ foo :: x:a -> {v : F a | (fxx v) > x} @-}+foo :: a -> F a+foo x = F x x x
+ tests/neg/SafePartialFunctions.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--totality" @-}+module SafePartialFunctions (gotail, gohead) where++import Prelude hiding (fromJust, tail, head)++fromJust :: Maybe a -> a+fromJust (Just a) = a++tail :: [a] -> [a]+tail (x:xs) = xs++head :: [a] -> a+head (x:xs) = x+++-- USERS++gotail xs = case xs of+             [] -> []+             y : ys -> tail ys++gohead :: [[a]] -> [a]+gohead xs = map head xs
+ tests/neg/StateConstraints.hs view
@@ -0,0 +1,87 @@+module Compose where+++++data ST s = ST {runState :: s -> s}++{-@ data ST s t <p :: s -> Prop, q :: s -> s -> Prop> = ST (runState :: x:s<p> -> s<q x>) @-}++ {-@ runState :: forall <p :: s -> Prop, q :: s -> s -> Prop>. ST <p, q> s -> x:s<p> -> s<q x> @-}++++{-@ +cmp :: forall < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              >. +       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pref, postf> s)+    -> (ST <pre, postg> s)+    -> (ST <pre, post> s)+@-}++cmp :: (ST s)+    -> (ST s)+    -> (ST s)++cmp (ST f) (ST g) = ST (\x -> f (g x))    ++++{-@ incr :: ST <{\x -> x >= 0}, {\x v -> v = x + 1}>  Nat   @-}+incr :: ST Int +incr = ST $ \x ->  x + 1+++{-@ incr2 :: ST <{\x -> x >= 0}, {\x v -> v = x + 5}>  Nat  @-}+incr2 :: ST Int +incr2 = cmp incr incr++{-@ incr3 :: ST <{\x -> x >= 0}, {\x v -> v = x + 4}>  Nat  @-}+incr3 :: ST Int +incr3 = cmp (cmp incr incr) incr+++foo :: Int+{-@ foo :: {v:Nat |  v = 10} @-}+foo = (runState incr3) 0+++++++++++++++++++++++++++++++++++++
+ tests/neg/StateConstraints0.hs view
@@ -0,0 +1,159 @@+module Compose where+++-- | TODO +-- | +-- | 1. default methods are currently not supported+-- | ie. if we remove the definition of fail method it fails+-- | as I assume that dictionaries are Non Recursive+-- |+-- | 2. check what happens if we import the instance (it should work)  ++data ST s a = ST {runState :: s -> (a,s)}++{-@ data ST s a <p :: s -> Prop, q :: s -> s -> Prop, r :: s -> a -> Prop> +  = ST (runState :: x:s<p> -> (a<r x>, s<q x>)) @-}++{-@ runState :: forall <p :: s -> Prop, q :: s -> s -> Prop, r :: s -> a -> Prop>. ST <p, q, r> s a -> x:s<p> -> (a<r x>, s<q x>) @-}+++++instance Monad (ST s) where+  {-@ instance Monad ST s where+    return :: forall s a <p :: s -> Prop >. x:a -> ST <p, {\s v -> v == s}, {\s v -> x == v}> s a;+    >>= :: forall s a b  < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              , pref0 :: a -> Prop +              >. +       {x::s<pre> |- a<rg x> <: a<pref0>}      +       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (a<pref0> -> ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b) ;+    >>  :: forall s a b  < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              >. +       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b)++    @-}+  return x     = ST $ \s -> (x, s)+  (ST g) >>= f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})    +  (ST g) >>  f = ST (\x -> case g x of {(y, s) -> (runState f) s})    +  fail         = error+ ++++++{-@ incr :: ST <{\x -> true}, {\x v -> v = x + 1}, {\x v -> v = x}>  Int Int @-}+incr :: ST Int Int+incr = ST $ \x ->  (x, x + 1)++{-@ foo :: ST <{\x -> true}, {\x v -> true}, {\x v -> v = 0}>  Bool Int @-}+foo :: ST Bool Int+foo = return 0++{-@ incr2 :: ST <{\x -> true}, {\x v -> v = x + 3}, {\x v -> v = x + 2}>  Int Int @-}+incr2 :: ST Int Int+incr2 = incr >> incr+++run :: (Int, Int)+{-@ run :: ({v:Int |  v = 1}, {v:Int |  v = 2}) @-}+run = (runState incr2) 0++++{-@+cmp :: forall < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              >. +       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b)+@-}++cmp :: (ST s a)+    -> (ST s b)+    -> (ST s b)++m `cmp` f = m `bind` (\_ -> f)++{-@+bind :: forall < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              , pref0 :: a -> Prop +              >. +       {x::s<pre> |- a<rg x> <: a<pref0>}      +       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (a<pref0> -> ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b)+@-}++bind :: (ST s a)+    -> (a -> ST s b)+    -> (ST s b)++bind (ST g) f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})    +++++++++++++++++++++++++++++++
+ tests/neg/StateConstraints00.hs view
@@ -0,0 +1,47 @@+module Compose where++import Prelude hiding (Monad, return )++-- | TODO +-- | +-- | 1. default methods are currently not supported++data ST s a = ST {runState :: s -> (a,s)}++{-@ data ST s a <r :: a -> Prop> +  = ST (runState :: x:s -> (a<r>, s)) @-}++{-@ runState :: forall <r :: a -> Prop>. ST <r> s a -> x:s -> (a<r>, s) @-}+++class Foo m where+  return :: a -> m a+++instance Foo (ST s) where+  {-@ instance Foo ST s where+    return :: forall s a. x:a -> ST <{\v -> x == v}> s a+    @-}+  return x     = ST $ \s -> (x, s)+ ++{-@ foo :: w:a -> ST <{v:a | v > w}>  Bool a @-}+foo :: a -> ST Bool a+foo x = return x+++bar = runState (foo 0) True++++++++++++++
+ tests/neg/Strata.hs view
@@ -0,0 +1,30 @@+module Strata where++import Prelude hiding (repeat, length)++{-@ LIQUID "--strata" @-}++data L a = N | Cons a (L a)+{-@ data L [llen] a = N | Cons (x::a) (xs::(L a)) @-}++{-@ measure llen :: L a -> Int+    llen (N) = 0+    llen (Cons x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v:L a | (llen v) >= 0} @-}++{-@ Cons :: forall <l>.a -> L^l a -> L^l a @-}+++{-@ Lazy repeat @-}+repeat x = Cons x (repeat x)+++-- length :: L a -> Int+length N = 0+length (Cons _ xs) = length xs++foo x = length (repeat x)++bar = repeat
+ tests/neg/StreamInvariants.hs view
@@ -0,0 +1,12 @@+module Invariant where++{-@ using [a] as {v : [a] | (len v) > 0 } @-}+++xs = []++add x xs = x:xs++bar xs = head xs+foo xs = tail xs+
+ tests/neg/StrictPair0.hs view
@@ -0,0 +1,15 @@+-- Compare with tests/neg/StrictPair1.hs++module SPair (poo) where++{-@ measure tsnd :: (a, b) -> b +    tsnd (x, y) = y +  @-} ++{-@ type Foo  a = ((a, Int), Int)<{\z v -> v <= (tsnd z)}> @-}++{-@ poo :: a -> Int -> (Foo a) @-}+poo     :: a -> Int -> ((a, Int), Int)+poo x n = ((x, n), m)+  where+    m   = n + 1
+ tests/neg/StrictPair1.hs view
@@ -0,0 +1,37 @@+-- From Data.ByteString.Fusion++-- Compare with tests/neg/StrictPair0.hs++module SPair (+    PairS(..)+  , moo+  ) where++infixl 2 :*:++-- | Strict pair+--   But removing the strictness annotation does not change the fact that+--   this program is marked as SAFE...+data PairS a b = !a :*: !b deriving (Eq,Ord,Show)++{-@ qualif PSnd(v: a, x:b): v = (psnd x)                            @-}++{-@ data PairS a b <p :: x0:a -> b -> Prop> = (:*:) (x::a) (y::b<p x>)   @-}++{-@ measure pfst :: (PairS a b) -> a +    pfst ((:*:) x y) = x +  @-} ++{-@ measure psnd :: (PairS a b) -> b +    psnd ((:*:) x y) = y +  @-} ++{-@ type FooS a = PairS <{\z v -> v <= (psnd z)}> (PairS a Int) Int @-}++{-@ moo :: a -> Int -> (FooS a) @-}+moo :: a -> Int -> PairS (PairS a Int) Int +moo x n = (x :*: n :*: m)+-- moo x n = (x :*: 1 :*: 100) -- ALAS, also reported "SAFE"+  where+    m   = n + 1+
+ tests/neg/Strings.hs view
@@ -0,0 +1,11 @@+module DBC where++import GHC.CString  -- This import interprets Strings as constants!+++bar :: () -> String +{-@ bar :: () -> {x:String | x ~~ "boo"} @-}+bar _ = "foo"++boo :: String+boo = "boo"
+ tests/neg/Sum.hs view
@@ -0,0 +1,10 @@+module Sum where++{-@ ssum :: forall<p :: a -> Prop, q :: a -> Prop>. +            {{v:a | v == 0} <: a<q>}+            {x::a<p> |- {v:a | x <= v} <: a<q>}+            xs:[{v:a<p> | 0 <= v}] -> {v:a<q> | len xs >= 0 && 0 <= v } @-}+ssum :: Num a => [a] -> a+ssum []       = 0+ssum [x]      = x+ssum (x:xs)   = x + ssum (x:xs)
+ tests/neg/TerminationNum.hs view
@@ -0,0 +1,6 @@+module Fixme where++{-@ fak2 :: (Ord a, Eq a, Num a) => y:{x: a | x >= 0} -> a /[y]@-}+fak2 :: (Ord a, Eq a, Num a) => a -> a+fak2 0 = 1+fak2 x = x * fak2 (x + 1)
+ tests/neg/TerminationNum0.hs view
@@ -0,0 +1,18 @@+module Fixme where++{-@fak2 :: (Ord a, Eq a, Num a) => {x: a | x >= 0} -> a @-}+fak2 :: (Ord a, Eq a, Num a) => a -> a+fak2 0 = 1+fak2 x = x * fak2 (x + 1)+++{-@ fak :: {x: Int | x >= 0} -> a -> Int @-}+fak :: (Ord a, Eq a, Num a) => Int -> a -> Int +fak 0 _ = 1+fak x y = fak (x + 1) y+++{-@ fak1 :: {x: Int | x >= 0} -> a -> Int @-}+fak1 :: (Num a) => Int -> a -> Int +fak1 0 _ = 1+fak1 x y = fak1 (x + 1) y
+ tests/neg/TopLevel.hs view
@@ -0,0 +1,7 @@+module TopLevel where++import Language.Haskell.Liquid.Prelude++foo b = liquidAssertB b++bar = foo True
+ tests/neg/Variance.hs view
@@ -0,0 +1,40 @@+module Variance where++{-@ data variance Foo invariant bivariant covariant contravariant @-}+data Foo a b c d++{-@ check_covariant :: Foo a b {v:Int | v > 0} c -> Foo a b {v:Int | v = 1} c @-}+check_covariant :: Foo a b Int c -> Foo a b Int c+check_covariant r = r++{-@ check_contravariant :: Foo a b c {v:Int | v = 1} -> Foo a b c {v:Int | v > 0 } @-}+check_contravariant :: Foo a b c Int-> Foo a b c Int+check_contravariant r = r++{-@ check_bivariant :: Foo a {v: Int | v > 0 } c d -> Foo a {v:Int | ((v > 0) && (v < 2))} c d @-}+check_bivariant :: Foo a Int c d -> Foo a Int c d+check_bivariant r = r+++{-@ check_invariant :: Foo {v: Int | v = 1} b c d -> Foo {v:Int | ((v > 0) && (v < 3))} b c d @-}+check_invariant :: Foo Int b c d -> Foo Int b c d+check_invariant r = r+++++++++++++++++++
+ tests/neg/alias00.hs view
@@ -0,0 +1,10 @@+module Test0 () where++{-@ type NegInt = {v: Int | v <= 0} @-}+{-@ myabs :: Int -> NegInt @-}+myabs :: Int -> Int+myabs x = if (x > 0) then x else (0 - x)++{-@ type NNList a = {v: [a] | len(v) = 0} @-}+{-@ single :: a -> NNList a @-}+single x = [x]
+ tests/neg/ass0.hs view
@@ -0,0 +1,7 @@+module Ass () where++-- import Language.Haskell.Liquid.Prelude (liquidAssert)++{-@ assert foo :: x:a -> {v: a | (v != x) } @-}+foo x = x +
+ tests/neg/concat.hs view
@@ -0,0 +1,21 @@+module Concat () where++import Language.Haskell.Liquid.Prelude++foo :: [Int]+foo = [1..10]++concatmap f ls = concat $ map f ls++myconcatmap f []     = []+myconcatmap f (x:xs) = (f x) ++ (myconcatmap f xs) +++chooseList x = [choose x]+r :: Int+r = 5++prop x = liquidAssertB (x == r)++propMap  = map prop $ myconcatmap chooseList foo+propMap1 = map prop $ concatmap   chooseList foo
+ tests/neg/concat1.hs view
@@ -0,0 +1,38 @@+module Concat () where++import Language.Haskell.Liquid.Prelude++------------------------------------------------------------+------------ Longer Version of neg/polypred.hs -------------+------------------------------------------------------------++foo :: [[Int]]+foo = [[choose 1], [choose 2]]++-- concatmap f ls = concat $ map f ls++myconcat []     = []+myconcat (x:xs) = x ++ (myconcat xs) +++myconcat1 :: a -> [[Int]] -> [Int]+myconcat1 _ []     = []+myconcat1 f (x:xs) = x ++ (myconcat1 f xs) ++concat1 f = concat+myconcat2 f = myconcat++r :: Int+r = 5++prop x = liquidAssertB (x == r)++-- ok +-- propC0 = map prop $ myconcat foo+-- this is safe+-- propC1 = map prop $ myconcat foo+-- propC2 = map prop $ concat foo+-- propC3 = map prop $ concat1 id foo++propC4 = map prop $ myconcat1 id foo+
+ tests/neg/concat2.hs view
@@ -0,0 +1,20 @@+module Concat () where++import Language.Haskell.Liquid.Prelude++foo :: [Int]+foo = [choose 1, choose 2]++-- myconcat1 :: (a -> a) -> [[Int]] -> [Int] +-- :: a goes to False -> safe+myconcat1 :: (a -> [(k,v)]) -> [a] -> [(k, v)]+myconcat1 _ []     = []+myconcat1 f (x:xs) = (f x) ++ (myconcat1 f xs) ++r :: Int+r = 5++prop (x, y) = liquidAssertB (x > r)+--  where r = 5+-- this is safe+propC = map prop $ myconcat1 (\x->[(x, x)]) foo
+ tests/neg/contra0.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}++module Foo () where++import Language.Haskell.Liquid.Prelude (liquidAssert)+import Data.IORef+++{-@ data variance IO bivariant @-}+{-@ data variance IORef bivariant @-}++job :: IO () +job = do+  p <- newIORef (0 :: Int)+  writeIORef p 10+  v <- readIORef p+  liquidAssert (v == 0) $ return ()
+ tests/neg/coretologic.hs view
@@ -0,0 +1,22 @@+module CoreToLog where++import Data.Set++-- ISSUE: can we please allow things like `empty` to also+-- appear in type and alias specifications, not just in+-- measures as in `goo` below?++{-@ type IsEmp a = {v:[a] | listElts v = Data.Set.empty } @-}++{-@ foo :: IsEmp Int @-}+foo :: [Int]+foo = []++{-@ bar :: IsEmp Int @-}+bar :: [Int]+bar = [1]++{-@ measure goo @-}+goo        :: (Ord a) => [a] -> Set a+goo []     = empty+goo (x:xs) = (singleton x) `union` (goo xs)
+ tests/neg/csv.hs view
@@ -0,0 +1,38 @@+module CSV () where++-- | Using LiquidHaskell for CSV lists+-- c.f. http://www.reddit.com/r/scala/comments/1nhzi2/using_shapelesss_sized_type_to_eliminate_real/++data CSV = Csv { headers :: [String]+               , rows    :: [[String]]+               }++{-@ data CSV = Csv { headers :: [String]+                   , rows    :: [{v:[String] | (len v) = (len headers)}]+                   }+  @-}++-- Eeks, we missed the column name.++csvBad1 = Csv ["Date"] +              [ ["Mon", "1"]+              , ["Tue", "2"]+              , ["Wed", "3"] +              ]++-- Eeks, we missed a column.++csvBad2 = Csv ["Name", "Age"] +              [ ["Alice", "32"]+              , ["Bob"        ]+              , ["Cris" , "29"] +              ]+                      +-- All is well! ++csvGood = Csv ["Id", "Name", "Days"]+              [ ["1", "Jan", "31"]+              , ["2", "Feb", "28"]+              , ["3", "Mar", "31"]+              , ["4", "Apr", "30"] +              ]
+ tests/neg/datacon-eq.hs view
@@ -0,0 +1,9 @@+module Blank (foo) where++-- This is a blank file.++data G = A | B++{-@ foo :: {v:Int | true} -> {v:G | v = B} @-}+foo  :: Int -> G+foo _ = A
+ tests/neg/deppair0.hs view
@@ -0,0 +1,14 @@+module Niki () where++import Language.Haskell.Liquid.Prelude++incr x = x + 1++baz x = (x, incr x)++prop :: Bool+prop = chk $ baz n+  where n = choose 100++chk (x, y) = liquidAssertB (x > y)+
+ tests/neg/deptupW.hs view
@@ -0,0 +1,23 @@+module Deptup0 () where++import Language.Haskell.Liquid.Prelude++{-@ data Pair a b <p :: x0:a -> x1:b -> Prop> = P (x :: a) (y :: b<p x>) @-} +data Pair a b = P a b+++-- Names are shifty. I bet this would not work with alpha-renaming.+{-@ mkP :: forall a <p :: x0:a -> x1:a -> Prop>. x: a -> y: a<p x> -> Pair <p> a a @-}+mkP :: a -> a -> Pair a a+mkP x y = error "TBD"++incr :: Int -> Int+incr x = x - 1++baz x = mkP x (incr x)++chk :: Pair Int Int -> Bool+chk (P x y) = liquidAssertB (x < y)++prop = chk $ baz n+  where n = choose 100
+ tests/neg/errmsg.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--short-names" @-}++module Goo where++import Data.Set++{- the "error message" is garbled thanks to all the ill-formatted+   "Eq [Contravariant]" stuff. Can we remove it, or at least NOT show+   it when running in --short-names mode. -}++{-@ foo :: (Eq a) => x:a -> xs:[a] -> {v:Bool | Prop v <=> (Data.Set.member x (Data.Set.elems xs))} @-}+foo          :: (Eq a) => a -> [a] -> Bool+foo x (y:ys) = x == y || elem x ys+foo _ []     = False++{-@ measure elements @-}+elements  []    = empty+elements (x:xs) = singleton x `union` elements xs++{- append :: xs:_ -> ys:_ -> {v:_ | elements v = union (elements xs) (elements ys) }@-}+append :: [a] -> [a] -> [a]+append = undefined +
+ tests/neg/errorloc.hs view
@@ -0,0 +1,11 @@+module Foo () where++import Language.Haskell.Liquid.Prelude (liquidAssert)++{-@ zoo :: {v: Int | v > 0} -> {v: Int | v > 0} -> Int @-}+zoo   :: Int -> Int -> Int +zoo x y = liquidAssert (x /= 0) $ x + y +++foo = zoo (-1) (-2)+
+ tests/neg/ex0-unsafe.hs view
@@ -0,0 +1,27 @@+module Ex () where++-- Testing "existential-types"++{-@ foldN :: forall a <p :: x0000:Int -> x1111:a -> Prop>. +                (i:Int -> a<p i> -> a<p (i+1)>) +              -> n:{v: Int | v >= 0}+              -> a <p 0>+              -> a <p n>+  @-}++foldN :: (Int -> a -> a) -> Int -> a -> a+foldN f n = go 0 +  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x+++fooBar :: (Int -> a -> a) -> Int -> a -> a+fooBar f n = go 0+  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x+++{-@ count :: m: {v: Int | v > 0 } -> {v: Int | v = 44 } @-}+count :: Int -> Int+count m = foldN (\_ n -> n + 1) m 0+-- count m = fooBar (\_ n -> n + 1) m 0
+ tests/neg/ex1-unsafe.hs view
@@ -0,0 +1,67 @@++-- | A somewhat fancier example demonstrating the use of Abstract Predicates and exist-types++module Ex () where++-------------------------------------------------------------------------+-- | Data types ---------------------------------------------------------+-------------------------------------------------------------------------++data Vec a = Nil | Cons a (Vec a)++-- | We can encode the notion of length as an inductive measure @llen@ ++{-@ measure llen     :: forall a. Vec a -> Int +    llen (Nil)       = 0 +    llen (Cons x xs) = 1 + llen(xs)+  @-}+++-- | As a warmup, lets check that a /real/ length function indeed computes+-- the length of the list.++{-@ sizeOf :: xs:Vec a -> {v: Int | v = llen(xs)} @-}+sizeOf             :: Vec a -> Int+sizeOf Nil         = 0+sizeOf (Cons _ xs) = 1 + sizeOf xs++-------------------------------------------------------------------------+-- | Higher-order fold -------------------------------------------------- +-------------------------------------------------------------------------++-- | Time to roll up the sleeves. Here's a a higher-order @foldr@ function+-- for our `Vec` type. Note that the `op` argument takes an extra /ghost/+-- parameter that will let us properly describe the type of `efoldr` ++{-@ efoldr :: forall a b <p :: x0:Vec a -> x1:b -> Prop>. +                (xs:Vec a -> x:a -> b <p xs> -> b <p (Ex.Cons x xs)>) +              -> b <p Ex.Nil> +              -> ys: Vec a+              -> b <p ys>+  @-}+efoldr :: (Vec a -> a -> b -> b) -> b -> Vec a -> b+efoldr op b Nil         = b+efoldr op b (Cons x xs) = op xs x (efoldr op b xs) ++-------------------------------------------------------------------------+-- | Clients of `efold` ------------------------------------------------- +-------------------------------------------------------------------------++-- | Finally, lets write a few /client/ functions that use `efoldr` to +-- operate on the `Vec`s. ++-- | First: Computing the length using `efoldr`+{-@ size :: xs:Vec a -> {v: Int | v = llen(xs)} @-}+size :: Vec a -> Int+size = efoldr (\_ _ n -> n + 1) 0++{-@ suc :: x:Int -> {v: Int | v = x + 1} @-}+suc :: Int -> Int+suc x = x + 1 ++-- | Second: Appending two lists using `efoldr`+{-@ app  :: xs: Vec a -> ys: Vec a -> {v: Vec a | llen(v) = 1 + llen(xs) + llen(ys) } @-} +app xs ys = efoldr (\_ z zs -> Cons z zs) ys xs +++
+ tests/neg/filterAbs.hs view
@@ -0,0 +1,43 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}++++module Filter where++import Prelude hiding (filter)++{-@ filter :: forall <p :: a -> Prop, q :: a -> Bool -> Prop>.+                  {y::a, flag :: {v:Bool<q y> | Prop v} |- {v:a | v = y} <: a<p>}+                  (x:a -> Bool<q x>) -> [a] -> [a<p>]+  @-}++filter f (x:xs)+  | f x       = x : filter f xs+  | otherwise = filter f xs+filter _ []   = []++{-@ isPos :: x:Int -> {v:Bool | Prop v <=> x > 0} @-}+isPos :: Int -> Bool+isPos n = n > 0+++{-@ isNeg :: x:Int -> {v:Bool | Prop v <=> x < 0} @-}+isNeg :: Int -> Bool+isNeg n = n < 0+++-- Now the below *should* work with+-- p := \v   -> 0 < v+-- q := \x v -> Prop v <=> 0 < 0+++{-@ positives :: [Int] -> [{v:Int | v > 0}] @-}+positives xs = filter isPos xs++{-@ negatives :: [Int] -> [{v:Int | v < 0}] @-}+negatives xs = filter isNeg xs++{-@ positivesBAD :: [Int] -> [{v:Int | v < 0}] @-}+positivesBAD xs = filter isPos xs+
+ tests/neg/foldN.hs view
@@ -0,0 +1,18 @@+module Ex () where++-- Testing "existential-types"++{-@ foldN :: forall a <p :: x0:Int -> x1:a -> Prop>. +                (i:Int -> a<p i> -> a<p (i+1)>) +              -> n:{v: Int | v >= 0}+              -> a <p 0> +              -> a <p 42>+  @-}++foldN :: (Int -> a -> a) -> Int -> a -> a+foldN f n = go 0 +  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x+++
+ tests/neg/foldN1.hs view
@@ -0,0 +1,14 @@+module Toy  where++{-@ foldN :: forall a <p :: x0:Int -> x1:a -> Prop>. +                (i:Int -> a<p i> -> a<p (i+1)>) +              -> n:{v: Int | v >= 0}+              -> a <p 0>+              -> {v : a | 0=1}+  @-}++foldN :: (Int -> a -> a) -> Int -> a -> a+foldN f n = go 0 +  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x+
+ tests/neg/grty0.hs view
@@ -0,0 +1,13 @@+module Test () where++{-@ stupid :: Int -> Int @-}+stupid :: Int -> Int+stupid x = 0++{-@ myId :: x:a -> {v:a | v = x } @-}+myId x = x ++{-@ assert single :: a -> {v: [a] | len(v) = 0} @-}+single x = [x] ++
+ tests/neg/grty1.hs view
@@ -0,0 +1,11 @@+module Foo () where++moo = insert 4 [1, 2, 0]+++{-@ insert      :: (Ord a) => x:a -> xs: [a]<{\fld v -> (v >= fld)}> -> {v: [a]<{\fld v -> (v >= fld)}> | len(v) = (1 + len(xs)) } @-}+insert y []                   = [y]+insert y (x : xs) | y <= x    = y : x : xs +                  | otherwise = x : insert y xs++
+ tests/neg/grty2.hs view
@@ -0,0 +1,9 @@+module Foo () where++moo = insert 4 [1, 2, 3]++{-@ insert      :: (Ord a) => x:a -> xs: [a]<{\fld v -> (v >= fld)}> -> {v: [a]<{\fld v -> (v >= fld)}> | len(v) = (1 + len(xs)) } @-}+insert y []                            = [y]+insert y (x : xs) | y > {- <= -} x     = y : x : xs +                  | otherwise          = x : insert y xs+
+ tests/neg/grty3.hs view
@@ -0,0 +1,10 @@+module Foo () where+++{-@ choo :: [a] -> {v: Int | v > 0 } @-}+choo = poo+++poo :: [a] -> Int +poo (x:xs) = poo xs+poo []     = 0
+ tests/neg/list00.hs view
@@ -0,0 +1,10 @@+module Vec0 () where++import Language.Haskell.Liquid.Prelude -- hiding (copyList)++copyList zs = zs++xs    = [1] :: [Int]+ys    = copyList xs+jhala = head ys+prop0 = crash (0 == 1)
+ tests/neg/mapreduce-tiny.hs view
@@ -0,0 +1,30 @@++++module Meas () where++import Language.Haskell.Liquid.Prelude++++prop1       = map choo [[True]] -- replace [[1]] with [[]] for UNSAT+choo (x:xs) = liquidAssertB False+-- choo []     = liquidAssertB False++-- import qualified Data.Map as M+-- import Data.List (foldl')++--keyvals :: [(Int, Int)]+--keyvals = [(1, 1), (2, 2), (3, 3)]+--+--group :: (Ord k) => [(k, v)] -> M.Map k [v]+--group = foldl' addKV  M.empty+--+--addKV m (k, v) = let boo = liquidAssertB False in M.insert k vs' m+--  where vs' = v : (M.findWithDefault [] k m)+--+--checkNN m = M.foldrWithKey reduceKV False m+--+--reduceKV _ _ acc = liquidAssertB False +--+--prop = checkNN (group keyvals)
+ tests/neg/mapreduce.hs view
@@ -0,0 +1,55 @@++-- RJ: Issues with TypeClasses? Ord?++module Meas () where++import Language.Haskell.Liquid.Prelude+import qualified Data.Map as M+import Data.List (foldl')++----------------------------------------------------------------+--- Step 1: Map each element into key-value list (concatMap) ---+----------------------------------------------------------------++expand          :: (a -> [(k,v)]) -> [a] -> [(k, v)]+expand f []     = []+expand f (x:xs) = (f x) ++ (expand f xs)++----------------------------------------------------------------+--- Step 2: Group By Key ---------------------------------------+----------------------------------------------------------------++group :: (Ord k) => [(k, v)] -> M.Map k [v]+group = foldl' addKV  M.empty+  +addKV m (k, v) = M.insert k vs' m+  where vs' = v : (M.findWithDefault [] k m)++----------------------------------------------------------------+--- Step 3: Group By Key ---------------------------------------+----------------------------------------------------------------++collapse f = M.foldrWithKey reduceKV []+  where reduceKV k (v:vs) acc = if liquidAssertB False then (k, foldl' f v vs) : acc else acc+        reduceKV k []     _   = crash False --error $ show (liquidAssertB False)++----------------------------------------------------------------+--- Putting it All Together ------------------------------------+----------------------------------------------------------------++mapReduce fmap fred = collapse fred . group . expand fmap ++----------------------------------------------------------------+--- "Word Count" -----------------------------------------------+----------------------------------------------------------------++wordCount  = mapReduce fm plus +  where fm = \doc -> [ (w,1) | w <- words doc]++main = putStrLn $ show $ wordCount docs+  where docs = [ "this is the end"+               , "go to the end"+               , "the end is the beginning"]+ ++
+ tests/neg/maps.hs view
@@ -0,0 +1,34 @@+module Maps where++{-@ prop1 :: x:_ -> y:{_ | y == x} -> TT @-}+prop1 x y = (z == 10)+  where+    m1    = put x 10 emp  +    m2    = put y 20 m1+    z     = get x m2++{-@ prop2 :: x:_ -> y:{_ | y == x} -> TT @-}+prop2 x y = (z == 10)+  where+    m1    = put x 10 emp +    m2    = put y 20 m1+    z     = get x m2++-----------------------------------------------------------------------++data Map k v = M++{-@ embed Map as Map_t @-}+{-@ measure Map_select :: Map k v -> k -> v @-}+{-@ measure Map_store  :: Map k v -> k -> v -> Map k v @-}++emp :: Map Int Int+emp = undefined   +     +{-@ get :: k:k -> m:Map k v -> {v:v | v = Map_select m k} @-}+get :: k -> Map k v -> v+get = undefined ++{-@ put :: k:k -> v:v -> m:Map k v -> {n:Map k v | n = Map_store m k v} @-}+put :: k -> v -> Map k v -> Map k v+put = undefined
+ tests/neg/meas0.hs view
@@ -0,0 +1,13 @@+module Range () where++import Control.Applicative+import Language.Haskell.Liquid.Prelude++goo x = []++poo (x:_) = True+poo ([])  = liquidAssertB False++xs = goo (choose 0)++prop1 = liquidAssertB (poo xs)
+ tests/neg/meas2.hs view
@@ -0,0 +1,19 @@+module Meas () where++import Language.Haskell.Liquid.Prelude++goo :: a -> Int+goo _ = 1++bob :: [a] -> Int+--bob [] = 0+--bob (n:ns) = goo ns +bob ms = case ms of +           []     -> 0+           (n:ns) -> goo ns ++zs :: [Int]+zs = [1..100]++prop2 = liquidAssertB (n2 `eq` 0) +  where n2 = bob zs
+ tests/neg/meas3.hs view
@@ -0,0 +1,24 @@+module Meas () where+++import Language.Haskell.Liquid.Prelude++--mylen []       = 0+--mylen (_:xs)   = 1 `plus` mylen xs++mylen xs = case xs of +             []     -> 0+             (_:ys) -> 1 `plus` mylen ys+++zs :: [Int]+zs = [1..100]++goo :: [dogbert] -> Int+goo _ = 1++bloo :: [Int] -> Int+bloo _ = 0++prop1 = liquidAssertB (n1 `eq` 0) +  where n1 = mylen zs
+ tests/neg/meas5.hs view
@@ -0,0 +1,41 @@+module Meas () where++import Language.Haskell.Liquid.Prelude++{-@ include <len.hquals> @-}++mylen          :: [a] -> Int+mylen []       = 0+mylen (_:xs)   = 1 + mylen xs+++mymap f []     = []+mymap f (x:xs) = (f x) : (mymap f xs)++myreverse = go []+  where go acc (x:xs) = go (x:acc) xs+        go acc []     = acc+    +myapp [] ys     = ys+myapp (x:xs) ys = x:(myapp xs ys)++zs :: [Int]+zs = [1..100]++zs' :: [Int]+zs' = [500..1000]++prop2 = liquidAssertB (n1 == n2) +  where n1 = mylen zs+        n2 = mylen $ mymap (+ 1) zs ++prop3 = liquidAssertB (n1 == n2) +  where n1 = mylen zs+        n2 = mylen $ myreverse zs ++prop4 = liquidAssertB ((n1 + n2) == n3) +  where n1 = mylen zs+        n2 = mylen zs'+        n3 = mylen $ myapp zs zs' ++prop5 = zipWith (+) zs (0: myreverse zs)
+ tests/neg/meas7.hs view
@@ -0,0 +1,17 @@++module Meas () where++-- some tests for the 'expandDefaultCase' trick to case-split +-- on the "missing" constructors.++mylen          :: [a] -> Int+mylen []       = 0+mylen (_:xs)   = 1 + mylen xs+++{-@ foo :: [a] -> {v: Int | v = 0} @-}+foo :: [a] -> Int+foo zs = case zs of+           [] -> 0+           _  -> mylen zs+
+ tests/neg/meas9.hs view
@@ -0,0 +1,13 @@+module Meas () where++import Data.Set (Set(..))++{-@ myid :: xs:[a] -> {v:[a]| listElts(v) = listElts(xs)} @-}+myid []     = []+myid (x:xs) = x : myid xs++{-@ myapp :: xs:[a] -> ys:[a] -> {v:[a] | listElts(v) = Set_cup(listElts(xs), listElts(xs))} @-}+myapp :: [a] -> [a] -> [a]+myapp []     ys = ys+myapp (x:xs) ys = x : myapp xs ys+
+ tests/neg/monad3.hs view
@@ -0,0 +1,15 @@+module Foo () where++import Language.Haskell.Liquid.Prelude++-- gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x >= 0) (x + 1)+++-- decrlist n = n : decrlist (n-1)++xs, ys, zs :: [Int]+xs = [0, -1]+ys = gpp xs+zs = gpp ys
+ tests/neg/monad4.hs view
@@ -0,0 +1,15 @@+module Foo () where++import Language.Haskell.Liquid.Prelude++-- gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x > 0) (x - 10)+++incrlist n = n : incrlist (n+1)++xs, ys, zs :: Maybe Int+xs = Just 9+ys = gpp xs+zs = gpp ys
+ tests/neg/monad5.hs view
@@ -0,0 +1,18 @@+module Foo () where++import Language.Haskell.Liquid.Prelude++-- gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x > 0) (x + 1)++myabs :: Int -> Int+myabs x | x >= 0     = x+        | otherwise  = 0-x++posM :: Monad m => m Int+posM = return $ myabs $ choose 0+++yM :: Monad m => m Int+yM = gpp posM
+ tests/neg/monad6.hs view
@@ -0,0 +1,8 @@+module Foo  where++import Language.Haskell.Liquid.Prelude ++{-@ gpp :: Monad m => m {v:Int|v>=0} -> m {v:Int|v>0} @-}+gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x >= 0) (x)
+ tests/neg/monad7.hs view
@@ -0,0 +1,22 @@+module Foo () where++import Language.Haskell.Liquid.Prelude ++{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}+{-@ gpp :: (Ord a, Monad m) => [a] -> m (OList a) @-}+gpp :: (Ord a, Monad m) => [a] -> m [a]+gpp ls = return $ reverse $ insertSort ls++{-@ insertSort :: (Ord a) => xs:[a] -> OList a @-}+insertSort            :: (Ord a) => [a] -> [a]+insertSort []         = []+insertSort (x:xs)     = insert x (insertSort xs) ++insert y []                   = [y]+insert y (x : xs) | y <= x    = y : x : xs +                  | otherwise = x : insert y xs+++++
+ tests/neg/mr00.hs view
@@ -0,0 +1,16 @@+module MapReduce () where++import Language.Haskell.Liquid.Prelude +import Data.Map hiding (filter, map, foldl, foldr)++baz (v:vs) _ = crash False +baz []     _ = crash False++mymap = Data.Map.fromList [('a', [1])]++-- Why is this safe+coll = Data.Map.fold baz 0 +prop_safe = coll mymap ++-- Oddly, this is unsafe+-- prop_unsafe = Data.Map.foldr baz 0 mymap
+ tests/neg/multi-pred-app-00.hs view
@@ -0,0 +1,6 @@+module Blank () where++{-@ bar :: forall < p :: Int -> Prop+                  , q :: Int -> Prop >. Int<p> -> Int<p, q> @-}+bar :: Int -> Int+bar x = x
+ tests/neg/nestedRecursion.hs view
@@ -0,0 +1,6 @@+module Map (radicals) where++radicals :: Int -> [a]+radicals n = [ foo (radicals n) i | i <- [1..]]++foo = undefined
+ tests/neg/pair.hs view
@@ -0,0 +1,25 @@+module Pair () where ++import Language.Haskell.Liquid.Prelude ++{-@ data Pair a b <p :: a -> b -> Prop> = P (x :: a) (y :: b<p x>) @-} +data Pair a b = P a b++incr x = let p = P x ((x+1)) in p+chk (P x (y)) = liquidAssertB (x == y) +prop  = chk $ incr n+  where n = choose 0++incr2 x = +  let p1 = (P True (x+1)) in +  let p2 = P x p1 in +   p2+chk2 (P x w) = +   case w of (P z y) -> liquidAssertB (x == y) +prop2  = chk2 $ incr2 n+  where n = choose 0++incr3 x = P x (P True (P 0 (x+1)))+chk3 (P x (P _(P _ y))) = liquidAssertB (x == y) +prop3  = chk3 $ incr3 n+  where n = choose 0
+ tests/neg/pair0.hs view
@@ -0,0 +1,21 @@+module Pair () where ++import Language.Haskell.Liquid.Prelude ++data Pair a b = P a b+++incr x = (x, x-1)+chk (x, y) = liquidAssertB (x <y) +prop  = chk $ incr n+  where n = choose 0++incr2 x = (x, True, x-1)+chk2 (x, _, y) = liquidAssertB (x <y) +prop2  = chk2 $ incr2 n+  where n = choose 0++incr3 x = (x, (True, (0, x-1)))+chk3 (x, (_, (_, y))) = liquidAssertB (x <y) +prop3  = chk3 $ incr3 n+  where n = choose 0
+ tests/neg/pargs.hs view
@@ -0,0 +1,10 @@+module Foo () where++{-@ foo :: forall a <p :: x0:Int -> x1:a -> Prop>. +             (i:Int -> a<p i>) -> {v:Int| v=0}+              -> a <p 1>+  @-}++foo ::  (Int -> a) -> Int ->  a+foo f i = f i+
+ tests/neg/pargs1.hs view
@@ -0,0 +1,11 @@+module Foo () where++{-@ foo :: forall a <p :: x0:Int -> x1:a -> Prop>. +             (i:Int  -> j : Int-> a<p (i)>) -> +               ii:Int -> jj:Int+              -> a <p (ii+jj)>+  @-}++foo ::  (Int -> Int -> a) -> Int -> Int ->  a+foo f i j = f i j+
+ tests/neg/partial.hs view
@@ -0,0 +1,13 @@+module Test () where++{-@ posPlus :: x:{v: Int | v >= 0} -> {v: Int | v >= x} @-}+posPlus :: Int -> Int+posPlus x = if (x > 0) +              then 2 + (posPlus (x - 1))+              else 0++goo = posPlus (-3)++{-@ poo :: x:Int -> {v: Int | v >= x } @-}+poo x = if x > 0 then posPlus x else x+
+ tests/neg/poly0.hs view
@@ -0,0 +1,22 @@+module Poly0 () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++myid arg     = arg++----------------------------------------------------------++x = choose 0++prop_id1 = let x'  = myabs x in +           let x'' = myid x' in +           liquidAssertB (x'' `geq` 0)++prop_id2 = liquidAssertB (x'' `geq` 0)+  where x'  = myabs x +        x'' = myid x' ++prop_id3 = liquidAssertB (x' `geq` 20)+  where x' = myid $ myabs x
+ tests/neg/poly1.hs view
@@ -0,0 +1,19 @@+module Poly0 () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++myid2 a b  = a  ++----------------------------------------------------------++x =  choose 0++prop_id4 = let x'  = myabs x in +           let x'' = myid2 x' [] in +           liquidAssertB (x'' `geq` 10)++prop_id5 = liquidAssertB (x'' `geq` 0)+  where x'  = myabs x +        x'' = myid2 x' []
+ tests/neg/poly2-degenerate.hs view
@@ -0,0 +1,14 @@+module Poly0 () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++----------------------------------------------------------++myid3 x y  = y++prop_id6 = liquidAssertB (x' `geq` 10)+  where x' = myid3 [] $ myabs n +        n  = choose 0+
+ tests/neg/poly2.hs view
@@ -0,0 +1,16 @@+module Poly0 () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++----------------------------------------------------------++myid3 x y  = y++x = choose 0++prop_id6 = liquidAssertB (x' `geq` 10)+  where x' = myid3 [] $ myabs x ++
+ tests/neg/polypred.hs view
@@ -0,0 +1,13 @@+module Concat () where++import Language.Haskell.Liquid.Prelude++prop :: Int -> Bool+prop x = liquidAssertB (x == 0)++foo :: a -> Int+foo longVarName = choose 20 ++-- propUNSAFE = prop (foo "ker")+propSAFE = prop (foo id)+
+ tests/neg/poslist.hs view
@@ -0,0 +1,16 @@+module Poslist () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++absList xs = map myabs xs++prop1 = map (liquidAssertB . (`geq` 0)) $ absList $ map choose [1..]+++numAbs x   = if x > 0 then x else (x)++numAbsList = map numAbs ++prop2      = map (liquidAssertB . (>= 0)) $ numAbsList $ map choose [1..]
+ tests/neg/pragma0-unsafe.hs view
@@ -0,0 +1,8 @@+-- NO PRAGMA version of tests/pos/pragma0.hs++module Test0 where++-- an obviously non-terminating function++zoo   :: Int -> Int+zoo x = zoo x
+ tests/neg/pred.hs view
@@ -0,0 +1,8 @@+module Foo () where++{-@ predicate Gt x y = (x < y) @-}++{- incr :: x:Int -> {v:Int | v > x} @-}+{-@ incr :: x:Int -> {v:Int | (Gt v x)} @-}+incr :: Int -> Int+incr x = x + 1
+ tests/neg/prune0.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Prune where++import Prelude hiding (read, length)+import Control.Monad.Primitive+import Data.Vector.Generic.Mutable++----------------------------------------------------------------------------+-- LIQUID Specifications ---------------------------------------------------+----------------------------------------------------------------------------++-- | Vector Size Measure++{-@ measure vsize :: forall a. a -> Int @-}++-- | Vector Type Aliases+{-@ type      OkIdx X     = {v:Nat | v < (vsize X)} @-}++-- | Assumed Types for Vector++{-@ unsafeRead  +      :: (PrimMonad m, MVector v a) +      => xorp:(v (PrimState m) a) +      -> (OkIdx xorp) +      -> m a       +  @-}++yuck xanadu i = if (i > 0) then unsafeRead xanadu i else undefined++++++++++++++++++++++
+ tests/neg/qsloop.hs view
@@ -0,0 +1,9 @@+module NonTermQuickSort where++quickSort []       = []+quickSort xs@(x:_) = lts ++  gts +  where +    lts          = quickSort [y | y <- xs, y < x]+    gts          = quickSort [z | z <- xs, z >= x]++
+ tests/neg/range.hs view
@@ -0,0 +1,19 @@+module Range () where++import Language.Haskell.Liquid.Prelude++range :: Int -> Int -> [Int]+range i j  +  | i `lt` j  = i : (range (i `plus` 1) j)+  | otherwise = []  ++sumTo = foldl plus 0 . range 0++n = choose 0 +m = choose 1++prop_rng1 = map (liquidAssertB . (10 `leq`)) $ range 0 n+prop_rng2 = map (liquidAssertB . (n `leq`)) $ range n 100+prop_rng3 = map (liquidAssertB . (n `leq`)) $ range n m+prop_rng4 = map (liquidAssertB . (`leq` m)) $ range n m +prop_rng5 = liquidAssertB ((sumTo n) `geq` 10)
+ tests/neg/record0.hs view
@@ -0,0 +1,17 @@+module Rec0 (clone, mk) where++{-@ data LL a = BXYZ { size  :: {v: Int | v > 0 }+                     , elems :: {v: [a] | (len v) = size }+                     }+  @-}++data LL a = BXYZ { size  :: Int+                 , elems :: [a]+                 }++{-@ mk :: a -> Int -> LL a @-}+mk x n = BXYZ n (clone x 0)++{-@ clone :: x:a -> n:Int -> {v:[a]| (len v) = n} @-}+clone :: a -> Int -> [a]+clone = error "FOO"
+ tests/neg/revshape.hs view
@@ -0,0 +1,34 @@+{-@ LIQUID "--no-termination" @-}++module Shapes () where+ +-- https://gist.github.com/cartazio/6891549++data Shape = Nil | Cons !Int !Shape ++{-@ measure rank :: Shape -> Int+    rank (Nil)       = 0+    rank (Cons d ds) = 1 + (rank ds)+  @-}++{-@ type DIM1 = {v:Shape | (rank v) = 1} @-}+{-@ type DIM2 = {v:Shape | (rank v) = 2} @-}++{-@ oneDim :: DIM1 @-}+oneDim = 12 `Cons` Nil++{-@ twoDim :: DIM2 @-}+twoDim = 2 `Cons` (17 `Cons` Nil)++-- clearly an error, is flagged by LiquidHaskell+{-@ twoDim' :: DIM2 @-}+twoDim' = 56 `Cons` (2 `Cons` (17 `Cons` Nil))++{-@ reverseShape :: sh:Shape -> {v:Shape | (rank v) = (rank sh)} @-}+reverseShape shs = go shs Nil +    where+        {-@ go ::  a:Shape -> b:Shape -> {v:Shape | (rank v) = (rank a) + (rank b)} @-}+        go Nil res            = res   +        go (Cons ix more) res = go more  (Cons ix res)+ +
+ tests/neg/risers.hs view
@@ -0,0 +1,14 @@+module Risers  where++{-@ LIQUID "--totality" @-}++{-@ predicate NonNull X = ((len X) > 0) @-}++{- risers :: (Ord a) => zs:[a] -> {v: [[a]] | ((NonNull zs) => (NonNull v)) } @-} +risers []        +  = []+risers [x]       +  = [[x]]+risers (x:y:etc) +  = if x <= y then (x:s):ss else [x]:(s:ss)+    where (s:ss) = risers [] -- insert partiality (y:etc)
+ tests/neg/stacks.hs view
@@ -0,0 +1,35 @@+module Stacks () where+++{-@ type DList a = [a]<{\fld v -> (v != fld)}> @-}++{-@ data Stack a = St { focus  :: a    +                      , up     :: DList {v: a | v != focus}+                      , down   :: DList {v: a | v != focus}+                      } +  @-}++data Stack a = St { focus  :: !a    +                  , up     :: ![a] +                  , down   :: ![a]+                  } deriving (Show, Eq)++-- All of the below violate the invariant, get liquid to say so!++{-@ bad0 :: a -> Stack a @-}+bad0   :: a -> Stack a +bad0 x = St x [x] []+++{-@ bad1 :: a -> Stack a @-}+bad1   :: a -> Stack a +bad1 x = St x []  [x]++{-@ bad2 :: Int -> Stack Int @-}+bad2 :: Int -> Stack Int+bad2 x = St 0 [x] [x]++{-@ bad3 :: Int -> Stack Int @-}+bad3 :: Int -> Stack Int+bad3 x = St x [1] [1] +
+ tests/neg/state0.hs view
@@ -0,0 +1,14 @@+module StateMonad () where++type State = Int+data ST a = S (State -> (a, State))+{-@ data ST a <p1 :: State -> Prop,+               p2 :: State -> Prop> +     = S (x::(f:State<p1> -> (a, State<p2>))) +  @-}++{-@ fresh :: ST <{\v -> v>=0}, {\v -> v>=0}> Int @-}+fresh :: ST Int+fresh = S $ \n -> (n, n-1)++
+ tests/neg/state00.hs view
@@ -0,0 +1,10 @@+module StateMonad () where++type State = Int+data ST a b = S (a -> (a, b)) | F a++{-@ fresh :: ST Int {v:Int|v>=0} @-}+fresh :: ST Int Int+fresh = S $ \n -> (n, n+1)++
+ tests/neg/string00.hs view
@@ -0,0 +1,8 @@+module Str0 () where++import Language.Haskell.Liquid.Prelude++foo = "dog"++prop1 = liquidAssertB (0 == 1)	+prop2 = liquidAssertB (1 /= 1)
+ tests/neg/sumPoly.hs view
@@ -0,0 +1,6 @@+module Toy  where++{-@ sumPoly :: forall <p ::a -> Prop>. (Num a, Ord a) => [a<p>] -> a<p> @-} +sumPoly     :: (Num a, Ord a) => [a] -> a+sumPoly (x:xs) = foldl (+) x xs+
+ tests/neg/sumk.hs view
@@ -0,0 +1,16 @@+module Sumk () where++import Language.Haskell.Liquid.Prelude++m   = choose 0+bot = choose 0++dsum ranjit jhala k =+  if (ranjit `leq` 0)+    then k jhala +    else dsum (ranjit `minus` 1) (ranjit `plus` jhala) k++prop0 = dsum m bot (\x -> liquidAssertB ((m `plus` bot) `leq` x))++prop1 = liquidAssertB (1 `leq` 0)+
+ tests/neg/test00.hs view
@@ -0,0 +1,13 @@+module Test0 () where++import Language.Haskell.Liquid.Prelude++x :: Int+x = choose 0++prop_abs = if x > 0 then baz x else False++baz :: Int -> Bool+baz z = liquidAssertB (z `geq` 100)++
+ tests/neg/test00a.hs view
@@ -0,0 +1,9 @@+module Test0 () where++import Language.Haskell.Liquid.Prelude++x = choose 0++prop_abs = if x > 0 then baz x else False++baz z = liquidAssertB (z >= 10)
+ tests/neg/test00b.hs view
@@ -0,0 +1,14 @@+module Test0 () where++import Language.Haskell.Liquid.Prelude++x = choose 0++foo ::  Num a => a -> a+foo x = 0 - x++prop_abs ::  Bool+prop_abs = if x > 0 then baz (foo x) else False++baz ::  (Num a, Ord a) => a -> Bool+baz z = liquidAssertB (z > 0)
+ tests/neg/test1.hs view
@@ -0,0 +1,9 @@+module Test1 () where++import Language.Haskell.Liquid.Prelude++myabs x = if x `gt` 0 then x else 0 `minus` x++n = choose 0++prop_absf = liquidAssertB ((myabs n) `geq` 4)
+ tests/neg/test2.hs view
@@ -0,0 +1,11 @@+module Test1 () where++import Language.Haskell.Liquid.Prelude++myabs x = if x `gt` 0 then x else 0 `minus` x++n = choose 0++prop_absf = +  let zz = (myabs n) `geq` 4 in+  liquidAssertB zz
+ tests/neg/testRec.hs view
@@ -0,0 +1,29 @@+module TestRec () where++import Prelude hiding (map, foldl)++data L a = N | C a (L a)+{-@ +data L [llen] a = N | C (x::a) (xs::(L a))+  @-}++{-@ measure llen :: (L a) -> Int+    llen(N) = 0+    llen(C x xs) = 1 + (llen xs)+  @-}+++{-@ map :: (a -> b) -> [a] -> [b]@-}+map f []     = []+map f (x:xs) = f x : map f (x:xs)+ +-- bar = map id []++{-@ Decrease go 2 @-}+rev xs = go [] xs+  where go ack  []    = ack+        go ack (x:xs) = go (x:ack) xs+++mapL f N = N+mapL f (C x xs) = C (f x) (mapL f xs)
+ tests/neg/trans.hs view
@@ -0,0 +1,13 @@+module Tx () where++{-@ assert compre :: xs:[a] -> {v:[(a,a)] | len(v) = len(xs) } @-}+compre xs = [(x,x) | x <- xs]++{-@ assert transpose :: n: Int -> [{v:[a] | len(v) = n}] -> {v: [[a]] | len(v) > n} @-}+transpose               :: Int -> [[a]] -> [[a]]+transpose 0 _              = []+transpose n ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n-1) (xs : [ t | (_:t) <- xss]) +-- transpose []             = []+-- transpose ([]   : xss)   = transpose xss++
+ tests/neg/truespec.hs view
@@ -0,0 +1,7 @@+module TrueSpec (foo) where++import Language.Haskell.Liquid.Prelude (liquidAssert)++{-@ foo :: Int -> Int @-}+foo :: Int -> Int+foo x = liquidAssert (x > 0) $ x + 1
+ tests/neg/tyclass0-unsafe.hs view
@@ -0,0 +1,11 @@+module Goo (poop) where++class Zog a where+  zoom :: a -> Int++-- Assume the relevant behavior for the method.+{-@ zoom :: (Zog a) => a -> Int @-}++-- Uses the behavior of `zoom`+{-@ poop :: (Zog a) => a -> Nat @-}+poop x = zoom x
+ tests/neg/vector0.hs view
@@ -0,0 +1,22 @@+module Vec0 () where++import Language.Haskell.Liquid.Prelude+import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))++xs  = [1,2,3,4] :: [Int]+vs  = fromList xs++prop0 = liquidAssertB (x >= 0)+        where x = Prelude.head xs++prop1 = liquidAssertB (n > 0)+        where n = Prelude.length xs++prop2 = liquidAssertB (Data.Vector.length vs > 0)+prop3 = liquidAssertB (Data.Vector.length vs > 3)++x0    = [ vs ! 0+        , vs ! 1+        , vs ! 2+        , vs ! 3 +        , vs ! 4]
+ tests/neg/vector00.hs view
@@ -0,0 +1,12 @@+module Vec0 () where++import Language.Haskell.Liquid.Prelude++import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))++xs    = [1,2,3,4] :: [Int]+vs    = fromList xs+jhala = vs ! (x + y + z)+  where x = 2+        y = 3+        z = 5
+ tests/neg/vector0a.hs view
@@ -0,0 +1,20 @@+module Vec0 () where++import Language.Haskell.Liquid.Prelude++import Data.Vector hiding(map, concat, zipWith, filter, foldl, foldr, (++))++xs  = [1,2,3,4] :: [Int]+vs  = fromList xs++--prop0 = liquidAssertB (x >= 0)+--        where x = Prelude.head xs+--+--prop1 = liquidAssertB (n > 0)+--        where n = Prelude.length xs+--+--prop2 = liquidAssertB (Data.Vector.length vs > 0)+--prop3 = liquidAssertB (Data.Vector.length vs > 3)++prop6 = crash (0 == 1) +x0    = vs ! 0
+ tests/neg/vector1a.hs view
@@ -0,0 +1,22 @@+module Vec1 () where++import Language.Haskell.Liquid.Prelude+import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))+++-- HA this needs a non-TOP spec due to contravariance...+foo = (Data.Vector.!) ++for :: Int -> Int -> a -> (Int -> a -> a) -> a+for lo hi acc f +  | lo < hi   = for (lo + 1) hi (f lo acc) f+  | otherwise = acc ++dotProd       :: Vector Int -> Vector Int -> Int+dotProd v1 v2 = for 0 n 0 $ \i -> (((v1!i) * (v2!i)) +)+  where n = Data.Vector.length v1++sumSquare   :: Vector Int -> Int+sumSquare v = dotProd v v++total = sumSquare $ Data.Vector.fromList [0..100]
+ tests/neg/vector2.hs view
@@ -0,0 +1,67 @@+module Vec0 () where++import Prelude hiding (length)+import Data.Vector+import Language.Haskell.Liquid.Prelude (liquidAssert)+    +{-@ predicate Lt X Y      = X < Y                         @-}+{-@ predicate Ge X Y      = not (Lt X Y)                  @-}+{-@ predicate InBound I A = ((Ge I 0) && (Lt I (vlen A))) @-}++{-@ unsafeLookup :: vec:Vector a +                 -> {v: Int | (0 <= v && v < (vlen vec)) } +                 -> a @-}+unsafeLookup vec i = vec ! i++{-@ unsafeLookup' :: vec:Vector a -> {v: Int | (InBound v vec)} -> a @-}+unsafeLookup' vec i = vec ! i++safeLookup x i +  | 0 <= i && i < length x = Just (x ! i)+  | otherwise              = Nothing ++{-@ absoluteSum   :: Vector Int -> {v: Int | 0 <= v}  @-}+absoluteSum       :: Vector Int -> Int +absoluteSum vec   = if 0 < n then go 0 0 else 0+  where+    go acc i +      | i /= n    = go (acc + abz (vec ! i)) (i + 1)+      | otherwise = acc +    n             = length vec++abz n = if 0 <= n then n else (0 - n) ++loop :: Int -> Int -> a -> (Int -> a -> a) -> a +loop lo hi base f = go base lo+  where+    go acc i     +      | i /= hi   = go (f i acc) (i + 1)+      | otherwise = acc++incr x = x + 1++zoo = incr 29++{-@ dotProduct :: x:(Vector Int) +               -> y:{v: Vector Int | (vlen x) = (vlen x)} +               -> Int +  @-}+dotProduct     :: Vector Int -> Vector Int -> Int+dotProduct x y +  = loop 0 (length x) 0 (\index -> (+ (x ! index) * (y ! index))) +  -- = error "dotProduct only on equal-sized vectors!"+++{-@ type SparseVector a N = [({v: Int | (0 <= v && v <= N)}, a)] @-}++{-@ sparseDotProduct :: (Num a) => x:(Vector a) -> (SparseVector a {(vlen x)}) -> a @-}+sparseDotProduct x y  = go 0 y+  where +    go sum ((i, v) : y') = go (sum + (x ! i) * v) y' +    go sum []            = sum++jhala = vs ! (x + y + z)+  where x = 2+        y = 3+        z = 5+        vs = fromList [1,2,3,4]
+ tests/neg/wrap0.hs view
@@ -0,0 +1,21 @@+module Wrap0 () where++import Language.Haskell.Liquid.Prelude (liquidError, liquidAssertB)++{-@ data Foo a <p :: a -> Prop> = F (f :: a <p>) @-}+data Foo a = F a++type IntFoo = Foo Int++{-@ assert flibberty :: (Eq a) => a -> Bool @-}+flibberty x   = prop x (F x)+prop x (F y)  = liquidAssertB (x == y)++{-@ assert flibInt :: (Num a, Ord a) => a -> Bool @-}+flibInt x     = prop1 x (F (x + 1))+prop1 x (F y) = liquidAssertB (x < y) ++{-@ assert flibXs :: a -> Bool @-}+flibXs x     = prop2 (F [x, x, x])+prop2 (F _ ) = liquidError "no!"+prop2 (F _ ) = True
+ tests/neg/wrap1.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Wrap0 () where+++import Language.Haskell.Liquid.Prelude (liquidError, liquidAssertB)+import Data.Function (on)+import Data.Ord (comparing)++data WrapType b a = WrapType {getVect :: b, getVal :: a}++instance Eq (WrapType [Double] a) where+   (==) = (==) `on` getVect++instance Ord (WrapType [Double] a) where+    compare = comparing getVect++{-@ assert flibXs :: a -> Bool @-}+flibXs x              = prop1 (WrapType [x, x, x] x)+prop1 (WrapType [] _) = liquidError "no!"+prop1 (WrapType _  _) = True++{-@ assert nflibXs :: Int -> a -> Bool @-}+nflibXs n x           = prop2 n (WrapType nxs x)+                        where nxs = replicate n x ++prop2 n (WrapType xs _) = liquidAssertB (n > length xs) +++++
+ tests/pos/AVL.hs view
@@ -0,0 +1,95 @@+{- Example of AVL trees by michaelbeaumont -}++{-@ LIQUID "--totality" @-}+module AVL (Tree, singleton, insert) where++-- Basic functions+{-@ data Tree [ht] a = Nil | Tree (x::a) (l::Tree a) (r::Tree a) @-}+data Tree a = Nil | Tree a (Tree a) (Tree a) deriving Show++{-@ measure ht @-}+ht              :: Tree a -> Int+ht Nil          = 0+ht (Tree x l r) = if (ht l) > (ht r) then (1 + ht l) else (1 + ht r)+{-@ invariant {v:Tree a | 0 <= ht v} @-}+++{-@ measure bFac @-}+bFac Nil          = 0+bFac (Tree v l r) = ht l - ht r++{-@ htDiff :: s:Tree a -> t: Tree a -> {v: Int | HtDiff s t v} @-}+htDiff :: Tree a -> Tree a -> Int+htDiff l r = ht l - ht r++{-@ emp :: {v: AVLTree | ht v == 0} @-}+emp = Nil++{-@ singleton :: a -> {v: AVLTree | ht v == 1 }@-}+singleton a = Tree a Nil Nil++-- | Insert functions++{-@ Decrease insert 3 @-}+{-@ insert :: a -> s: AVLTree -> {t: AVLTree | EqHt t s || HtDiff t s 1 } @-}+insert :: (Ord a) => a -> Tree a -> Tree a+insert a Nil = singleton a+insert a t@(Tree v l r) = case compare a v of+    LT -> insL+    GT -> insR+    EQ -> t+    where r' = insert a r+          l' = insert a l+          insL | siblDiff > 1+                 && bFac l' == (0-1) = rebalanceLR v l' r+               | siblDiff > 1+                 && bFac l' == 1  = rebalanceLL v l' r+               | siblDiff <= 1 = Tree v l' r+               | otherwise = t+               where siblDiff = htDiff l' r+          insR | siblDiff > 1+                 && bFac r' == 1 = rebalanceRL v l r'+               | siblDiff > 1+                 && bFac r' == (0-1) = rebalanceRR v l r'+               | siblDiff <= 1 = Tree v l r'+               | otherwise = t+               where siblDiff = htDiff r' l++{-@ rebalanceLL :: a -> l:{AVLTree | LeftHeavy l } -> r:{AVLTree | HtDiff l r 2} -> {t:AVLTree | EqHt t l } @-}+rebalanceLL v (Tree lv ll lr) r                 = Tree lv ll (Tree v lr r)++{-@ rebalanceLR :: a -> l:{AVLTree | RightHeavy l } -> r:{AVLTree | HtDiff l r 2 } -> {t: AVLTree | EqHt t l } @-}+rebalanceLR v (Tree lv ll (Tree lrv lrl lrr)) r = Tree lrv (Tree lv ll lrl) (Tree v lrr r)++{-@ rebalanceRR :: a -> l: AVLTree -> r: {AVLTree | RightHeavy r && HtDiff r l 2 } -> {t: AVLTree | EqHt t r } @-}+rebalanceRR v l (Tree rv rl rr)                 = Tree rv (Tree v l rl) rr++{-@ rebalanceRL :: a -> l: AVLTree -> r:{AVLTree | LeftHeavy r && HtDiff r l 2} -> {t: AVLTree | EqHt t r } @-}+rebalanceRL v l (Tree rv (Tree rlv rll rlr) rr) = Tree rlv (Tree v l rll) (Tree rv rlr rr) ++-- Test+main = do+    mapM_ print [a,b,c,d]+  where+    a = singleton 5+    b = insert 2 a+    c = insert 3 b+    d = insert 7 c++-- Liquid Haskell++{-@ predicate HtDiff S T D = (ht S) - (ht T) == D @-}+{-@ predicate EqHt S T = (ht S) == (ht T) @-}++{-@ predicate LeftHeavy T = bFac T == 1 @-}+{-@ predicate RightHeavy T = bFac T == -1 @-}++{-@ measure balanced :: Tree a -> Prop+balanced (Nil) = true+balanced (Tree v l r) = ((ht l) <= (ht r) + 1)+                        && (ht r <= ht l + 1)+                        && (balanced l)+                        && (balanced r)+@-}++{-@ type AVLTree = {v: Tree a | balanced v} @-}
+ tests/pos/AVLRJ.hs view
@@ -0,0 +1,110 @@+{- Example of AVL trees by michaelbeaumont -}++{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--totality" @-}++module AVL (Tree, empty, singleton, insert) where++-- Basic functions+data Tree a = Nil | Tree { key :: a, l::Tree a, r :: Tree a} deriving Show++{-@ data Tree [ht] a = Nil+                     | Tree { key :: a+                            , l   :: Tree {v:a | v < key }+                            , r   :: Tree {v:a | key < v }+                            }+  @-}++{-@ measure ht @-}+ht              :: Tree a -> Int+ht Nil          = 0+ht (Tree _ l r) = if (ht l) > (ht r) then (1 + ht l) else (1 + ht r)+{-@ invariant {v:Tree a | 0 <= ht v} @-}+++{-@ measure bFac @-}+{-@ bFac :: t:AVLTree a -> {v:Int | v = bFac t && 0 <= v + 1 && v <= 1} @-}+bFac Nil          = 0+bFac (Tree _ l r) = ht l - ht r++{-@ htDiff :: s:Tree a -> t: Tree a -> {v: Int | HtDiff s t v} @-}+htDiff :: Tree a -> Tree a -> Int+htDiff l r = ht l - ht r++-- | Empty+{-@ empty :: {v: AVLTree a | ht v == 0} @-}+empty = Nil++-- | Singleton+{-@ singleton :: a -> {v: AVLTree a | ht v == 1 }@-}+singleton a = Tree a Nil Nil++-- | Insert++{-@ predicate PostInsert S T = ((bFac T == 0) => (EqHt T S || ht T == 1)) && (EqHt T S || HtDiff T S 1) @-}++{-@ insert :: a -> s: AVLTree a -> {t: AVLTree a | PostInsert s t } @-}+insert :: (Ord a) => a -> Tree a -> Tree a+insert a Nil = singleton a+insert a t@(Tree v _ _) = case compare a v of+    LT -> insL a t+    GT -> insR a t+    EQ -> t++{-@ insL :: x:a -> s:{AVLTree a | x < key s && ht s > 0} -> {t: AVLTree a | PostInsert s t } @-}+insL a (Tree v l r)+  | siblDiff == 2 && bl' == 1  = rebalanceLL v l' r+  | siblDiff == 2 && bl' == -1 = rebalanceLR v l' r+  | siblDiff <= 1              = Tree v l' r+  where+    l'                       = insert a l+    siblDiff                 = htDiff l' r+    bl'                      = bFac l'++{-@ insR :: x:a -> s:{AVLTree a | key s < x && ht s > 0} -> {t: AVLTree a | PostInsert s t } @-}+insR a (Tree v l r)+  | siblDiff == 2 && br' == 1  = rebalanceRL v l r'+  | siblDiff == 2 && br' == -1  = rebalanceRR v l r'+  | siblDiff <= 1            = Tree v l r'+  where+    siblDiff                 = htDiff r' l+    r'                       = insert a r+    br'                      = bFac r'+++{-@ rebalanceLL :: x:a -> l:{AVLL a x | LeftHeavy l } -> r:{AVLR a x | HtDiff l r 2} -> {t:AVLTree a | EqHt t l} @-}+rebalanceLL v (Tree lv ll lr) r                 = Tree lv ll (Tree v lr r)++{-@ rebalanceLR :: x:a -> l:{AVLL a x | RightHeavy l } -> r:{AVLR a x | HtDiff l r 2} -> {t: AVLTree a | EqHt t l } @-}+rebalanceLR v (Tree lv ll (Tree lrv lrl lrr)) r = Tree lrv (Tree lv ll lrl) (Tree v lrr r)++{-@ rebalanceRR :: x:a -> l: AVLL a x -> r:{AVLR a x | RightHeavy r && HtDiff r l 2 } -> {t: AVLTree a | EqHt t r } @-}+rebalanceRR v l (Tree rv rl rr)                 = Tree rv (Tree v l rl) rr++{-@ rebalanceRL :: x:a -> l: AVLL a x -> r:{AVLR a x | LeftHeavy r && HtDiff r l 2} -> {t: AVLTree a | EqHt t r } @-}+rebalanceRL v l (Tree rv (Tree rlv rll rlr) rr) = Tree rlv (Tree v l rll) (Tree rv rlr rr)++-- Test+main = do+    mapM_ print [a,b,c,d]+  where+    a = singleton 5+    b = insert 2 a+    c = insert 3 b+    d = insert 7 c++-- Liquid Haskell++{-@ predicate HtDiff S T D = ht S - ht T == D @-}+{-@ predicate EqHt S T     = HtDiff S T 0     @-}+{-@ predicate LeftHeavy  T = bFac T == 1      @-}+{-@ predicate RightHeavy T = bFac T == -1     @-}++{-@ measure balanced @-}+balanced              :: Tree a -> Bool+balanced (Nil)        = True+balanced (Tree v l r) = ht l - ht r <= 1 && ht l - ht r >= -1 && balanced l && balanced r++{-@ type AVLTree a   = {v: Tree a | balanced v} @-}+{-@ type AVLL a X    = AVLTree {v:a | v < X}    @-}+{-@ type AVLR a X    = AVLTree {v:a | X < v}    @-}
+ tests/pos/Abs.hs view
@@ -0,0 +1,16 @@+module Abs () where++absN ::  (Num a, Ord a) => a -> a+absN x = if x > 0 then x else (-x)++absI ::  Int -> Int +absI x = if x > 0 then x else (-x)++--incI ::  Int -> Int +--incI = (+) 1++x0 = absN 4+x1 = absI (-5)++--x2 = absI (incI 2)+-- x3 = absI (-3)
+ tests/pos/Ackermann.hs view
@@ -0,0 +1,8 @@+module Ackermann () where++{-@ ack :: m:Nat -> n:Nat -> Nat / [m, n]@-}+ack :: Int -> Int -> Int+ack m n+    | m == 0          = n + 1+    | m > 0 && n == 0 = ack (m-1) 1+    | m > 0 && n >  0 = ack (m-1) (ack m (n-1))
+ tests/pos/AmortizedQueue.hs view
@@ -0,0 +1,85 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--maxparams=3"    @-}++module LazyQueue where++-- Source: Okasaki, JFP 1995+-- http://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf++--------------------------------------------------------------------------------+-- | Sized Lists+--------------------------------------------------------------------------------++data SList a = SL { size  :: Int+                  , elems :: [a]+                  }++{-@ type SListN a N = {v:SList a | size v = N} @-}++-- | Invariant: `size` is really the size:++{-@ data SList a = SL { size  :: Int+                      , elems :: {v:[a] | len v = size}+                      }+  @-}++-- | Size function actually returns the size: (Duh!)++{-@ size :: q:SList a -> {v:Nat | v = size q} @-}++-- | Non-Empty Lists:++{-@ type NEList a = {v:SList a | size v > 0} @-}+++{-@ nil          :: SListN a 0  @-}+nil              = SL 0 []++{-@ cons         :: a -> xs:SList a -> SListN a {size xs + 1}   @-}+cons x (SL n xs) = SL (n+1) (x:xs)++{-@ tl           :: xs:NEList a -> SListN a {size xs - 1}  @-}+tl (SL n (_:xs)) = SL (n-1) xs+tl _             = die "never"++{-@ hd           :: xs:NEList a -> a @-}+hd (SL _ (x:_))  = x +hd _             = die "never"+++--------------------------------------------------------------------------------+-- | Sized Lists+--------------------------------------------------------------------------------++data Queue a = Q  { left   :: SList a+                  , right  :: SList a+                  }++-- | Invariant: `|right|` <= `|left|`++{-@ data Queue a = Q { left  :: SList a +                     , right :: {v:SList a | size v <= size left}+                     }+  @-}++++emp = Q nil nil++qsize         :: Queue a -> Int+qsize (Q l r) = size l + size r++insert e (Q l r) = makeq l (e `cons` r)++{-@ makeq :: l:_ -> r:{ _ | size r <= size l + 1} -> _  @-}+makeq l r+  | size r <= size l = Q l r+  | otherwise        = Q (rot l r nil) nil++{-@ rot :: l:_ -> r:SListN _ {1 + size l} -> a:_ -> {v:_ | size v = size l + size r + size a} @-}+rot l r a+  | size l == 0      = (hd r) `cons` a+  | otherwise        = (hd l) `cons` (rot (tl l) (tl r) ((hd r) `cons` a))++{-@ die :: {v:_ | false} -> a @-}+die x = error x
+ tests/pos/Assume.hs view
@@ -0,0 +1,8 @@+module Assume where++import Language.Haskell.Liquid.Prelude++{-@ assume foo :: {v:Bool | (Prop v)} @-}+foo = False++bar = liquidAssertB foo
+ tests/pos/AssumedRecursive.hs view
@@ -0,0 +1,5 @@+module Foo where++{-@ assume foo :: a -> a @-}+foo :: a -> a+foo f = foo f
+ tests/pos/Avg.hs view
@@ -0,0 +1,31 @@+module Avg where+++{-@ LIQUID "--real" @-}++{-@ measure sumD :: [Double] -> Double+    sumD([]) = 0.0+    sumD(x:xs) = x + (sumD xs)+  @-}++{-@ measure lenD :: [Double] -> Double+    lenD([]) = 0.0+    lenD(x:xs) = (1.0) + (lenD xs)+  @-}++{-@ expression Avg Xs = ((sumD Xs) / (lenD Xs))  @-}++{-@ meansD :: xs:{v:[Double] | ((lenD v) > 0.0)} +           -> {v:Double | v = Avg xs} @-}+meansD :: [Double] -> Double+meansD xs = sumD xs / lenD xs++{-@ lenD :: xs:[Double] -> {v:Double | v = (lenD xs)} @-}+lenD :: [Double] -> Double+lenD [] = 0.0+lenD (x:xs) = 1.0 + lenD xs++{-@ sumD :: xs:[Double] -> {v:Double | v = (sumD xs)} @-}+sumD :: [Double] -> Double+sumD [] = 0.0+sumD (x:xs) = x + sumD xs
+ tests/pos/BST.hs view
@@ -0,0 +1,79 @@+module BST () where++import Language.Haskell.Liquid.Prelude++{-@+data Bst [blen] k v <l :: x0:k -> x1:k -> Prop, r :: x0:k -> x1:k -> Prop>+  = Empty+  | Bind (key   :: k) +         (value :: v) +         (left  :: Bst <l, r> (k <l key>) v) +         (right :: Bst <l, r> (k <r key>) v)+  @-}++{-@ measure blen :: (Bst k v) -> Int+    blen(Empty)        = 0+    blen(Bind k v l r) = 1 + (blen l) + (blen r)+  @-}++{-@ invariant {v:Bst k v | (blen v) >= 0} @-}++data Bst k v = Empty | Bind k v (Bst k v) (Bst k v)++{-@+data Pair k v <p :: x0:k -> x1:k -> Prop, l :: x0:k -> x1:k -> Prop, r :: x0:k -> x1:k -> Prop>+  = P (fld0 :: k) (fld1 :: v) (tree :: Bst <l, r> (k <p fld0>) v) +  @-}++data Pair k v = P k v (Bst k v)++-- insert :: (Eq k, Ord k) => k -> v -> Bst k v -> Bst k v+insert k v Empty  = Bind k v Empty Empty+insert k v (Bind k' v' l r)+  | k == k'       = Bind k v l r+  | k < k'        = Bind k' v' (insert k v l) r+  | otherwise     = Bind k' v' l (insert k v r)++-- delete :: (Eq k, Ord k) => k -> Bst k v -> Bst k v+delete _ Empty = Empty+delete k' (Bind k v l r)+  | k' == k = +      case r of +       Empty   -> l+       _       -> let P kmin vmin r' = getMin r in Bind kmin vmin l r'+  | k' < k = Bind k v (delete k' l) r+  | otherwise = Bind k v l (delete k' r)++getMin (Bind k v Empty rt) = P k v rt+getMin (Bind k v lt rt)    = P k0min v0min (Bind k v l' rt)+   where P k0min v0min l' = getMin lt+getMin _                   = error "getMin"++chkMin x Empty            = liquidAssertB True  +chkMin x (Bind k v lt rt) = liquidAssertB (x<k) && chkMin x lt && chkMin x rt++chk Empty            = liquidAssertB True  +chk (Bind k v lt rt) = chk lt && chk rt && chkl k lt && chkr k rt+		+chkl k Empty = liquidAssertB True+chkl k (Bind kl _ _ _) = liquidAssertB (kl < k)++chkr k Empty = liquidAssertB True+chkr k (Bind kr _ _ _) = liquidAssertB (k < kr)++key, key1, val, val1 :: Int+key = choose 0+val = choose 1+key1 = choose 0+val1 = choose 1++bst = insert key val $ insert key1 val1 Empty++mkBst = foldl (\t (k, v) -> insert k v t) Empty++prop        = chk bst+prop1       = chk $ mkBst $ zip [1..] [1..]+propDelete  = chk $ delete 1 bst+propMin     = chkMin x t+    where pr  = getMin bst+          P x _ t = pr
+ tests/pos/BST000.hs view
@@ -0,0 +1,65 @@+module BST () where++import Language.Haskell.Liquid.Prelude+++{-@+data Bst [blen] k v <l :: root:k -> x1:k -> Prop, r :: root:k -> x1:k -> Prop>+  = Empty+  | Bind (key   :: k) +         (value :: v) +         (left  :: Bst <l, r> (k <l key>) v) +         (right :: Bst <l, r> (k <r key>) v)+  @-}++{-@ measure blen :: (Bst k v) -> Int+    blen(Empty)        = 0+    blen(Bind k v l r) = 1 + (blen l) + (blen r)+  @-}++{-@ invariant {v:Bst k v | (blen v) >= 0} @-}++data Bst k v = Empty | Bind k v (Bst k v) (Bst k v)++{-@ type OBST k a = Bst <{\root v -> v < root }, {\root v ->  v > root}> k a @-}++{-@ chkMin :: (Ord k) => x:k -> OBST {v:k | x < v} a -> Bool @-}+chkMin :: (Ord k) => k -> Bst k a -> Bool+chkMin x Empty            = liquidAssertB True  +chkMin x (Bind k v lt rt) = liquidAssertB (x<k) && chkMin x lt && chkMin x rt++{-@+data Pair k v <p :: x0:k -> x1:k -> Prop, l :: x0:k -> x1:k -> Prop, r :: x0:k -> x1:k -> Prop>+  = P (fld0 :: k) (fld1 :: v) (tree :: Bst <l, r> (k <p fld0>) v) +  @-}++data Pair k v = P k v (Bst k v)++getMin (Bind k v Empty rt) = (k, rt)+getMin (Bind k v lt rt)    = case getMin lt of+                               (k0, l') -> (k0, Bind k v l' rt) +getMin _                   = error "getMin"++{-@ propMin :: (Ord k) => OBST k a -> Bool @-}+propMin :: (Ord k) => Bst k a -> Bool+propMin bst = chkMin x t+    where (x, t) = getMin bst +++zoo :: Int -> (Int, Int)+zoo x = (x, x + 1)+++m = zoo 12++++++++++++
+ tests/pos/Bar.hs view
@@ -0,0 +1,5 @@+module Bar where++import Foo++foo = bar
+ tests/pos/Class.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-@ LIQUID "--no-termination" @-}+module Class () where++import Language.Haskell.Liquid.Prelude+import Prelude hiding (sum, length, (!!), Functor(..))+import qualified Prelude as P++{-@ qualif Size(v:int, xs:a): v = (size xs) @-}++{-@ data List a = Nil | Cons (hd::a) (tl::(List a)) @-}+data List a = Nil | Cons a (List a)++{-@ length :: xs:List a -> {v:Nat | v = (size xs)} @-}+length :: List a -> Int+length Nil         = 0+length (Cons x xs) = 1 + length xs++{-@ (!!) :: xs:List a -> {v:Nat | v < (size xs)} -> a @-}+(!!) :: List a -> Int -> a+Nil         !! i = liquidError "impossible"+(Cons x _)  !! 0 = x+(Cons x xs) !! i = xs !! (i - 1)++{-@ class measure size :: forall a. a -> Int @-}+{-@ class Sized s where+      size :: forall a. x:s a -> {v:Nat | v = (size x)}+  @-}+class Sized s where+  size :: s a -> Int++instance Sized List where+  {-@ instance measure size :: List a -> Int+      size (Nil)       = 0+      size (Cons x xs) = 1 + (size xs)+    @-}+  size = length++instance Sized [] where+  {-@ instance measure size :: [a] -> Int+      size ([])   = 0+      size (x:xs) = 1 + (size xs)+    @-}+  size [] = 0+  size (x:xs) = 1 + size xs++{-@ class (Sized s) => Indexable s where+      index :: forall a. x:s a -> {v:Nat | v < (size x)} -> a+  @-}+class (Sized s) => Indexable s where+  index :: s a -> Int -> a+++instance Indexable List where+  index = (!!)++{-@ sum :: Indexable s => s Int -> Int @-}+sum :: Indexable s => s Int -> Int+sum xs = go max 0+  where+    max = size xs+    go (d::Int) i+      | i < max   = index xs i + go (d-1) (i+1)+      | otherwise = 0+++{-@ sumList :: List Int -> Int @-}+sumList :: List Int -> Int+sumList xs = go max 0+  where+    max = size xs+    go (d::Int) i+      | i < max   = index xs i + go (d-1) (i+1)+      | otherwise = 0+++{-@ x :: {v:List Int | (size v) = 3}  @-}+x :: List Int+x = 1 `Cons` (2 `Cons` (3 `Cons` Nil))++foo = liquidAssert $ size (Cons 1 Nil) == size [1]
+ tests/pos/Class2.hs view
@@ -0,0 +1,6 @@+module Class2 where++{-@ LIQUID "--idirs=../neg" @-}+import Class5++instance Foo ()
+ tests/pos/ClassReg.hs view
@@ -0,0 +1,18 @@+module Compose where+++data ST s a = ST {runState :: s -> (a,s)}++{-@ data ST s b <r :: s -> b -> Prop> +  = ST (runState :: x:s -> (b<r x>, s)) @-}+++class MM m where+  bind :: m a -> (a -> m b) -> m b+  cmp  :: m a -> m b -> m b++instance MM (ST s) where+  cmp m f = bind m (\_ -> f) +++
+ tests/pos/Coercion.hs view
@@ -0,0 +1,26 @@++{-@ LIQUID "--no-termination" @-}++module Encoding where++data F a = F a+data BS = BS (F Int)+bar :: IO (F Int)+bar = undefined++foo = undefined+++-- start ::  F Int -> IO BS+start fp = foo fp $ go+  where go ptr = do+         -- ensure :: (IO BS ~ IO b) => IO b -> IO b+         let ensure act+               | False = act+               | otherwise = do+                   fp' <- bar+                   start fp -- ((start fp) `cast` (IO BS ~ IO b)) +         ensure $ return $ BS fp+      ++
+ tests/pos/CompareConstraints.hs view
@@ -0,0 +1,85 @@+module Foo where++import Language.Haskell.Liquid.Prelude+++{-@ mycmp :: forall <p :: a -> Prop, q :: a -> Prop>. +           {x::a<p>, y::a<q> |- a <: {v:a | x <= y} } +           Ord a => +           [a<p>] -> [a<q>] -> Bool @-}+mycmp :: Ord a => [a] -> [a] -> Bool+mycmp (x:_) (_:y:_) = liquidAssert (x <= y) True+++{-@ mycmp' :: forall <p :: a -> Prop, q :: a -> Prop>. +           {x::a<p>, y::a<q> |- a <: {v:a | x <= y} } +           Ord a => +           a<p> -> a<q> -> Bool @-}+mycmp' :: Ord a => a -> a -> Bool+mycmp' x y = liquidAssert (x <= y) True++bar :: Bool+bar = let w = choose 0 in +      let x = w + 1 in +      let y = w - 1 in +      let z = w + 2 in +      mycmp [x, y, x] [z, x, z]+++bar' :: Bool+bar' = let w = choose 0 in +      let x = w + 1 in +      let y = w - 1 in +      let z = w + 2 in +      mycmp' x z    +{-++-----------------+++data Dyn = Int Int | String String | Bool Bool +type Key = String+data Box = Record Key Dyn++emp :: Box+emp = undefined++class Value v where+  toDyn   :: v -> Dyn+  fromDyn :: Dyn -> v+ +put :: (Value v) => Key -> v -> Box -> Box+put k v b = insert k b (toDyn v) ++get :: (Value v) => Box -> Key -> v+get = undefined++rj  :: Box+rj  = put "name"     "Ranjit" +    $ put "age"      10+    $ put "sleeping" True+    $ emp ++out = "My name is " ++ get rj "name"+++sumXY box x y = get box x + get box y++-}+++++++++++++++++
+ tests/pos/Constraints.hs view
@@ -0,0 +1,51 @@+module Compose where++{-@ +cmp :: forall < pref :: b -> Prop, postf :: b -> c -> Prop+              , pre  :: a -> Prop, postg :: a -> b -> Prop+              , post :: a -> c -> Prop+              >. +       {xx::a<pre>, w::b<postg xx> |- c<postf w> <: c<post xx>}+       {ww::a<pre> |- b<postg ww> <: b<pref>}+       f:(y:b<pref> -> c<postf y>)+    -> g:(z:a<pre > -> b<postg z>)+    -> x: a<pre> -> c<post x>+@-}++cmp :: (b -> c)+    -> (a -> b)+    ->  a -> c++cmp f g x = f (g x)    ++++{-@ incr :: x:Nat -> {v:Nat | v == x + 1} @-}+incr :: Int -> Int+incr x = x + 1+++{-@ incr2 :: x:Nat -> {v:Nat | v == x + 2} @-}+incr2 :: Int -> Int+incr2 = cmp incr incr+++{-@ plus1 :: x:Nat -> {v:Nat | v == x + 20} @-}+plus1 :: Int -> Int+plus1 x = x + 20++{-@ plus2 :: x:{v:Nat | v > 10} -> {v:Nat | v == x + 22} @-}+plus2 :: Int -> Int+plus2 x = x + 22++{-@ plus42 :: x:Nat -> {v:Nat | v == x + 42} @-}+plus42 :: Int -> Int+plus42 = cmp plus2 plus1++++++++
+ tests/pos/ConstraintsAppend.hs view
@@ -0,0 +1,45 @@+module ListSort () where++{-@ LIQUID "--no-termination" @-}++import Language.Haskell.Liquid.Prelude++{-@ type OList a = [a]<{\x v -> v >= x}> @-}+++{-@ assume (++) :: forall <p :: a -> Prop, q :: a -> Prop, r :: a -> Prop>.+        {x::a<p> |- a<q> <: {v:a| x <= v}} +        {a<p> <: a<r>} +        {a<q> <: a<r>} +        Ord a => OList (a<p>) -> OList (a<q>) -> OList a<r> @-}+{-@ app :: forall <p :: a -> Prop, q :: a -> Prop, r :: a -> Prop>.+        {x::a<p> |- a<q> <: {v:a| x <= v}} +        {a<p> <: a<r>} +        {a<q> <: a<r>} +        Ord a => OList (a<p>) -> OList (a<q>) -> OList a<r> @-}+app :: Ord a => [a] -> [a] -> [a]+app []     ys = ys+app (x:xs) ys = x:(app xs ys) ++takeL :: Ord a => a -> [a] -> [a]+{-@ takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}] @-}+takeL x []     = []+takeL x (y:ys) = if (y<x) then y:(takeL x ys) else takeL x ys++takeGE :: Ord a => a -> [a] -> [a]+{-@ takeGE :: Ord a => x:a -> [a] -> [{v:a|v>=x}] @-}+takeGE x []     = []+takeGE x (y:ys) = if (y>=x) then y:(takeGE x ys) else takeGE x ys+++{-@ quicksort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}+quicksort []     = []+quicksort (x:xs) = xsle ++ (x:xsge)+  where xsle = quicksort (takeL x xs)+        xsge = quicksort (takeGE x xs)++{-@ qsort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}+qsort []     = []+qsort (x:xs) = (qsort [y | y <- xs, y < x]) ++ (x:(qsort [z | z <- xs, z >= x])) ++
+ tests/pos/DataBase.hs view
@@ -0,0 +1,25 @@+module DataBase where++data Rec s v = R (s -> v)+type DBRec = Rec String Value++get :: String -> DBRec -> Value +get i (R a) = a i++set :: String -> Value -> DBRec -> DBRec+set i x (R a) = R $ \k -> if k == i then x else a k++{-@ empty :: Rec {v:String|0=1} {v : DataBase.Value | v = DataBase.BOT} @-}+empty :: Rec String Value+empty = R $ const BOT++data Value = BOT+           | INT Int +           | BOOL Bool +           | STRING String+--            | VEC Value Int+++append a1 a2 = \k -> case a1 k of +                     BOT -> a2 k+                     v   -> v
+ tests/pos/Eval.hs view
@@ -0,0 +1,53 @@+{-@ LIQUID "--no-termination" @-}++module Eval (eval) where++import Language.Haskell.Liquid.Prelude (liquidError)+import Prelude hiding (lookup)+import Data.Set (Set (..))++{-@ embed Set as Set_Set @-}++type Val  = Int++type Bndr = String ++data Expr = Const Int+          | Var   Bndr+          | Plus  Expr Expr+          | Let   Bndr Expr Expr++type Env  = [(Bndr, Val)]++------------------------------------------------------------------+{-@ lookup :: x:Bndr -> {v:Env | Set_mem x (vars v)} -> Val @-}+lookup :: Bndr -> Env -> Val+---------------------  -------------------------------------------+lookup x ((y,v):env)   +  | x == y             = v+  | otherwise          = lookup x env+lookup x []            = liquidError "Unbound Variable"++------------------------------------------------------------------+{-@ eval :: g:Env -> CExpr g -> Val @-}+------------------------------------------------------------------+eval env (Const i)     = i+eval env (Var x)       = lookup x env +eval env (Plus e1 e2)  = eval env e1 + eval env e2 +eval env (Let x e1 e2) = eval env' e2 +  where +    env'               = (x, eval env e1) : env++{-@ type CExpr G = {v:Expr | Set_sub (free v) (vars G)} @-}++{-@ measure vars :: Env -> (Set Bndr)+    vars ([])    = {v | Set_emp v }+    vars (b:env) = {v | v = Set_cup (Set_sng (fst b)) (vars env)}+  @-}++{-@ measure free       :: Expr -> (Set Bndr) +    free (Const i)     = {v | Set_emp v}+    free (Var x)       = {v | v = Set_sng x} +    free (Plus e1 e2)  = {v | v = Set_cup (free e1) (free e2)}+    free (Let x e1 e2) = {v | v = Set_cup (free e1) (Set_dif (free e2) (Set_sng x))}+  @-}
+ tests/pos/Even.hs view
@@ -0,0 +1,9 @@+module Even () where++{-@ isEven, isOdd :: Nat -> Bool @-}+isEven :: Int -> Bool+isEven 0 = True+isEven n = isOdd  $ n - 1++isOdd  0 = False+isOdd  m = isEven $ m - 1
+ tests/pos/Even0.hs view
@@ -0,0 +1,13 @@+module Even () where++{-@ isEven :: n:Nat -> Bool / [n, 0]@-}+{-@ isOdd  :: m:Nat -> Bool / [m, 1] @-}+isEven, isOdd  :: Int -> Bool++isEven 0 = True+isEven n = isOdd  $ n - 1++isOdd  k = not $ isEven k+++
+ tests/pos/FFI.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-@ LIQUID "--c-files=../ffi-include/foo.c" @-}+{-@ LIQUID "-i../ffi-include" @-}+module Main where++import Foreign.C.Types++{-@ embed CInt as int @-}+{-@ embed Integer as int @-}++{-@ assume c_foo :: x:{CInt | x > 0} -> IO {v:CInt | v = x} @-}+foreign import ccall unsafe "foo.c foo" c_foo+  :: CInt -> IO CInt++main :: IO ()+main = print . fromIntegral =<< c_foo 1
+ tests/pos/Foo.hs view
@@ -0,0 +1,6 @@+module Foo where+++bar = 0++{-@ assume (Prelude.++) :: [a] -> [a] -> [a] @-}
+ tests/pos/Fractional.hs view
@@ -0,0 +1,15 @@+module Fixme where+++{-@ foo :: Fractional a => {v:a | v >= 1.0} @-}+foo :: Fractional a => a+foo = undefined++{-@ foo'' :: RealFloat a => {v:a | v >= 1.0} @-}+foo'' :: RealFloat a => a+foo'' = undefined+++{-@ foo' :: Num a => {v:a | v >= 1} @-}+foo' :: Num a => a+foo' = undefined
+ tests/pos/GCD.hs view
@@ -0,0 +1,22 @@+module GCD () where++import Prelude hiding (gcd, mod)+import Language.Haskell.Liquid.Prelude+{-@ mod :: a:Nat -> b:{v:Nat| ((v < a) && (v > 0))} -> {v:Nat | v < b} @-}+mod :: Int -> Int -> Int+mod a b | a - b >  b = mod (a - b) b+        | a - b <  b = a - b+        | a - b == b = 0++{-@ gcd :: a:Nat -> b:{v:Nat | v < a} -> Int @-}+gcd :: Int -> Int -> Int+gcd a 0 = a+gcd a b = gcd b (a `mod` b)++{-@ gcd' :: a:Nat -> b:Nat -> Nat / [a, b] @-}+gcd' :: Int -> Int -> Int+gcd' a b | a == 0 = b+         | b == 0 = a+         | a == b = a+         | a >  b = gcd' (a - b) b +         | a <  b = gcd' a (b - a)
+ tests/pos/GeneralizedTermination.hs view
@@ -0,0 +1,37 @@+module GenTerm () where++import Prelude hiding (reverse)++foo :: Int -> Int -> Int+{-@ foo :: n:Nat -> m:Nat -> Nat /[n+m] @-}++foo n m +  | cond 1 = 0+  | cond 2 && n > 1 = foo (n-1) m+  | cond 3 && m > 2 = foo (n+1) (m-2)+ +{-@ cond :: Int -> Bool @-}+cond :: Int -> Bool+cond _ = undefined+++data L a = N | C a (L a)++{-@ data L [llen] @-}++{-@ measure llen :: (L a) -> Int+    llen(N)      = 0+    llen(C x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v: L a | (llen v) >= 0} @-}++{-@ reverse :: xs: L a -> ys : L a -> L a / [(llen ys)] @-}+reverse :: L a -> L a -> L a+reverse xs N = xs+reverse xs (C y ys) = reverse (C y xs) ys++merge :: Ord a => L a -> L a -> L a +{-@ merge :: Ord a => xs:L a -> ys:L a -> L a /[(llen xs) + (llen ys)]@-}+merge (C x xs) (C y ys) | x > y     = C x $ merge xs (C y ys) +                        | otherwise = C y $ merge (C x xs) ys
+ tests/pos/GhcListSort.hs view
@@ -0,0 +1,128 @@+{-@ LIQUID "--no-termination" @-}++module GhcSort () where++import Language.Haskell.Liquid.Prelude++{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}++---------------------------------------------------------------------------+---------------------------  Official GHC Sort ----------------------------+---------------------------------------------------------------------------++{-@ assert sort1 :: (Ord a) => [a] -> OList a  @-}+sort1 :: (Ord a) => [a] -> [a]+sort1 = mergeAll . sequences+  where+    sequences (a:b:xs)+      | a `compare` b == GT = descending b [a]  xs+      | otherwise           = ascending  b (a:) xs+    sequences [x] = [[x]]+    sequences []  = [[]]++    descending a as (b:bs)+      | a `compare` b == GT = descending b (a:as) bs+    descending a as bs      = (a:as): sequences bs++    ascending a as (b:bs)+      | a `compare` b /= GT = ascending b (\ys -> as (a:ys)) bs+    ascending a as bs       = as [a]: sequences bs++    mergeAll [x] = x+    mergeAll xs  = mergeAll (mergePairs xs)++    mergePairs (a:b:xs) = merge1 a b: mergePairs xs+    mergePairs [x]      = [x]+    mergePairs []       = []++-- merge1 needs to be toplevel,+-- to get applied transformRec tx+merge1 (a:as') (b:bs')+  | a `compare` b == GT = b:merge1 (a:as')  bs'+  | otherwise           = a:merge1 as' (b:bs')+merge1 [] bs            = bs+merge1 as []            = as++---------------------------------------------------------------------------+------------------- Mergesort ---------------------------------------------+---------------------------------------------------------------------------++{-@ assert sort2 :: (Ord a) => [a] -> OList a  @-}+sort2 :: (Ord a) => [a] -> [a]+sort2 = mergesort++mergesort :: (Ord a) => [a] -> [a]+mergesort = mergesort' . map wrap++mergesort' :: (Ord a) => [[a]] -> [a]+mergesort' [] = []+mergesort' [xs] = xs+mergesort' xss = mergesort' (merge_pairs xss)++merge_pairs :: (Ord a) => [[a]] -> [[a]]+merge_pairs [] = []+merge_pairs [xs] = [xs]+merge_pairs (xs:ys:xss) = merge xs ys : merge_pairs xss++merge :: (Ord a) => [a] -> [a] -> [a]+merge [] ys = ys+merge xs [] = xs+merge (x:xs) (y:ys)+ = case x `compare` y of+        GT -> y : merge (x:xs)   ys+        _  -> x : merge    xs (y:ys)++wrap :: a -> [a]+wrap x = [x]++----------------------------------------------------------------------+-------------------- QuickSort ---------------------------------------+----------------------------------------------------------------------++{-@ assert sort3 :: (Ord a) => w:a -> [{v:a|v<=w}] -> OList a @-}+sort3 :: (Ord a) => a -> [a] -> [a]+sort3 w ls = qsort w ls []++-- qsort is stable and does not concatenate.+qsort :: (Ord a) =>  a -> [a] -> [a] -> [a]+qsort _ []     r = r+qsort _ [x]    r = x:r+qsort w (x:xs) r = qpart w x xs [] [] r++-- qpart partitions and sorts the sublists+qpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> [a]+qpart w x [] rlt rge r =+    -- rlt and rge are in reverse order and must be sorted with an+    -- anti-stable sorting+    rqsort x rlt (x:rqsort w rge r)+qpart w x (y:ys) rlt rge r =+    case compare x y of+        GT -> qpart w x ys (y:rlt) rge r+        _  -> qpart w x ys rlt (y:rge) r++-- rqsort is as qsort but anti-stable, i.e. reverses equal elements+rqsort :: (Ord a) => a -> [a] -> [a] -> [a]+rqsort _ []     r = r+rqsort _ [x]    r = x:r+rqsort w (x:xs) r = rqpart w x xs [] [] r++rqpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> [a]+rqpart w x [] rle rgt r =+    qsort x rle (x:qsort w rgt r)+rqpart w x (y:ys) rle rgt r =+    case compare y x of+        GT -> rqpart w x ys rle (y:rgt) r+        _  -> rqpart w x ys (y:rle) rgt r+++++++++++++
+ tests/pos/GhcSort1.hs view
@@ -0,0 +1,57 @@+{-# Language ScopedTypeVariables #-}+module ListSort () where++import Language.Haskell.Liquid.Prelude -- (liquidAssertB, choose)++{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}+{-@ assert sort1 :: (Ord a) => [a] -> OList a  @-}+sort1 :: (Ord a) => [a] -> [a]+sort1 xs = mergeAll  (sequences xs 0)+  where+    {-@ Decrease sequences  1 2 @-}+    {-@ Decrease descending 3 4 @-}+    {-@ Decrease ascending  3 4 @-}+    sequences (a:b:xs) (_::Int)+      | a `compare` b == GT = descending b [a]  xs 1+      | otherwise           = ascending  b (a:) xs 1+    sequences [x] _ = [[x]]+    sequences []  _ = [[]]++    descending a as (b:bs) (_::Int)+      | a `compare` b == GT = descending b (a:as) bs 1+    descending a as bs _    = (a:as): sequences bs 0++    ascending a as (b:bs) (_ :: Int)+      | a `compare` b /= GT = ascending b (\ys -> as (a:ys)) bs 1+    ascending a as bs _     = as [a]: sequences bs 0++    mergeAll []  = [] --this case cannot occur, though  +    mergeAll [x] = x+    mergeAll xs  = mergeAll (mergePairs xs)++{-@ mergePairs :: Ord a +               => xss:[(OList a)] +               -> {v:[(OList a)] | (if ((len xss) > 1) then ((len v) < (len xss)) else ((len v) = (len xss) ))}+  @-}+mergePairs :: Ord a => [[a]] -> [[a]]+mergePairs (a:b:xs) = merge1 a b: mergePairs xs+mergePairs [x]      = [x]+mergePairs []       = []++-- merge1 needs to be toplevel,+-- to get applied transformRec tx++{-@ merge1 :: Ord a +           => xs:(OList a) +           -> ys:(OList a)+           -> {v:(OList a) | (len v) = ((len xs) + (len ys))} +           / [(len xs) + (len ys)] +  @-}+merge1 :: Ord a => [a] -> [a] -> [a]+merge1 (a:as') (b:bs')+  | a `compare` b == GT = b:merge1 (a:as')  bs'+  | otherwise           = a:merge1 as' (b:bs')+merge1 [] bs            = bs+merge1 as []            = as++
+ tests/pos/GhcSort2.hs view
@@ -0,0 +1,47 @@+module GhcSort () where++import Language.Haskell.Liquid.Prelude++{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}+++{-@ assert sort2 :: (Ord a) => [a] -> OList a  @-}+sort2 :: (Ord a) => [a] -> [a]+sort2 = mergesort++mergesort :: (Ord a) => [a] -> [a]+mergesort = mergesort' . map wrap++mergesort' :: (Ord a) => [[a]] -> [a]+mergesort' [] = []+mergesort' [xs] = xs+mergesort' xss = mergesort' (merge_pairs xss)++{-@ predicate DLen X Y = +    (if ((len X) > 1) +     then ((len Y) < (len X)) +     else ((len X) = (len Y))) +  @-}++{-@ merge_pairs :: (Ord a) => xs:[OList a] -> {v:[OList a] | (DLen xs v)} @-}+merge_pairs :: (Ord a) => [[a]] -> [[a]]+merge_pairs [] = []+merge_pairs [xs] = [xs]+merge_pairs (xs:ys:xss) = merge xs ys d : merge_pairs xss+  where d = length xs + length ys+++{-@ Decrease merge 4 @-}+{-@ merge :: (Ord a) => xs:OList a -> ys:OList a -> {n:Nat|n = (len xs) + (len ys)} -> OList a  @-}+merge :: (Ord a) => [a] -> [a] -> Int -> [a]+merge [] ys _ = ys+merge xs [] _ = xs+merge (x:xs) (y:ys) d+ = case x `compare` y of+        GT -> y : merge (x:xs)   ys (d-1)+        _  -> x : merge xs   (y:ys) (d-1)++wrap :: a -> [a]+wrap x = [x]++
+ tests/pos/GhcSort3.hs view
@@ -0,0 +1,36 @@+module GhcSort () where++{-@ LIQUID "--no-termination" @-}++{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}++{-@ assert sort3 :: (Ord a) => w:a -> [{v:a|v<=w}] -> OList a @-}+sort3 :: (Ord a) => a -> [a] -> [a]+sort3 w ls = qsort w ls []++qsort :: (Ord a) =>  a -> [a] -> [a] -> [a]+qsort _ []     r = r+qsort _ [x]    r = x:r+qsort w (x:xs) r = qpart w x xs [] [] r++qpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> [a]+qpart w x [] rlt rge r =+    rqsort x rlt (x:rqsort w rge r)+qpart w x (y:ys) rlt rge r =+    case compare x y of+        GT -> qpart w x ys (y:rlt) rge r+        _  -> qpart w x ys rlt (y:rge) r++rqsort :: (Ord a) => a -> [a] -> [a] -> [a]+rqsort _ []     r = r+rqsort _ [x]    r = x:r+rqsort w (x:xs) r = rqpart w x xs [] [] r++rqpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> [a]+rqpart w x [] rle rgt r =+    qsort x rle (x:qsort w rgt r)+rqpart w x (y:ys) rle rgt r =+    case compare y x of+        GT -> rqpart w x ys rle (y:rgt) r+        _  -> rqpart w x ys (y:rle) rgt r+
+ tests/pos/Goo.hs view
@@ -0,0 +1,10 @@+module Goo (+    module Moo +  , plusTwo+ ) where++import Moo ++plusTwo :: Int -> Int+plusTwo = plusOne . plusOne+
+ tests/pos/Graph.hs view
@@ -0,0 +1,54 @@+module Graph () where++import Data.Set+++type Size = Int+data Map k v = Tip | Bin Size k v (Map k v) (Map k v)+             deriving (Eq, Ord)+++data Edges edge +++{-@ measure getEdgesIncoming :: (Edges edge) -> (Set edge) @-}++{-@ measure getEdgesOutgoing :: (Edges edge) -> (Set edge) @-}++data Graph node edge = +  Graph {+    graphMap :: +      Map node (Edges edge, Edges edge)+  }+++{-@ invariant {v: (Graph node edge) | (getGraphIncoming v) = (getGraphOutgoing v) } @-}++{-@ measure getGraphIncoming :: (Graph node edge) -> (Set edge)+    getGraphIncoming (Graph m) = (getMapIncoming m)+  @-}++{-@ measure getGraphOutgoing :: (Graph node edge) -> (Set edge)+    getGraphOutgoing (Graph m) = (getMapOutgoing m)+  @-}+++{-@ measure getMapIncoming :: (Map node (Edges edge, Edges e)) -> (Set edge)+    getMapIncoming (Tip) = {v | Set_emp v }+    getMapIncoming (Bin size k v lm rm) = (Set_cup (getPairIncoming v) (Set_cup (getMapIncoming lm) (getMapIncoming rm)))+  @-}+++{-@ measure getMapOutgoing :: (Map node (Edges edge, Edges edge)) -> (Set edge)+    getMapOutgoing (Tip) = {v | Set_emp v }+    getMapOutgoing (Bin size k v lm rm) = Set_cup (getPairOutgoing v) (Set_cup (getMapOutgoing lm) (getMapOutgoing rm))+  @-}++{-@ measure getPairIncoming :: (Edges edge, Edges e) -> (Set edge)+    getPairIncoming (x, y) = (getEdgesIncoming x)+  @-}++{-@ measure getPairOutgoing :: (Edges e, Edges edge) -> (Set edge)+    getPairOutgoing (x, y) = (getEdgesOutgoing y)+  @-}+
+ tests/pos/HasElem.hs view
@@ -0,0 +1,26 @@+module HasElem where++{-@ LIQUID "--no-termination" @-}++data L a = Nil | Cons a (L a)++{-@ measure hasElem @-}+hasElem :: Eq a => a -> L a -> Bool+hasElem x Nil = False+hasElem x (Cons y ys) = x == y || hasElem x ys++{-@ prop :: {v:Bool | Prop v <=> true} @-}+prop :: Bool+prop = hasElem 1 (Cons 1 Nil)++{-@ prop1 :: {v:Bool | Prop v <=> false} @-}+prop1 :: Bool+prop1 = hasElem 1 (Cons 2 Nil)++{-@ prop2 :: {v:Bool | Prop v <=> false} @-}+prop2 :: Bool+prop2 = hasElem 1 Nil+++nil = Nil+cons = Cons
+ tests/pos/HaskellMeasure.hs view
@@ -0,0 +1,16 @@+module Measures where++{-@ measure lllen @-}+llen :: [a] -> Int+llen [] = 0+llen (x:xs) = 1 + llen xs+++{-@ llen, llllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}++lllen :: [a] -> Int	+lllen [] = 0+lllen (x:xs) = 1 + lllen xs+++llllen = lllen
+ tests/pos/HedgeUnion.hs view
@@ -0,0 +1,49 @@+module Map where++import Language.Haskell.Liquid.Prelude++{-@+  data Map [mlen] k a <l :: root:k -> k -> Prop, r :: root:k -> k -> Prop>+      = Tip +      | Bin (right :: Map <l, r> k  a) +  @-}++{-@ measure mlen :: (Map k a) -> Int +    mlen(Tip) = 0+    mlen(Bin r) = 1 + (mlen r)+  @-}++{-@ invariant {v:Map k a | (mlen v) >= 0}@-}++{- type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}++data Map k a = Tip+             | Bin (Map k a)++type Size    = Int++-- Internal representation of hedgeUnion:++{-@ LAZYVAR d20r @-}++g t1 d20i = +  case d20i of+   Tip -> Tip+   Bin d20G -> (\_ -> let d20r = \_ -> let d20n  = \_ -> case t1 of+                                                         Tip -> liquidError ""+                                                         Bin  r -> r+                                      in case d20i of+                                          Tip -> d20n ""+                                          Bin d20j -> case d20j of+                                                        Tip -> Tip+                                                        Bin _ -> d20n ""+                         in case t1 of+                             Tip -> case d20i of +                                      Tip -> d20r ""+                                      Bin r -> r+                             Bin _ -> d20r "") ""++-- hedgeUnion t1 Tip      = Tip  +-- hedgeUnion Tip (Bin r) = r+-- hedgeUnion t1  (Bin Tip) = Tip+-- hedgeUnion (Bin r) t = r
+ tests/pos/HigherOrderRecFun.hs view
@@ -0,0 +1,6 @@+module HOF () where++foo :: [a] -> (b -> c) -> (b -> c)+foo []     f = f+foo (x:xs) f = foo xs f+
+ tests/pos/Holes.hs view
@@ -0,0 +1,38 @@+module Holes (plus) where++{-@ foo :: x:_ -> y:{Int | y > 0} -> _ @-}+foo :: Int -> Int -> Int+foo x y = x++zero = foo 0 1+++{-@ baz :: _ -> _ -> a @-}+baz :: a -> b -> b+baz x y = y++baz' = baz 1 2++data P a b = P a b++{-@ goo :: _ -> b -> _ @-}+goo :: P a b -> b -> a+goo p@(P a b) x = a++y = goo (P 1 1) 2+++{-@ bar :: {v:[{v0:Int | v0 > 0}] | _ } -> Int @-}+bar :: [Int] -> Int+bar [x] = x++x =  bar [1]++{-@ plus :: x:_ -> y:_ -> {v:_ | v = x + y} @-}+plus x y = x + y+++{-@ type UNat = {v:_ | v >= 0} @-}++{-@ zoo :: UNat @-}+zoo = 1
+ tests/pos/IcfpDemo.hs view
@@ -0,0 +1,81 @@+module IcfpDemo where++import Prelude hiding (gcd, map, repeat, take)+import Language.Haskell.Liquid.Prelude+++fac :: Int -> Int+fac n = if n <= 1 then 1 else n * fac (n-1)++--FIXME: fixpoint can't parse "mod" anymore..+{- gcd :: a:Nat -> {v:Nat | v < a} -> Nat @-}+-- gcd :: Int -> Int -> Int+-- gcd a 0 = a+-- gcd a b = gcd b (a `mod` b)++{-@ tfac :: Nat -> n:Nat -> Nat / [n] @-}+tfac :: Int -> Int -> Int+tfac x n = if n <= 1 then x+                     else tfac (n*x) (n-1)++{-@ range :: lo:Nat -> hi:Nat -> [Nat] / [hi-lo] @-}+range :: Int -> Int -> [Int]+range lo hi+  | lo < hi   = lo : range (lo + 1) hi+  | otherwise = []++{-@ data L [sz] a <p :: L a -> Prop>+      = N | C (x::a) (xs::L <p> a <<p>>)+  @-}+data L a = N | C a (L a)++{-@ measure sz  :: L a -> Int+    sz (C x xs) = 1 + (sz xs)+    sz (N)      = 0+  @-}+{-@ invariant {v:L a | (sz v) >= 0} @-}++{-@ map :: (a -> b) -> xs:L a -> (L b) / [(sz xs)] @-}+map :: (a -> b) -> L a -> L b+map f (C x xs) = f x `C` map f xs+map _ N        = N++{-@ merge :: xs:_ -> ys:_ -> _ / [(sz xs) + (sz ys)] @-}+merge :: Ord a => L a -> L a -> L a+merge (C x xs) (C y ys)+  | x < y     = x `C` merge xs (y `C` ys)+  | otherwise = y `C` merge (x `C` xs) ys++{-@ measure emp  :: L a -> Prop+    emp (N)      = true+    emp (C x xs) = false+  @-}++{-@ type Stream a = {xs: L <{\v -> not (emp v)}> a | not (emp xs)} @-}++{-@ Lazy repeat @-}+{-@ repeat :: a -> Stream a @-}+repeat :: a -> L a+repeat x = x `C` repeat x++{-@ take :: Nat -> Stream a -> L a @-}+take :: Int -> L a -> L a+take 0 _        = N+take n (C x xs) = x `C` take (n-1) xs+take _ N        = liquidError "never happens"++++++++++++++++
+ tests/pos/Infinity.hs view
@@ -0,0 +1,24 @@+module Infinity () where++import Language.Haskell.Liquid.Prelude+{-@ LIQUID "--totality" @-}+{-@ Lazy inf @-}++{-@ inf :: {v:[Int] | (((len v) > oo) && ((len v) > 2))} @-}+inf :: [Int]+inf = 1 : inf++bar = tail $ tail inf+++foo = inf !! n+  where n = myabs $ choose 0++myabs :: Int -> Int+{-@ myabs :: Int -> {v:Int | v >= 0} @-}+myabs = undefined++-- Encoding infinity.....++{-@ measure oo :: Int @-}+{-@ invariant {v:Int | (v < oo) }@-}
+ tests/pos/Invariants.hs view
@@ -0,0 +1,56 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}++module Foo () where++import Language.Haskell.Liquid.Prelude (liquidAssert)+import Data.IORef+++data Foo a b c d++{-@ data variance IO bivariant @-}++foo :: IO ()+foo = do a <- return 0 +         liquidAssert (a == 0) (return ())++foo' :: IO ()+foo' = bind (return 0) (\a -> liquidAssert (a == 0) (return ()))++{-@ data variance IORef bivariant @-}++{-@ data variance Foo invariant bivariant covariant contravariant @-}++{-@ job' :: IORef {v:Int |  v = 4} -> IO () @-}+job' :: IORef Int -> IO ()+job' p = +	bind (readIORef p) (\v -> liquidAssert (v == 4) (return ()))+++{-@ bind :: Monad m => m a -> (a -> m b) -> m b @-}+bind :: Monad m => m a -> (a -> m b) -> m b+bind = (>>=)+++++++++++++++++++++++
+ tests/pos/Keys.hs view
@@ -0,0 +1,19 @@+module Eval where++import qualified Data.Set as S++{-@ measure keys @-}+keys :: (Ord k) => [(k, v)] -> S.Set k+keys []       = S.empty+keys (kv:kvs) = (S.singleton (myfst kv)) `S.union` (keys kvs)++{-@ measure myfst @-}+myfst :: (a, b) -> a+myfst (x, _) = x++-- this is fine++{-@ measure okeys  :: [(a, b)] -> (S.Set a)+    okeys ([])     = (Set_empty 0)+    okeys (kv:kvs) = (Set_cup (Set_sng (fst kv)) (okeys kvs))+  @-}
+ tests/pos/LambdaEval.hs view
@@ -0,0 +1,154 @@+{-@ LIQUID "--no-termination" @-}++module LambdaEval () where++import Data.List        (lookup)++import Language.Haskell.Liquid.Prelude   ++---------------------------------------------------------------------+----------------------- Datatype Definition -------------------------+---------------------------------------------------------------------++type Bndr +  = Int++data Expr +  = Lam Bndr Expr+  | Var Bndr  +  | App Expr Expr+  | Const Int+  | Plus Expr Expr+  | Pair Expr Expr+  | Fst Expr+  | Snd Expr++{-@ +data Expr [elen]+  = Lam (x::Bndr) (e::Expr)+  | Var (x::Bndr)  +  | App (e1::Expr) (e2::Expr)+  | Const (i::Int)+  | Plus (e1::Expr) (e2::Expr)+  | Pair (e1::Expr) (e2::Expr)+  | Fst (e::Expr)+  | Snd (e::Expr)+@-}++{-@ measure elen :: (Expr) -> Int+    elen(Lam x e)    = 1 + (elen e)+    elen(Var x)      = 0+    elen(App e1 e2)  = 1 + (elen e1) + (elen e2)+    elen(Const i)    = 1+    elen(Plus e1 e2) = 1 + (elen e1) + (elen e2)+    elen(Pair e1 e2) = 1 + (elen e1) + (elen e2)+    elen(Fst e)      = 1 + (elen e)+    elen(Snd e)      = 1 + (elen e)+@-}++{-@ invariant {v:Expr | (elen v) >= 0} @-}++{-@+measure isValue      :: Expr -> Prop+isValue (Const i)    = true +isValue (Lam x e)    = true +isValue (Var x)      = false+isValue (App e1 e2)  = false+isValue (Plus e1 e2) = false +isValue (Fst e)      = false+isValue (Snd e)      = false+isValue (Pair e1 e2) = (isValue e1) && (isValue e2)+@-}++{-@ type Value = {v: Expr | isValue v } @-}++---------------------------------------------------------------------+-------------------------- The Evaluator ----------------------------+---------------------------------------------------------------------++{-@ Decrease evalVar 2 @-}+evalVar :: Bndr -> [(Bndr, Expr)] -> Expr+evalVar x ((y,v):sto) +  | x == y+  = v+  | otherwise+  = evalVar x sto++evalVar x []      +  = error "unbound variable"+++{-@ Decrease eval 2 @-}+{-@ eval :: [(Bndr, Value)] -> Expr -> ([(Bndr, Value)], Value) @-}+eval sto (Const i) +  = (sto, Const i)++eval sto (Var x)  +  = (sto, evalVar x sto) ++eval sto (Plus e1 e2)+  = let (_, e1') = eval sto e1+        (_, e2') = eval sto e2+    in case (e1, e2) of+         (Const i1, Const i2) -> (sto, Const (i1 + i2))+         _                    -> error "non-integer addition"++eval sto (App e1 e2)+  = let (_,    v2 ) = eval sto e2 +        (sto1, e1') = eval sto e1+    in case e1' of+         (Lam x e) -> eval ((x, v2): sto1) e+         _         -> error "non-function application"++eval sto (Lam x e) +  = (sto, Lam x e)++eval sto (Pair e1 e2)+  = (sto, Pair v1 v2)+  where (_, v1) = eval sto e1+        (_, v2) = eval sto e2++eval sto (Fst e)+  = let (sto', e') = eval sto e in+    case e' of+      Pair v _ -> (sto', v)+      _        -> error "non-tuple fst"++eval sto (Snd e)+  = let (sto', e') = eval sto e in+    case e' of+      Pair _ v -> (sto', v)+      _        -> error "non-tuple snd"++---------------------------------------------------------------------+-------------------------- Value Checker ----------------------------+---------------------------------------------------------------------++{-@ assert check :: {v: Expr | isValue v } -> Bool @-}+check (Const _)    = True+check (Lam _ _)    = True+check (Var _)      = liquidAssertB False+check (App _ _)    = liquidAssertB False+check (Pair v1 v2) = check v1 && check v2+check (Fst _)      = liquidAssertB False+check (Snd _)      = liquidAssertB False+check (Plus _ _)   = liquidAssertB False++---------------------------------------------------------------------+-------------------------- Unit Tests -------------------------------+---------------------------------------------------------------------++tests =+  let (f,g,x) = (0,1,2) +      e1      = Lam x (Var x)+      e2      = App e1 e1 +      e3      = Lam f (Lam g (Lam x (App (Var f)  (App (Var g) (Var x)))))+      e4      = Const 10+      e5      = App e1 e4+      e6      = Lam x (Plus (Var x) e4)+      e7      = App (App e3 e6) e6+      e8      = Pair (App e7 (Const 0)) (App e7 (Const 100))+      e9      = Fst e8+      e10     = Snd e9+      vs      = map (snd . eval []) [e1, e2, e3, e4, e5, e6, e7, e8, e9, e10]+  in map check vs
+ tests/pos/LambdaEvalMini.hs view
@@ -0,0 +1,90 @@+{-@ LIQUID "--no-termination" @-}++module LambdaEvalMini () where++import Language.Haskell.Liquid.Prelude        ++---------------------------------------------------------------------+----------------------- Datatype Definition -------------------------+---------------------------------------------------------------------++type Bndr +  = Int++data Expr +  = Lam Bndr Expr+  | Var Bndr  +  | App Expr Expr+{-@+data Expr [elen] +  = Lam (x::Bndr) (e::Expr)+  | Var (x::Bndr)  +  | App (e1::Expr) (e2::Expr)+@-}++{-@ measure elen :: Expr -> Int+    elen(Var x)     = 0+    elen(Lam x e)   = 1 + (elen e) +    elen(App e1 e2) = 1 + (elen e1) + (elen e2) +  @-}++{-@ invariant {v:Expr | (elen v) >= 0} @-}++{-@  measure isValue :: Expr -> Prop+     isValue (Lam x e)    = true +     isValue (Var x)      = false+     isValue (App e1 e2)  = false+  @-}++{-@ type Value = {v: Expr | isValue v } @-}++---------------------------------------------------------------------+-------------------------- The Evaluator ----------------------------+---------------------------------------------------------------------++evalVar x ((y, v):sto) +  | x == y+  = v+  | otherwise+  = evalVar x sto++evalVar x []      +  = error "unbound variable"++-- A "value" is simply: {v: Expr | isValue v } *)++{-@ Decrease eval 2 @-}+{-@ eval :: [(Bndr, Value)] -> Expr -> ([(Bndr, Value)], Value) @-}++eval sto (Var x)  +  = (sto, evalVar x sto)++eval sto (App e1 e2)+  = let (_,    v2 ) = eval sto e2 +        (sto1XXX, e1') = eval sto e1+    in case e1' of+         (Lam x e) -> eval ((x, v2): sto1XXX) e+         _         -> error "non-function application"++eval sto (Lam x e) +  = (sto, Lam x e)++-----------------------------------------------------------------------+---------------------------- Value Checker ----------------------------+-----------------------------------------------------------------------++check (Lam _ _)    = True+check (Var _)      = liquidAssertB False+check (App _ _)    = liquidAssertB False++-----------------------------------------------------------------------+---------------------------- Unit Tests -------------------------------+-----------------------------------------------------------------------+mysnd (x, y) = y+tests =+  let (f,g,x) = (0,1,2) +      e1      = Lam x (Var x)+      e2      = App e1 e1 +      e3      = Lam f (Lam g (Lam x (App (Var f)  (App (Var g) (Var x)))))+      vs      = map (mysnd . eval []) [e1, e2, e3]+  in map check vs
+ tests/pos/LambdaEvalSuperTiny.hs view
@@ -0,0 +1,65 @@+{-@ LIQUID "--no-termination" @-}++module LambdaEvalMini () where++---------------------------------------------------------------------+----------------------- Datatype Definition -------------------------+---------------------------------------------------------------------++data Pair a b = P a b+data LL a     = Nil | Cons a (LL a)++data Bndr ++data Expr +  = Lam Bndr Expr+  | Var Bndr  +  | App Expr Expr++{-@+data Expr [elen] +  = Lam (x::Bndr) (e::Expr)+  | Var (x::Bndr)  +  | App (e1::Expr) (e2::Expr)+@-}++{-@ measure elen :: Expr -> Int+    elen(Var x)     = 0+    elen(Lam x e)   = 1 + (elen e) +    elen(App e1 e2) = 1 + (elen e1) + (elen e2) +  @-}++{-@ invariant {v:Expr | (elen v) >= 0} @-}++{-@  measure isValue :: Expr -> Prop+     isValue (Lam x e)    = true +     isValue (Var x)      = false+     isValue (App e1 e2)  = false+  @-}++{-@ type Value = {v: Expr | (isValue v) } @-}+{-@ type Store = LL (Pair Bndr Value)       @-}++---------------------------------------------------------------------+-------------------------- The Evaluator ----------------------------+---------------------------------------------------------------------++{-@ evalVar :: Bndr -> Store -> Value @-}+evalVar :: Bndr -> LL (Pair Bndr Expr) -> Expr +evalVar = error "HIDEME"++{-@ eval :: Store -> e:Expr -> (Pair Store Value) @-}+{-@ Decrease eval 2 @-}+eval sto (Var x)  +  = P sto (evalVar x sto)++eval sto (App e1 e2)+  = let (P _    v2 ) = eval sto e2 +        (P sto1 e1') = eval sto e1+    in case e1' of+         (Lam x e) -> eval (Cons (P x v2) sto1) e+         _         -> error "non-function application"++eval sto (Lam x e) +  = P sto (Lam x e)+
+ tests/pos/LambdaEvalTiny.hs view
@@ -0,0 +1,64 @@+{-@ LIQUID "--no-termination" @-}++module LambdaEvalMini () where++---------------------------------------------------------------------+----------------------- Datatype Definition -------------------------+---------------------------------------------------------------------++data Bndr ++data Expr +  = Lam Bndr Expr+  | Var Bndr  +  | App Expr Expr++{-@+data Expr [elen] +  = Lam (x::Bndr) (e::Expr)+  | Var (x::Bndr)  +  | App (e1::Expr) (e2::Expr)+@-}++{-@ measure elen :: Expr -> Int+    elen(Var x)     = 0+    elen(Lam x e)   = 1 + (elen e) +    elen(App e1 e2) = 1 + (elen e1) + (elen e2) +  @-}++{-@ invariant {v:Expr | (elen v) >= 0} @-}++{-@  measure isValue :: Expr -> Prop+     isValue (Lam x e)    = true +     isValue (Var x)      = false+     isValue (App e1 e2)  = false+  @-}++{-@ type Value = {v: Expr | isValue v } @-}+{-@ type Store = [(Bndr, Value)]            @-}++---------------------------------------------------------------------+-------------------------- The Evaluator ----------------------------+---------------------------------------------------------------------++{-@ evalVar :: Bndr -> Store -> Value @-}+evalVar :: Bndr -> [(Bndr, Expr)] -> Expr +evalVar = error "HIDEME"++{-@ Decrease eval 2 @-}++{-@ eval :: sto:Store -> e:Expr -> (Store, Value) @-}++eval sto (Var x)  +  = (sto, evalVar x sto)++eval sto (App e1 e2)+  = let (_,    v2 ) = eval sto e2 +        (sto1, e1') = eval sto e1+    in case e1' of+         (Lam x e) -> eval ((x, v2) : sto1) e+         _         -> error "non-function application"++eval sto (Lam x e) +  = (sto, Lam x e)+
+ tests/pos/LazyWhere.hs view
@@ -0,0 +1,13 @@+module LazyWhere () where++import Language.Haskell.Liquid.Prelude++{-@ pos :: Nat -> Int @-}+pos :: Int -> Int+pos = undefined+++{-@ LAZYVAR z @-}+foo = if x > 0 then z else x+  where z = pos x+        x = choose 0
+ tests/pos/LazyWhere1.hs view
@@ -0,0 +1,20 @@+module LazyWhere () where++import Language.Haskell.Liquid.Prelude++{-@ pos :: Nat -> Int @-}+pos :: Int -> Int+pos = undefined++{-@ safeDiv :: Int -> {v:Int| v != 0} -> Int @-}+safeDiv :: Int -> Int -> Int+safeDiv = undefined++{-@ LAZYVAR z @-}+{-@ LAZYVAR z1 @-}+{-@ LAZYVAR z2 @-}+foo = if x > 0 then z else x+  where z  = z1 + z2+        z1 = 42 `safeDiv` x+        z2 = pos x+        x = choose 0
+ tests/pos/LiquidArray.hs view
@@ -0,0 +1,20 @@+module LiquidArray where++{-@ set :: forall a <p :: x0: Int -> x1: a -> Prop, r :: x0: Int -> Prop>.+      i: Int<r> ->+      x: a<p i> ->+      a: (j: {v: Int<r> | v != i} -> a<p j>) ->+      (k: Int<r> -> a<p k>) @-}+set :: Int -> a -> (Int -> a) -> (Int -> a)+set i x a = \k -> if k == i then x else a k++{-@ get :: forall a <p :: x0: Int -> x1: a -> Prop, r :: x0: Int -> Prop>.+             i: Int<r> ->+             a: (j: Int<r> -> a<p j>) ->+             a<p i> @-}+get :: Int -> (Int -> a) -> a+get i a = a i++{-@ empty :: i: {v: Int | 0 = 1} -> a @-}+empty :: Int -> a+empty = const (error "Empty array!")
+ tests/pos/LiquidClass.hs view
@@ -0,0 +1,39 @@+module LiquidClass where+++-- | Typing classes+-- | Step 1: Refine type dictionaries:++class Compare a where+	cmax :: a -> a -> a+	cmin :: a -> a -> a++instance Compare Int where	+{-@ instance Compare Int where +	cmax :: Odd -> Odd -> Odd ;+	cmin :: Int -> Int -> Int+  @-}++	cmax y x = if x >= y then x else y+  	cmin y x = if x >= y then x else y++-- | creates dictionary environment:+-- | * add the following environment+-- | dictionary $fCompareInt :: Compare Int+-- |               { $ccmax :: Odd -> Odd -> Odd+-- |               , $ccmin :: Int -> Int -> Int+-- |               }+-- |+-- | Important: do not type dictionaries, as preconditions+-- | of fields cannot be satisfied!!!!!+++-- | Dictionary application +-- | ((cmax Int)    @fcompareInt) :: Odd -> Odd -> Odd+-- | ((cmin Int)    @fcompareInt) :: Int -> Int -> Int+-- | (anything_else @fcompareInt) :: default+++{-@ foo :: Odd -> Odd -> Odd @-}+foo :: Int -> Int -> Int+foo x y = cmax x y
+ tests/pos/ListConcat.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--no-termination" @-}++module Foo () where+import Data.Set (Set(..)) +import Prelude hiding (concat)++{-@ measure llElts :: [[a]] -> (Set a) +    llElts([])   = {v | Set_emp v }+    llElts(x:xs) = {v | v = Set_cup (listElts x) (llElts xs) }+  @-}+++{-@ concat :: ys:[[a]] -> {v:[a] | listElts v = llElts ys } @-}+concat :: [[a]] ->  [a]+concat  []         = []+concat ([]: xs)    = concat xs+concat ((y:ys):xs) = y : concat (ys:xs)++++++
+ tests/pos/ListDataCons.hs view
@@ -0,0 +1,16 @@+module Fixme where++data L a = N +++{-@ lnil :: {v:L a | v == Fixme.N } @-} +lnil :: L a +lnil = N++{-@ hnil :: {v:[a] | v == []} @-} +hnil :: [a] +hnil = [] ++{-@ hcons :: x:a -> xs:[a] -> {v:[a] | v == x:xs} @-} +hcons :: a -> [a] -> [a] +hcons = (:)
+ tests/pos/ListElem.hs view
@@ -0,0 +1,15 @@+module ListElem () where++import Data.Set++{-@ listElem :: (Eq a) +             => y:a +             -> xs:[a]+             -> {v:Bool | (Prop(v) <=> Set_mem(y, (listElts(xs))))} +  @-}++listElem :: (Eq a) => a -> [a] -> Bool+listElem _ []     = False+listElem y (x:xs) | x == y    = True+                  | otherwise = listElem y xs+
+ tests/pos/ListISort-LType.hs view
@@ -0,0 +1,55 @@+module ListRange () where++import Language.Haskell.Liquid.Prelude++--------------------------------------------------------------------+-------------- Defining A List Type --------------------------------+--------------------------------------------------------------------++{-@ data List [llen] a <p :: x0:a -> x1:a -> Prop>  +  = Nil +  | Cons (h :: a) (t :: List <p> (a <p h>))+  @-}++{-@ measure llen :: (List a) -> Int+    llen(Nil)       = 0+    llen(Cons x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v:(List a) | ((llen v) >= 0)} @-}++data List a +  = Nil +  | Cons a (List a)++checkSort Nil                        +  = True+checkSort (_ `Cons` Nil)             +  = True+checkSort (x1 `Cons` (x2 `Cons` xs)) +  = liquidAssertB (x1 <= x2) && checkSort (x2 `Cons` xs)++xs0 :: List Int+xs0   = Nil+prop0 = checkSort xs0++xs1   = 4 `Cons` Nil+prop1 = checkSort xs1 ++xs2 = 2 `Cons` (4 `Cons` Nil) +prop2 = checkSort xs2 ++----------------------------------------------------------------+----------------- Insertion Sort -------------------------------+----------------------------------------------------------------++insert y Nil                  +  = y `Cons` Nil +insert y (Cons x xs) +  | y <= x    = y `Cons` (x `Cons` xs) +  | otherwise = x `Cons` (insert y xs)++insertSort = foldr insert Nil++bar3 = insertSort $ map choose [1 .. 10]+prop3 = checkSort bar3
+ tests/pos/ListISort.hs view
@@ -0,0 +1,18 @@+module ListSort () where++{-@ type OList a = [a]<{\fld v -> v >= fld}> @-}++{-@ insertSort    :: (Ord a) => xs:[a] -> {v : OList a | len(v) = len(xs)} @-}+insertSort        :: (Ord a) => [a] -> [a]+insertSort []     = []+insertSort (x:xs) = insert x (insertSort xs)++{-@ insertSort'    :: (Ord a) => xs:[a] -> OList a @-}+insertSort'        :: (Ord a) => [a] -> [a]+insertSort' xs      = foldr insert [] xs+++{-@ insert      :: (Ord a) => x:a -> xs: OList a -> {v: OList a | len(v) = (1 + len(xs)) } @-}+insert y []                   = [y]+insert y (x : xs) | y <= x    = y : x : xs+                  | otherwise = x : insert y xs
+ tests/pos/ListKeys.hs view
@@ -0,0 +1,20 @@+module Foo () where+import Data.Set (Set(..)) ++{-@  measure listKeys :: [(k, v)] -> (Set k) +    listKeys([])   = {v | Set_emp v }+    listKeys(x:xs) = {v | v = (Set_cup (Set_sng (fst x)) (listKeys xs)) }++@-}+++{-@ getFsts :: ys:[(a, b)] -> {v : [a] | listElts v = listKeys ys } @-}+getFsts ::[(a, b)] ->  [a]+getFsts []           = []+getFsts ((x, _): xs) = x : getFsts xs++++++
+ tests/pos/ListLen-LType.hs view
@@ -0,0 +1,54 @@+module ListLen () where++import Language.Haskell.Liquid.Prelude++{-@  +data List [llen] a <p :: x0:a -> x1:a -> Prop>  +  = Nil +  | Cons (h :: a) (t :: List <p> (a <p h>))+@-}++{-@ measure llen :: (List a) -> Int+    llen(Nil)       = 0+    llen(Cons x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v:(List a) | ((llen v) >= 0)} @-}++data List a = Nil | Cons a (List a)++make2d :: a -> Int -> Int -> List ([a])+make2d x n m = cloneL (clone x n) m++{-@ invariant {v:Int | v >= 0} @-}++clone :: a -> Int -> [a]+clone x n+  | n == 0+  = []+  | otherwise +  = x : (clone x (n-1))++cloneL :: a -> Int -> List a+cloneL x n+  | n == 0+  = Nil+  | otherwise +  = Cons x  (cloneL x (n-1))++-- check [] = [liquidAssertB True]+-- check (xs:xss) = let n = length xs in map (\xs' -> liquidAssertB (length xs' == n)) xss++chk Nil = liquidAssertB True+chk (Cons xs xss) =+  case xss of +   (Cons xs1 xss1) -> let n = length xs in liquidAssertB (length xs1 == n) && chk xss+   Nil -> liquidAssertB True++fooL  = Cons [1, 1, 3] (Cons [2, 2, 5] Nil)+fooL1 = make2d 0 n m+  where n = choose 0+        m = choose 1++propL = chk fooL1+prop  = chk fooL
+ tests/pos/ListLen.hs view
@@ -0,0 +1,70 @@+module ListClone () where++import Language.Haskell.Liquid.Prelude++make2d :: a -> Int -> Int -> [[a]]+make2d x n m = clone (clone x n) m++clone :: a -> Int -> [a]+clone x n+  | n == 0+  = []+  | otherwise +  = x : (clone x (n-1))++++-- check [] = [liquidAssertB True]+-- check (xs:xss) = let n = length xs in map (\xs' -> liquidAssertB (length xs' == n)) xss++chk [] = liquidAssertB True+chk (xs:xss) =+  case xss of +   (xs1:xss1) -> let n = length xs in liquidAssertB (length xs1 == n) && chk xss+   []         -> liquidAssertB True++fooL  = [[1, 1, 3], [2, 2, 5]]+fooL1 = let f = make2d n0 n1 n2 in f+    where n0 = 0+          n1 = 2+          n2 = 3+propL = chk fooL1+prop  = chk fooL++++++++++++++++++++++++++++++++++++++
+ tests/pos/ListMSort-LType.hs view
@@ -0,0 +1,60 @@+module ListRange () where+{-@ LIQUID "--no-termination" @-}++import Language.Haskell.Liquid.Prelude++{-@  +data List a <p :: x0:a -> x1:a -> Prop>  +  = Nil +  | Cons (h :: a) (t :: List <p> (a <p h>))+@-}+data List a = Nil | Cons a (List a)+++-- This is needed to conclude that +-- xs = Nil /\ xs = Cons _ _ <=> false++{-@ measure llen :: (List a) -> Int+    llen(Nil)       = 0+    llen(Cons x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v:List a | (llen v) >= 0} @-}++split :: List a -> (List a, List a)+split (Cons x (Cons y zs)) = (Cons x xs, Cons y ys) where (xs, ys) = split zs+split xs                   = (xs, Nil)+++{-@ Lazy merge @-}+merge :: Ord a => List a -> List a -> List a+merge xs Nil = xs+merge Nil ys = ys+merge (Cons x xs) (Cons y ys)+  | x <= y+  = Cons x (merge xs (Cons y ys))+  | otherwise +  = Cons y (merge (Cons x xs) ys)++mergesort :: Ord a => List a -> List a+mergesort Nil = Nil+mergesort (Cons x Nil) = Cons x Nil+mergesort xs = merge (mergesort xs1) (mergesort xs2) where (xs1, xs2) = split xs++chk y = +  case y of +   Nil -> True+   Cons x1 xs -> case xs of +                  Nil -> True+                  Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs2+																	+bar = mergesort $ mkList [1 .. 100]++barI :: List Int+barI = Cons 1 $ Cons 2 $ Cons 3 Nil++mkList :: Ord a => [a] -> List a+mkList = foldr Cons Nil++prop0 = chk bar+prop1 = chk barI
+ tests/pos/ListMSort.hs view
@@ -0,0 +1,37 @@+module ListSort () where++import Language.Haskell.Liquid.Prelude++{-@ type OList a = [a]<{\fld v -> (v >= fld)}>  @-}++{-@ predicate Pr X Y = (((len Y) > 1) => ((len Y) < (len X))) @-}++{-@ split :: xs:[a] +          -> ({v:[a] | (Pr xs v)}, {v:[a]|(Pr xs v)})+                 <{\x y -> ((len x) + (len y) = (len xs))}> +  @-}++split :: [a] -> ([a], [a])+split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs+split xs                   = (xs, [])+++{-@ Decrease merge 4 @-}+{-@ merge :: Ord a => xs:(OList a) -> ys:(OList a) -> d:{v:Int| v = (len xs) + (len ys)} -> {v:(OList a) | (len v) = d} @-}+merge :: Ord a => [a] -> [a] -> Int -> [a]+merge xs [] _ = xs+merge [] ys _ = ys+merge (x:xs) (y:ys) d+  | x <= y+  = x:(merge xs (y:ys) (d-1))+  | otherwise +  = y:(merge (x:xs) ys (d-1))++{-@ mergesort :: (Ord a) => xs:[a] -> {v:(OList a) | (len v) = (len xs)}  @-}+mergesort :: Ord a => [a] -> [a]+mergesort []  = []+mergesort [x] = [x]+mergesort xs  = merge (mergesort xs1) (mergesort xs2) d +  where (xs1, xs2) = split xs+        d          = length xs+
+ tests/pos/ListQSort-LType.hs view
@@ -0,0 +1,53 @@+module ListRange () where++import Language.Haskell.Liquid.Prelude++{-@  +data List [llen] a <p :: x0:a -> x1:a -> Prop>  +  = Nil +  | Cons (h :: a) (t :: List <p> (a <p h>))+@-}++{-@ measure llen :: (List a) -> Int+    llen(Nil)       = 0+    llen(Cons x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v:List a | (llen v) >= 0} @-}++{-@ qualif ZLLen(v:List a) : (llen(v) >= 0)@-}+{-@ qualif CmpLLen(v:List a, A:List b) : ((llen v) <= (llen A))@-}++data List a = Nil | Cons a (List a)++append k Nil         ys = Cons k ys+append k (Cons x xs) ys = Cons x (append k xs ys) ++takeL x Nil         = Nil+takeL x (Cons y ys) = if (y<x) then Cons y (takeL x ys) else takeL x ys++{-@ takeGE :: Ord a +           => x:a +           -> xs:List a +           -> {v: (List {v:a | v >= x}) | ((llen v) <= (llen xs))}  @-}+takeGE x Nil         = Nil+takeGE x (Cons y ys) = if (y>=x) then Cons y (takeGE x ys) else takeGE x ys++quicksort Nil = Nil+quicksort (Cons x xs) = append x xsle xsge+  where xsle = quicksort (takeL x xs)+        xsge = quicksort (takeGE x xs)++chk y = +  case y of +   Nil -> True+   Cons x1 xs -> case xs of +                 Nil -> True+                 Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs+																	+bar = quicksort $ mkList [1 .. 100]++mkList :: Ord a => [a] -> List a+mkList = foldr Cons Nil++prop0 = chk bar
+ tests/pos/ListQSort.hs view
@@ -0,0 +1,39 @@+module ListSort () where++import Language.Haskell.Liquid.Prelude++app k []     ys = k:ys+app k (x:xs) ys = x:(app k xs ys) ++takeL x []     = []+takeL x (y:ys) = if (y<x) then y:(takeL x ys) else takeL x ys++takeGE x []     = []+takeGE x (y:ys) = if (y>=x) then y:(takeGE x ys) else takeGE x ys+++{-@ quicksort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}+quicksort []     = []+quicksort (x:xs) = app x xsle xsge+  where xsle = quicksort (takeL x xs)+        xsge = quicksort (takeGE x xs)++{-@ qsort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}+qsort []     = []+qsort (x:xs) = app x (qsort [y | y <- xs, y < x]) (qsort [z | z <- xs, z >= x]) ++-------------------------------------------------------------------------------++chk [] = liquidAssertB True+chk (x1:xs) = case xs of +               []     -> liquidAssertB True+               x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs+																	+prop0 = chk bar+  where +    rlist = map choose [1 .. 10]+    bar = quicksort rlist++++
+ tests/pos/ListRange-LType.hs view
@@ -0,0 +1,38 @@+module ListRange () where++import Language.Haskell.Liquid.Prelude++{-@ LIQUID "--no-termination" @-}++{-@  +data List [llen] a <p :: x0:a -> x1:a -> Prop>  +  = Nil +  | Cons (h :: a) (t :: List <p> (a <p h>))+@-}++{-@ measure llen :: (List a) -> Int+    llen(Nil)       = 0+    llen(Cons x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v:(List a) | ((llen v) >= 0)} @-}++data List a = Nil | Cons a (List a)++{-+low, high :: Int+low  = 0+high = 10+-}++range l h = +  if l <= h then Cons l (range (l+1) h) else Nil++chk y = +  case y of +   Nil -> True+   Cons x1 xs -> case xs of +                 Nil -> True+                 Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs2++prop3 = chk $ range 1 100
+ tests/pos/ListRange.hs view
@@ -0,0 +1,19 @@+module ListSort () where++{-@ LIQUID "--no-termination" @-}++import Language.Haskell.Liquid.Prelude++low, high :: Int+low  = choose 0+high = choose 10++range l h = +  if l <= h then l:(range (l+1) h) else []++chk [] = liquidAssertB True+chk (x1:xs) = case xs of +              []       -> liquidAssertB True+              (x2:xs2) -> liquidAssertB (x1 <= x2) && chk xs++prop = chk $ range low high
+ tests/pos/ListReverse-LType.hs view
@@ -0,0 +1,18 @@+module Reverse (x) where++import Language.Haskell.Liquid.Prelude        +import Prelude hiding (reverse)+data L a = N | C a (L a)++{-@ data L [llen] @-}++{-@ measure llen :: (L a) -> Int+    llen(N)      = 0+    llen(C x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v: L a | (llen v) >= 0} @-}+reverse N xs = xs+reverse (C y ys) xs = reverse ys (C y xs)++x = reverse (C 1 (C 2 N))
+ tests/pos/ListSort.hs view
@@ -0,0 +1,70 @@+module ListSort (insertSort, insertSort', mergeSort, quickSort) where+++{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}++------------------------------------------------------------------------------+-- Insert Sort ---------------------------------------------------------------+------------------------------------------------------------------------------++{-@ insertSort :: (Ord a) => xs:[a] -> OList a @-}+insertSort            :: (Ord a) => [a] -> [a]+insertSort []         = []+insertSort (x:xs)     = insert x (insertSort xs) ++{-@ insertSort' :: (Ord a) => xs:[a] -> OList a @-}+insertSort' xs        = foldr insert [] xs++insert y []                   = [y]+insert y (x : xs) | y <= x    = y : x : xs +                  | otherwise = x : insert y xs++------------------------------------------------------------------------------+-- Merge Sort ----------------------------------------------------------------+------------------------------------------------------------------------------++{-@ mergeSort :: (Ord a) => xs:[a] -> {v:OList a| (len v) = (len xs)} @-}+mergeSort :: Ord a => [a] -> [a]+mergeSort []  = []+mergeSort [x] = [x]+mergeSort xs  = merge (mergeSort xs1) (mergeSort xs2) d +  where (xs1, xs2) = split xs+        d          = length xs++{-@ predicate Pr X Y = (((len Y) > 1) => ((len Y) < (len X))) @-}++{-@ split :: xs:[a] +          -> ({v:[a] | (Pr xs v)}, {v:[a]|(Pr xs v)})+                 <{\x y -> ((len x) + (len y) = (len xs))}> +  @-}++split :: [a] -> ([a], [a])+split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs+split xs         = (xs, [])++{-@ Decrease merge 4 @-}+{-@ merge :: Ord a => xs:(OList a) -> ys:(OList a) -> d:{v:Int| v = (len xs) + (len ys)} -> {v:(OList a) | (len v) = d} @-}+merge :: Ord a => [a] -> [a] -> Int -> [a]+merge xs [] _ = xs+merge [] ys _ = ys+merge (x:xs) (y:ys) d+  | x <= y+  = x: merge xs (y:ys) (d-1)+  | otherwise +  = y : merge (x:xs) ys (d-1)++------------------------------------------------------------------------------+-- Quick Sort ----------------------------------------------------------------+------------------------------------------------------------------------------++{-@ quickSort :: (Ord a) => [a] -> OList a @-}+quickSort []     = []+quickSort (x:xs) = append x lts gts +  where +    lts          = quickSort [y | y <- xs, y < x]+    gts          = quickSort [z | z <- xs, z >= x]++append k []     ys  = k : ys+append k (x:xs) ys  = x : append k xs ys++
+ tests/pos/LocalHole.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--no-termination" @-}+module LocalHole where++{-@ assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}++mysum xs = go 0 0+  where+    n = length xs+    {-@ go :: i:{Nat | i <= n} -> _ -> _ @-}+    go i acc+      | i >= n    = acc+      | otherwise = go (i+1) (acc + xs !! i)
+ tests/pos/LocalLazy.hs view
@@ -0,0 +1,12 @@+module LocalLazy (bar) where++import Language.Haskell.Liquid.Prelude++{-@ Lazy foo @-}+foo x = foo x+++bar = liquidAssertB (inf n > 0)+  where n     = choose 0+       {-@ Lazy inf @-}+        inf n = inf n
+ tests/pos/LocalSpec.hs view
@@ -0,0 +1,14 @@+module LocalSpec () where++import Language.Haskell.Liquid.Prelude (choose)+++prop = if x > 0 then bar x else x+  where x = choose 0+    {-@ bar :: Nat -> Nat @-}+        bar :: Int -> Int+        bar x = x++{-@ bar :: a -> {v:Int | v = 9} @-}+bar :: a -> Int+bar _ = 9
+ tests/pos/LocalSpec0.hs view
@@ -0,0 +1,10 @@+module LocalSpec0 (foo) where+++{-@ foo :: x:Int -> {v:Int | v > x } @-}+foo :: Int -> Int+foo x =  go x++{-@ go :: n:Int -> {v:Int | v = n + 1} @-}+go :: Int -> Int+go x = x + 1
+ tests/pos/LocalSpecImp.hs view
@@ -0,0 +1,7 @@+module LocalSpecImp where++import LocalSpec0++{-@ bar :: {x:Int | x > 99} -> {v:Int | v > 100 } @-}+bar :: Int -> Int+bar x = foo x
+ tests/pos/LocalTermExpr.hs view
@@ -0,0 +1,20 @@+module LocalTermExpr where++{-@ assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}++mysum xs = go 0 0+  where+    i = 0+    n = length xs+    {-@ go :: i:_ -> _ -> _ / [n - i] @-}+    go i acc+      | i >= n    = acc+      | otherwise = go (i+1) (acc + xs !! i)++myfoo = foo 5 True+  where+    n = False+    {-@ foo :: n:_ -> b:{_ | n >= 0 && Prop b} -> {v:_ | n >= 0 && (Prop b)} / [n-0] @-}+    foo :: Int -> Bool -> Bool+    foo 0 _ = True+    foo n b = foo (n-1) b
+ tests/pos/Loo.hs view
@@ -0,0 +1,12 @@+module Loo where++import qualified Goo as G++plusThree = G.plusOne . G.plusTwo+plusFour  = G.plusTwo . G.plusTwo++{-@ assert pp :: z:Int -> {v:Int| v > z} @-}+pp x      = G.plusOne (G.plusOne x)+++($$$) x  = x + 1
+ tests/pos/Map.hs view
@@ -0,0 +1,169 @@+module Map () where++import Language.Haskell.Liquid.Prelude++{-@ +  data Map [mlen] k a <l :: root:k -> k -> Prop, r :: root:k -> k -> Prop>+      = Tip +      | Bin (sz    :: Size) +            (key   :: k) +            (value :: a) +            (left  :: Map <l, r> (k <l key>) a) +            (right :: Map <l, r> (k <r key>) a) +  @-}++{-@ measure mlen :: (Map k a) -> Int +    mlen(Tip) = 0+    mlen(Bin s k v l r) = 1 + (mlen l) + (mlen r)+  @-}++{-@ invariant {v:Map k a | (mlen v) >= 0}@-}++{-@ type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}++data Map k a = Tip+             | Bin Size k a (Map k a) (Map k a)++type Size    = Int++{-@ singleton :: k -> a -> OMap k a @-}+singleton :: k -> a -> Map k a+singleton k x+  = Bin 1 k x Tip Tip++{-@ insert :: Ord k => k -> a -> OMap k a -> OMap k a @-}+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx x t+  = case t of +     Tip -> singleton kx x+     Bin sz ky y l r+         -> case compare kx ky of+              LT -> balance ky y (insert kx x l) r+              GT -> balance ky y l (insert kx x r)+              EQ -> Bin sz kx x l r++{-@ delete :: (Ord k) => k:k -> OMap k a -> OMap {v:k| (v /= k)} a @-}+delete :: Ord k => k -> Map k a -> Map k a+delete k t +  = case t of +      Tip -> Tip+      Bin _ kx x l r+          -> case compare k kx of +               LT -> balance kx x (delete k l) r+               GT -> balance kx x l (delete k r)+               EQ -> glue kx l r +++glue :: k -> Map k a -> Map k a -> Map k a+glue k Tip r = r+glue k l Tip = l+glue k l r+  | size l > size r = let (km1, vm, lm) = deleteFindMax l in balance km1 vm lm r+  | otherwise       = let (km2, vm, rm) = deleteFindMin r in balance km2 vm l rm++deleteFindMax t +  = case t of+      Bin _ k x l Tip -> (k, x, l)+      Bin _ k x l r -> let (km3, vm, rm) = deleteFindMax r in (km3, vm, (balance k x l rm))+      Tip           -> (error ms, error ms, Tip)+  where ms = "Map.deleteFindMax : can not return the maximal element of an empty Map"   +++deleteFindMin t +  = case t of+      Bin _ k x Tip r -> (k, x, r)+      Bin _ k x l r -> let (km4, vm, lm) = deleteFindMin l in (km4, vm, (balance k x lm r))+      Tip             -> (error ms, error ms, Tip)+  where ms = "Map.deleteFindMin : can not return the maximal element of an empty Map"   +++-------------------------------------------------------------------------------+--------------------------------- BALANCE -------------------------------------+-------------------------------------------------------------------------------++delta, ratio :: Int+delta = 5+ratio = 2++balance :: k -> a -> Map k a -> Map k a -> Map k a +balance k x l r +  | sizeL + sizeR <= 1   = Bin sizeX k x l r+  | sizeR >= delta*sizeL = rotateL k x l r+  | sizeL >= delta*sizeR = rotateR k x l r+  | otherwise            = Bin sizeX k x l r+  where sizeL = size l+        sizeR = size r+        sizeX = sizeL + sizeR + 1++-- rotate+rotateL :: a -> b -> Map a b -> Map a b -> Map a b+rotateL k x l r@(Bin _ _ _ ly ry) +  | size ly < ratio*size ry  = singleL k x l r+  | otherwise                = doubleL k x l r+rotateL _ _ _ Tip = error "rotateL Tip"++rotateR :: a -> b -> Map a b -> Map a b -> Map a b+rotateR k x l@(Bin _ _ _ ly ry) r+  | size ry < ratio*size ly  = singleR k x l r+  | otherwise                = doubleR k x l r+rotateR _ _ Tip _ = error "rotateR Tip"++-- basic rotations+singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3+singleL _  _  _ Tip                  = error "sinlgeL Tip"+singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = Bin 0 k2 x2 t1 (Bin 0 k1 x1 t2 t3)+singleR _  _  Tip _                  = error "sinlgeR Tip"++doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4)+ =bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+doubleL _ _ _ _ = error "doubleL" +doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 +  = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+doubleR _ _ _ _ = error "doubleR" ++bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r +  = Bin (size l + size r + 1) k x l r++size :: Map k a -> Int+size t +  = case t of +      Tip            -> 0+      Bin sz _ _ _ _ -> sz+++-- chkDel x Tip                = liquidAssertB True  +-- chkDel x (Bin sz k v lt rt) = liquidAssertB (not (x == k)) && chkDel x lt && chkDel x rt++-- chkMin x Tip                = liquidAssertB True  +-- chkMin x (Bin sz k v lt rt) = liquidAssertB (x<k) && chkMin x lt && chkMin x rt++chk Tip               = liquidAssertB True  +chk (Bin s k v lt rt) = chk lt && chk rt && chkl k lt && chkr k rt+		+chkl k Tip              = liquidAssertB True+chkl k (Bin _ kl _ _ _) = liquidAssertB (kl < k)++chkr k Tip              = liquidAssertB True+chkr k (Bin _ kr _ _ _) = liquidAssertB (k < kr)++key, key1, val, val1 :: Int+key = choose 0+val = choose 1+key1 = choose 0+val1 = choose 1++bst1 = insert key val Tip+bst  = insert key val $ insert key1 val1 Tip++mkBst = foldl (\t (k, v) -> insert k v t) Tip++prop        = chk bst1+prop1       = chk $ mkBst $ zip [1..] [1..]++propDelete  = chk bst' -- && chkDel x bst' +   where +     x      = choose 0+     bst'   = delete x bst
+ tests/pos/Map0.hs view
@@ -0,0 +1,168 @@+module Map () where++import Language.Haskell.Liquid.Prelude++{-@ +  data Map [mlen] k a <l :: root:k -> x1:k -> Prop, r :: root:k -> x1:k -> Prop>+      = Tip +      | Bin (sz    :: Size) +            (key   :: k) +            (value :: a) +            (left  :: Map <l, r> (k <l key>) a) +            (right :: Map <l, r> (k <r key>) a) +  @-}++{-@ type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}++{-@ measure mlen :: (Map k a) -> Int +    mlen(Tip) = 0+    mlen(Bin s k v l r) = 1 + (mlen l) + (mlen r)+  @-}++{-@ invariant {v:Map k a | (mlen v) >= 0}@-}++data Map k a = Tip+             | Bin Size k a (Map k a) (Map k a)++type Size    = Int++{-@ singleton :: k -> a -> OMap k a @-}+singleton :: k -> a -> Map k a+singleton k x+  = Bin 1 k x Tip Tip+++{-@ insert :: Ord k => k -> a -> OMap k a -> OMap k a @-}+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx x t+  = case t of +     Tip -> singleton kx x+     Bin sz ky y l r+         -> case compare kx ky of+              LT -> balance ky y (insert kx x l) r+              GT -> balance ky y l (insert kx x r)+              EQ -> Bin sz kx x l r++{-@ delete :: (Ord k) => k:k -> OMap k a -> OMap {v:k | (v /= k)} a @-}+delete :: Ord k => k -> Map k a -> Map k a+delete k t +  = case t of +      Tip -> Tip+      Bin _ kx x l r+          -> case compare k kx of +               LT -> balance kx x (delete k l) r+               GT -> balance kx x l (delete k r)+               EQ -> glue kx l r +++glue :: k -> Map k a -> Map k a -> Map k a+glue k Tip r = r+glue k l Tip = l+glue k l r+  | size l > size r = let (km1, vm, lm) = deleteFindMax l in balance km1 vm lm r+  | otherwise       = let (km2, vm, rm) = deleteFindMin r in balance km2 vm l rm++deleteFindMax t +  = case t of+      Bin _ k x l Tip -> (k, x, l)+      Bin _ k x l r -> let (km3, vm, rm) = deleteFindMax r in (km3, vm, (balance k x l rm))+      Tip           -> (error ms, error ms, Tip)+  where ms = "Map.deleteFindMax : can not return the maximal element of an empty Map"   +++deleteFindMin t +  = case t of+      Bin _ k x Tip r -> (k, x, r)+      Bin _ k x l r -> let (km4, vm, lm) = deleteFindMin l in (km4, vm, (balance k x lm r))+      Tip             -> (error ms, error ms, Tip)+  where ms = "Map.deleteFindMin : can not return the maximal element of an empty Map"   +++-------------------------------------------------------------------------------+--------------------------------- BALANCE -------------------------------------+-------------------------------------------------------------------------------++delta, ratio :: Int+delta = 5+ratio = 2++balance :: k -> a -> Map k a -> Map k a -> Map k a +balance k x l r +  | sizeL + sizeR <= 1   = Bin sizeX k x l r+  | sizeR >= delta*sizeL = rotateL k x l r+  | sizeL >= delta*sizeR = rotateR k x l r+  | otherwise            = Bin sizeX k x l r+  where sizeL = size l+        sizeR = size r+        sizeX = sizeL + sizeR + 1++-- rotate+rotateL :: a -> b -> Map a b -> Map a b -> Map a b+rotateL k x l r@(Bin _ _ _ ly ry) +  | size ly < ratio*size ry  = singleL k x l r+  | otherwise                = doubleL k x l r+rotateL _ _ _ Tip = error "rotateL Tip"++rotateR :: a -> b -> Map a b -> Map a b -> Map a b+rotateR k x l@(Bin _ _ _ ly ry) r+  | size ry < ratio*size ly  = singleR k x l r+  | otherwise                = doubleR k x l r+rotateR _ _ Tip _ = error "rotateR Tip"++-- basic rotations+singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3+singleL _  _  _ Tip                  = error "sinlgeL Tip"+singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = Bin 0 k2 x2 t1 (Bin 0 k1 x1 t2 t3)+singleR _  _  Tip _                  = error "sinlgeR Tip"++doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4)+ =bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+doubleL _ _ _ _ = error "doubleL" +doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 +  = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+doubleR _ _ _ _ = error "doubleR" ++bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r +  = Bin (size l + size r + 1) k x l r++size :: Map k a -> Int+size t +  = case t of +      Tip            -> 0+      Bin sz _ _ _ _ -> sz+++-- chkDel x Tip                = liquidAssertB True  +-- chkDel x (Bin sz k v lt rt) = liquidAssertB (not (x == k)) && chkDel x lt && chkDel x rt+-- +-- chkMin x Tip                = liquidAssertB True  +-- chkMin x (Bin sz k v lt rt) = liquidAssertB (x<k) && chkMin x lt && chkMin x rt++chk Tip               = liquidAssertB True  +chk (Bin s k v lt rt) = chk lt && chk rt && chkl k lt && chkr k rt+		+chkl k Tip              = liquidAssertB True+chkl k (Bin _ kl _ _ _) = liquidAssertB (kl < k)++chkr k Tip              = liquidAssertB True+chkr k (Bin _ kr _ _ _) = liquidAssertB (k < kr)++key, key1, val, val1 :: Int+key = choose 0+val = choose 1+key1 = choose 0+val1 = choose 1++bst1 = insert key val Tip+bst  = insert key val $ insert key1 val1 Tip++mkBst = foldl (\t (k, v) -> insert k v t) Tip++prop        = chk bst1+prop1       = chk $ mkBst $ zip [1..] [1..]++propDelete  = chk $ delete x bst+   where x = choose 0
+ tests/pos/Map2.hs view
@@ -0,0 +1,169 @@+module Map () where++import Language.Haskell.Liquid.Prelude++{-@ +  data Map [mlen] k a <l :: root:k -> k -> Prop, r :: root:k -> k -> Prop>+      = Tip +      | Bin (sz    :: Size) +            (key   :: k) +            (value :: a) +            (left  :: Map <l, r> (k <l key>) a) +            (right :: Map <l, r> (k <r key>) a) +  @-}++{-@ measure mlen :: (Map k a) -> Int +    mlen(Tip) = 0+    mlen(Bin s k v l r) = 1 + (if ((mlen l) < (mlen r)) then (mlen r) else (mlen l))+  @-}++{-@ invariant {v:Map k a | (mlen v) >= 0}@-}++{-@ type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}++data Map k a = Tip+             | Bin Size k a (Map k a) (Map k a)++type Size    = Int++{-@ singleton :: k -> a -> OMap k a @-}+singleton :: k -> a -> Map k a+singleton k x+  = Bin 1 k x Tip Tip++{-@ insert :: Ord k => k -> a -> OMap k a -> OMap k a @-}+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx x t+  = case t of +     Tip -> singleton kx x+     Bin sz ky y l r+         -> case compare kx ky of+              LT -> balance ky y (insert kx x l) r+              GT -> balance ky y l (insert kx x r)+              EQ -> Bin sz kx x l r++{-@ delete :: (Ord k) => k:k -> OMap k a -> OMap {v:k| (v /= k)} a @-}+delete :: Ord k => k -> Map k a -> Map k a+delete k t +  = case t of +      Tip -> Tip+      Bin _ kx x l r+          -> case compare k kx of +               LT -> balance kx x (delete k l) r+               GT -> balance kx x l (delete k r)+               EQ -> glue kx l r +++glue :: k -> Map k a -> Map k a -> Map k a+glue k Tip r = r+glue k l Tip = l+glue k l r+  | size l > size r = let (km1, vm, lm) = deleteFindMax l in balance km1 vm lm r+  | otherwise       = let (km2, vm, rm) = deleteFindMin r in balance km2 vm l rm++deleteFindMax t +  = case t of+      Bin _ k x l Tip -> (k, x, l)+      Bin _ k x l r -> let (km3, vm, rm) = deleteFindMax r in (km3, vm, (balance k x l rm))+      Tip           -> (error ms, error ms, Tip)+  where ms = "Map.deleteFindMax : can not return the maximal element of an empty Map"   +++deleteFindMin t +  = case t of+      Bin _ k x Tip r -> (k, x, r)+      Bin _ k x l r -> let (km4, vm, lm) = deleteFindMin l in (km4, vm, (balance k x lm r))+      Tip             -> (error ms, error ms, Tip)+  where ms = "Map.deleteFindMin : can not return the maximal element of an empty Map"   +++-------------------------------------------------------------------------------+--------------------------------- BALANCE -------------------------------------+-------------------------------------------------------------------------------++delta, ratio :: Int+delta = 5+ratio = 2++balance :: k -> a -> Map k a -> Map k a -> Map k a +balance k x l r +  | sizeL + sizeR <= 1   = Bin sizeX k x l r+  | sizeR >= delta*sizeL = rotateL k x l r+  | sizeL >= delta*sizeR = rotateR k x l r+  | otherwise            = Bin sizeX k x l r+  where sizeL = size l+        sizeR = size r+        sizeX = sizeL + sizeR + 1++-- rotate+rotateL :: a -> b -> Map a b -> Map a b -> Map a b+rotateL k x l r@(Bin _ _ _ ly ry) +  | size ly < ratio*size ry  = singleL k x l r+  | otherwise                = doubleL k x l r+rotateL _ _ _ Tip = error "rotateL Tip"++rotateR :: a -> b -> Map a b -> Map a b -> Map a b+rotateR k x l@(Bin _ _ _ ly ry) r+  | size ry < ratio*size ly  = singleR k x l r+  | otherwise                = doubleR k x l r+rotateR _ _ Tip _ = error "rotateR Tip"++-- basic rotations+singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3+singleL _  _  _ Tip                  = error "sinlgeL Tip"+singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = Bin 0 k2 x2 t1 (Bin 0 k1 x1 t2 t3)+singleR _  _  Tip _                  = error "sinlgeR Tip"++doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4)+ =bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+doubleL _ _ _ _ = error "doubleL" +doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 +  = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+doubleR _ _ _ _ = error "doubleR" ++bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r +  = Bin (size l + size r + 1) k x l r++size :: Map k a -> Int+size t +  = case t of +      Tip            -> 0+      Bin sz _ _ _ _ -> sz+++-- chkDel x Tip                = liquidAssertB True  +-- chkDel x (Bin sz k v lt rt) = liquidAssertB (not (x == k)) && chkDel x lt && chkDel x rt++-- chkMin x Tip                = liquidAssertB True  +-- chkMin x (Bin sz k v lt rt) = liquidAssertB (x<k) && chkMin x lt && chkMin x rt++chk Tip               = liquidAssertB True  +chk (Bin s k v lt rt) = chk lt && chk rt && chkl k lt && chkr k rt+		+chkl k Tip              = liquidAssertB True+chkl k (Bin _ kl _ _ _) = liquidAssertB (kl < k)++chkr k Tip              = liquidAssertB True+chkr k (Bin _ kr _ _ _) = liquidAssertB (k < kr)++key, key1, val, val1 :: Int+key = choose 0+val = choose 1+key1 = choose 0+val1 = choose 1++bst1 = insert key val Tip+bst  = insert key val $ insert key1 val1 Tip++mkBst = foldl (\t (k, v) -> insert k v t) Tip++prop        = chk bst1+prop1       = chk $ mkBst $ zip [1..] [1..]++propDelete  = chk bst' -- && chkDel x bst' +   where +     x      = choose 0+     bst'   = delete x bst
+ tests/pos/MeasureContains.hs view
@@ -0,0 +1,27 @@+module Fixme where++import Language.Haskell.Liquid.Prelude++{-@ LIQUID "--no-termination" @-}++{-@ measure containsV @-}+{-@ measure binderContainsV @-}+++binderContainsV ::  Binder n -> Bool+binderContainsV B     = True+binderContainsV (M x) = containsV x++data Binder n = B | M (TT n)+data TT n     = V Int | Other | Bind (Binder n) (TT n)++containsV :: TT n -> Bool+containsV (V i)           = True+containsV (Bind b body) = (binderContainsV b) || (containsV body)+-- containsV (App f arg)     = (containsV f) || (containsV arg)+-- containsV (Proj tm i)     = containsV tm+containsV _               = False+++prop1 = liquidAssert (containsV $ V 7)+prop2 = liquidAssert (containsV $ Bind (M (V 5)) Other)
+ tests/pos/MeasureDups.hs view
@@ -0,0 +1,27 @@+module Measures where++import Data.Set ++{-@ LIQUID "--no-termination" @-}+{-@ measure elements @-}+{-@ measure dups @-}++data F a = F a |  C a (F a) | E ++dups :: Ord a => F a -> Set a+dups E        = empty+dups (F a)    = empty+dups (C x xs) = if member x (elements xs) then singleton x `union` dups xs else dups xs++elements :: Ord a => F a -> Set a+elements E        = empty+elements (F a)    = singleton a+elements (C x xs) = singleton x `union` elements xs++++{-@ foo :: (Ord a) => x:F a -> {v:Set a | (dups x) = v} @-}+foo :: Ord a => F a -> Set a+foo E        = empty+foo (F a)    = empty+foo (C x xs) = if member x (elements xs) then singleton x `union` foo xs else foo xs
+ tests/pos/MeasureSets.hs view
@@ -0,0 +1,19 @@+module Measures where++import Data.Set ++{-@ measure foo @-}+{-@ measure foo1 @-}++data F a = F a | E++foo1 :: F a -> Set a+foo1 (F x) = singleton x+foo1 E     = empty+++foo :: F Int -> Int+foo (F x) = x + 1+foo E     = 0++-- bar = F
+ tests/pos/Measures.hs view
@@ -0,0 +1,15 @@+module Measures where++{-@ data Wrapper a <p :: a -> Prop, r :: a -> a -> Prop > +    = Wrap (rgref_ref :: a<p>) @-}+data Wrapper a = Wrap (a)++-- Two measures+{-@ measure fwdextends :: Int -> Int -> Prop @-}+{-@ measure actionP :: Int -> Prop @-}++{-@ data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (true)},{\x y -> (fwdextends y x)}> Int )) @-}+{- data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (actionP x)},{\x y -> (true)}> Int )) @-}+data Wrapper2  = Wrapper2 (Wrapper (Int) )++
+ tests/pos/Measures1.hs view
@@ -0,0 +1,15 @@+module Measures where++{-@ data Wrapper a <p :: a -> Prop, r :: a -> a -> Prop > +    = Wrap (rgref_ref :: a<p>) @-}+data Wrapper a = Wrap (a)++-- Two measures+{-@ measure fwdextends :: Int -> Int -> Prop @-}+{-@ measure actionP :: Int -> Prop @-}++{- data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (true)},{\x y -> (fwdextends y x)}> Int )) @-}+{-@ data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (actionP x)},{\x y -> (true)}> Int )) @-}+data Wrapper2  = Wrapper2 (Wrapper (Int) )++
+ tests/pos/Mod1.hs view
@@ -0,0 +1,12 @@+module Mod1 where++data Goo = G Int++{-@ measure myg :: Mod1.Goo -> Int +    myg (Mod1.G n) = n+  @-}+ +{-@ inc :: x:Goo -> {v: Goo | (myg v) > (myg x)} @-}+inc (G x) = G (x + 1)++
+ tests/pos/Mod2.hs view
@@ -0,0 +1,7 @@+module Mod2 where++import qualified Mod1 as M++{-@ inc :: x:M.Goo -> {v: M.Goo | (myg v) > (myg x)} @-}+inc (M.G x) = M.G (x + 1)+
+ tests/pos/Moo.hs view
@@ -0,0 +1,5 @@+module Moo (plusOne) where++{-@ assert plusOne :: x:Int -> {v:Int| v > x } @-}+plusOne :: Int -> Int+plusOne x = x + 1
+ tests/pos/MutualRec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE ScopedTypeVariables #-}++module MutualRec where++import Language.Haskell.Liquid.Prelude+++bin :: k -> v -> [(k, v)] -> [(k, v)] -> [(k, v)] +{-@ bin :: k -> v -> [(k, v)] -> [(k, v)] -> [(k, v)] @-}+singleton :: k -> v -> [(k, v)]+{-@ singleton :: k -> v -> [(k, v)] @-}+bin = undefined+singleton = undefined++fromDistinctAscList xs+  = create const (length xs) xs+  where+    {-@ Decrease create  2 3 @-}+    {-@ Decrease createR 1 4 @-}+    create c (0::Int) xs' = c undefined xs'+-- LIQUID for n = 1 n `div` 2 = 0 and the assume does not hold+    create c 1 xs' = case xs' of+                       (k1,x1):xx -> c (singleton k1 x1) xx+                       _ -> error "fromDistinctAscList create"+    create c 5 xs' = case xs' of+                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)+                            -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx+                       _ -> error "fromDistinctAscList create"+    create c n xs' = seq nr $ create (createR nr c) nl xs'+      where nl = liquidAssume (m < n && m >= 0) m+            m  = n `div` 2+            nr = n - nl - 1++    createR (n::Int) c l ((k,x):ys) = create (createB l k x c) n ys+    createR _ _ _ []         = error "fromDistinctAscList createR []"+    createB l k x c r zs     = c (bin k x l r) zs++
+ tests/pos/NoCaseExpand.hs view
@@ -0,0 +1,18 @@+module NoCaseExpand where++-- time 3.6s w/ "--no-case-expand" flag VS  8.5 s w/o++{- LIQUID "--no-case-expand" @-}++data TokenType =+  Space | Keyword | Keyglyph | Layout | Comment | Conid | Varid |+  Conop | Varop   | String   | Char   | Number  | Cpp   | Error |+  Definition+++context ::  [(TokenType, String)] -> [(TokenType, String)]+context stream@((Keyglyph,"="):_) = stream+context stream@((Keyglyph,"=>"):_) = stream+context stream@((Keyglyph,"⇒"):_) = stream+context (_:stream) = context stream+context [] = []
+ tests/pos/NoExhaustiveGuardsError.hs view
@@ -0,0 +1,6 @@+module Foo where++{-@ LIQUID "--totality" @-}+bar :: Int -> Int -> Int+bar x y | x >  y = 1+        | x <= y = 0
+ tests/pos/OrdList.hs view
@@ -0,0 +1,131 @@+module OrdList (+    OrdList, +        nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, concatOL',+        mapOL, fromOL, toOL, foldrOL, foldlOL+) where++import Language.Haskell.Liquid.Prelude (liquidError)++infixl 5  `appOL`+infixl 5  `snocOL`+infixr 5  `consOL`++{-@+data OrdList [olen] a = None+                      | One  (x  :: a)+                      | Many (xs :: ListNE a)+                      | Cons (x  :: a)           (xs :: OrdList a)+                      | Snoc (xs :: OrdList a)   (x  :: a)+                      | Two  (x  :: OrdListNE a) (y  :: OrdListNE a)+@-}++{-@+measure olen :: OrdList a -> Int+olen (None)      = 0+olen (One x)     = 1+olen (Many xs)   = (len xs)+olen (Cons x xs) = 1 + (olen xs)+olen (Snoc xs x) = 1 + (olen xs)+olen (Two x y)   = (olen x) + (olen y)+@-}++{-@+measure olens :: [OrdList a] -> Int+olens ([])     = 0+olens (ol:ols) = (olen ol) + (olens ols)+@-}++{-@ type ListNE    a   = {v:[a]       | (len v)  > 0} @-}+{-@ type OrdListNE a   = {v:OrdList a | (olen v) > 0} @-}+{-@ type OrdListN  a N = {v:OrdList a | (olen v) = N} @-}++{-@ invariant {v:OrdList a   | (olen v)  >= 0} @-}+{-@ invariant {v:[OrdList a] | (olens v) >= 0} @-}+++data OrdList a+  = None+  | One a+  | Many [a]          -- Invariant: non-empty+  | Cons a (OrdList a)+  | Snoc (OrdList a) a+  | Two (OrdList a) -- Invariant: non-empty+        (OrdList a) -- Invariant: non-empty+++{-@ nilOL    :: OrdListN a {0} @-}+{-@ isNilOL  :: xs:OrdList a -> {v:Bool | ((Prop v) <=> ((olen xs) = 0))} @-}++{-@ unitOL   :: a              -> OrdListN a {1} @-}+{-@ snocOL   :: xs:OrdList a   -> a            -> OrdListN a {1+(olen xs)} @-}+{-@ consOL   :: a              -> xs:OrdList a -> OrdListN a {1+(olen xs)} @-}+{-@ appOL    :: xs:OrdList a   -> ys:OrdList a -> OrdListN a {(olen xs)+(olen ys)} @-}+{-@ concatOL :: xs:[OrdList a] -> OrdListN a {(olens xs)} @-}++nilOL        = None+unitOL as    = One as+snocOL as   b    = Snoc as b+consOL a    bs   = Cons a bs+--LIQUID this definition requires `foldr` with abstract refinements, which isn't+--LIQUID in our standard set of specs+-- concatOL aas = foldr appOL None aas+concatOL []       = None+concatOL (ol:ols) = ol `appOL` concatOL ols++--LIQUID as an alternative, we can easily verify the property that, given+--LIQUID non-empty lists, `concatOL` will return a non-empty list+{-@ concatOL' :: ListNE (OrdListNE a) -> OrdListNE a @-}+concatOL' []     = liquidError "can't happen"+concatOL' (x:xs) = foldr appOL x xs++isNilOL None = True+isNilOL _    = False++None  `appOL` b     = b+a     `appOL` None  = a+One a `appOL` b     = Cons a b+a     `appOL` One b = Snoc a b+a     `appOL` b     = Two a b++{-@ qualif Go(v:List a, xs:OrdList a, ys:List a): (len v) = (olen xs) + (len ys) @-}++{-@ fromOL :: xs:OrdList a -> {v:[a] | (len v) = (olen xs)} @-}+fromOL a = go a []+  where+    go None       acc = acc+    go (One a)    acc = a : acc+    go (Cons a b) acc = a : go b acc+    go (Snoc a b) acc = go a (b:acc)+    go (Two a b)  acc = go a (go b acc)+    go (Many xs)  acc = xs ++ acc++{-@ mapOL :: (a -> b) -> xs:OrdList a -> OrdListN b {(olen xs)} @-}+mapOL _ None = None+mapOL f (One x) = One (f x)+mapOL f (Cons x xs) = Cons (f x) (mapOL f xs)+mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x)+mapOL f (Two x y) = Two (mapOL f x) (mapOL f y)+mapOL f (Many xs) = Many (map f xs)++instance Functor OrdList where+  fmap = mapOL++foldrOL :: (a->b->b) -> b -> OrdList a -> b+foldrOL _ z None        = z+foldrOL k z (One x)     = k x z+foldrOL k z (Cons x xs) = k x (foldrOL k z xs)+foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs+foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1+foldrOL k z (Many xs)   = foldr k z xs++foldlOL :: (b->a->b) -> b -> OrdList a -> b+foldlOL _ z None        = z+foldlOL k z (One x)     = k z x+foldlOL k z (Cons x xs) = foldlOL k (k z x) xs+foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x+foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2+foldlOL k z (Many xs)   = foldl k z xs++{-@ toOL :: xs:[a] -> OrdListN a {(len xs)} @-}+toOL [] = None+toOL xs = Many xs
+ tests/pos/Overwrite.hs view
@@ -0,0 +1,26 @@+module OverWrite where++import qualified Data.Set++{-@ assume reverse :: xs:(UList a)+                   -> {v: UList a | (EqElts v xs)} +  @-}+{-@ type UList a = {v:[a] | (ListUnique v)} @-}++{-@ predicate ListUnique LS =+       (Set_emp (listDup LS)) @-}++{-@ predicate EqElts X Y =+       ((listElts X) = (listElts Y)) @-}+{-@+  measure listDup :: [a] -> (Data.Set.Set a)+  listDup([])   = {v | Set_emp v }+  listDup(x:xs) = {v | v = if (Set_mem x (listElts xs)) then (Set_cup (Set_sng x) (listDup xs)) else (listDup xs) }+  @-}++{-@ foo :: xs:(UList a)+        -> {v: UList a | (EqElts v xs)} +  @-}+++foo  = reverse
+ tests/pos/PairMeasure.hs view
@@ -0,0 +1,16 @@+module Foo () where++{-@ measure getfst :: (a, b) -> a+    getfst (x, y) = x+  @-}++{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}+{-@ type OPList a b = [(Pair a b)]<\h -> {v: (a, b) | (getfst v) >= (getfst h)}> @-}+{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}++{-@ getFsts          :: OPList a b -> OList a @-}+getFsts []           = [] +getFsts ((x,_) : xs) = x : getFsts xs+++
+ tests/pos/PairMeasure0.hs view
@@ -0,0 +1,5 @@+module Foo () where++{-@ foo :: p:(a, b) -> {v:a | (v = (fst p))} @-}+foo (x, y) = x+
+ tests/pos/Permutation.hs view
@@ -0,0 +1,16 @@+module Permutation () where++{-@ permutations :: ts:[a] -> [[a]] / [(len ts), 1, 0] @-}+permutations            :: [a] -> [[a]]+permutations xs0        =  xs0 : perms xs0 []++{-@ perms :: ts:[a] -> is:[a] -> [[a]] / [((len ts)+(len is)), 0, (len ts)] @-}+perms :: [a] -> [a] -> [[a]]+perms []     _  = []+perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)+      where interleave    xs     r = let (_,zs) = interleave' id xs r in zs+            interleave' _ []     r = (ts, r)+            interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r+                                     in  (y:us, f (t:y:us) : zs)++
+ tests/pos/PlugHoles.hs view
@@ -0,0 +1,3 @@+module PlugHoles where++{-@ (>>=) :: m a -> (a -> m b) -> m b @-}
+ tests/pos/PointDist.hs view
@@ -0,0 +1,55 @@+{-@ LIQUID "--short-names"    @-}++module Point where++-- | Non-negative numbers:++{-@ type NonNeg  = {v:Double | v >= 0.0 } @-}++-- | Non-negative, and zero iff X is zero:++{-@ type PosZ X  = {v:NonNeg | X == 0.0 <=> v == 0.0 } @-}+ +-- | The distance function, STATICALLY guaranteed to satisfy "pre/post"+--   or type spec, assuming no run-time checks fail++{-@ dist                 :: p1:Point -> p2:Point -> {v:NonNeg | v == 0.0 <=> EqPoint p1 p2} @-}+dist (P x1 y1) (P x2 y2) = d+  where +    d                    = root   (dx + dy)+    dx                   = square (x1 - x2)+    dy                   = square (y1 - y2)++-- | A Data Type for Points++data Point = P { px :: Double, py::Double }++{-@ data Point = P { px :: Double, py :: Double } @-}++-- | When are two points "equal" ?++{-@ predicate EqPoint P1 P2 = (px P1 == px P2 && py P1 == py P2) @-}+                +-- | Squaring numbers: DYNAMIC checks establish numerical properties++{-@ square :: x:Double -> PosZ x @-}+square   :: Double -> Double+square 0 = 0+square x = assume (xx > 0) xx +  where+    xx   = x * x++{-@ root :: x:NonNeg -> PosZ x  @-}+root :: Double -> Double+root 0  = 0+root x  = assume (rx > 0) rx+  where+    rx  = sqrt x++-- | Run-time Checks++{-@ assume     :: b:_ -> a -> {v:a | Prop b} @-}+assume True  x = x+assume False _ = error "Failed Dynamic Check!"++
+ tests/pos/Product.hs view
@@ -0,0 +1,65 @@+{-@ LIQUID "--real"     @-}+{-@ LIQUID "--total" @-}+++module Vectors where++import Prelude hiding (sum, product, zipWith)++flatten :: Int -> Int -> [[a]] -> [a]++-- | Lets reuse plain lists++type Vec a = [a]++-- | The `len` function is defined in the LH prelude as:+{-++   len        :: [a] -> Int+   len []     = 0+   len (_:xs) = 1 + len xs+-}++             +{-@ type VecN a N = {v : Vec a | len v = N} @-}++{-@ product   :: xs:Vec a -> ys:Vec a -> VecN a {len xs * len ys} @-}+product xs ys = flatten n m $ map (\y -> map (* y) xs) ys+  where+    m         = length xs+    n         = length ys++{-@ sum       :: xs:Vec a -> ys:VecN a {len xs}-> VecN a {len xs} @-}+sum xs ys     = zipWith (+) xs ys++{-@ sum'       :: xs:Vec a -> ys:Vec a -> VecN a {len xs + len ys} @-}+sum' [] ys     = ys+sum' (x:xs) ys = x : sum' xs ys++{-@ example1   :: b:VecN _ 3 -> VecN _ 6 @-}+example1 b     = ([1, 2] `product` b) `sum` [1, 2, 3, 4, 5, 6]+    +{-@ example2   :: a:Vec _ -> b:{Vec _ | len b * len a = 6} -> VecN _ 6 @-}+example2 a b   = (a `product` b) `sum` [1,2,3,4,5,6]+++-- Helpers --+++{-@ flatten          :: n:Nat -> m:Nat -> VecN (VecN a m) n -> VecN a {m * n} @-}+flatten n m []       = []+flatten n m (xs:xss) = xs ++ flatten (n-1) m xss +++{-@ zipWith             :: (a -> b -> c) -> xs:Vec a -> ys:VecN b {len xs} -> VecN c {len xs} @-}+zipWith f [] []         = []+zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys+++++{-@ lAssert :: TT -> a -> a@-}+lAssert True x = x++  +
+ tests/pos/Propability.hs view
@@ -0,0 +1,28 @@+module Propability where++{-@ LIQUID "--real" @-}++{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}++{-@ p :: Propability @-}+p :: Double+p = 0.8++data DPD k = DPD [Pair k Double]++data Pair x y = P x y+{-@ data DPD k = DPD (val::{v:[Pair k Propability]|(total v) = 1.0 }) @-}++{-@ measure total :: [Pair k Double] -> Double +    total([]) = 0.0+    total(x:xs) = (sndP x) + (total xs)+  @-}++{-@ measure sndP :: (Pair x Double) -> Double+    sndP(P x y) = y+  @-}+++dpd0 :: DPD Int+dpd0 = DPD [P 1 0.8, P 2 0.1, P 3 0.1]+
+ tests/pos/RBTree-col-height.hs view
@@ -0,0 +1,208 @@++{-@ LIQUID "--no-termination"   @-}++module RedBlackTree where++import Language.Haskell.Liquid.Prelude++data RBTree a = Leaf +              | Node Color a !(RBTree a) !(RBTree a)+              deriving (Show)++data Color = B -- ^ Black+           | R -- ^ Red+           deriving (Eq,Show)++---------------------------------------------------------------------------+-- | Add an element -------------------------------------------------------+---------------------------------------------------------------------------++{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}+add x s = makeBlack (ins x s)++{-@ ins :: (Ord a) => a -> t:RBT a -> {v: ARBTN a {(bh t)} | ((IsB t) => (isRB v))} @-}+ins kx Leaf             = Node R kx Leaf Leaf+ins kx s@(Node B x l r) = case compare kx x of+                            LT -> let t = lbal x (ins kx l) r in t +                            GT -> let t = rbal x l (ins kx r) in t +                            EQ -> s+ins kx s@(Node R x l r) = case compare kx x of+                            LT -> Node R x (ins kx l) r+                            GT -> Node R x l (ins kx r)+                            EQ -> s++---------------------------------------------------------------------------+-- | Delete an element ----------------------------------------------------+---------------------------------------------------------------------------++{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}+remove x t = makeBlack (del x t)++{-@ predicate HDel T V = (bh V) = (if (isB T) then (bh T) - 1 else (bh T)) @-}++{-@ del              :: (Ord a) => a -> t:RBT a -> {v:ARBT a | ((HDel t v) && ((isB t) || (isRB v)))} @-}+del x Leaf           = Leaf+del x (Node _ y a b) = case compare x y of+   EQ -> append y a b +   LT -> case a of+           Leaf         -> Node R y Leaf b+           Node B _ _ _ -> lbalS y (del x a) b+           _            -> let t = Node R y (del x a) b in t +   GT -> case b of+           Leaf         -> Node R y a Leaf +           Node B _ _ _ -> rbalS y a (del x b)+           _            -> Node R y a (del x b)++{-@ append :: y:a -> l:RBT a -> r:RBTN a {(bh l)} -> (ARBT2 a l r) @-}+append :: a -> RBTree a -> RBTree a -> RBTree a++append _ Leaf r                               +  = r++append _ l Leaf                               +  = l++append piv (Node R lx ll lr) (Node R rx rl rr)  +  = case append piv lr rl of +     Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)+     lrl              -> Node R lx ll (Node R rx lrl rr)++append piv (Node B lx ll lr) (Node B rx rl rr)  +  = case append piv lr rl of +      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)+      lrl              -> lbalS lx ll (Node B rx lrl rr)++append piv l@(Node B _ _ _) (Node R rx rl rr)   +  = Node R rx (append piv l rl) rr++append piv l@(Node R lx ll lr) r@(Node B _ _ _) +  = Node R lx ll (append piv lr r)++---------------------------------------------------------------------------+-- | Delete Minimum Element -----------------------------------------------+---------------------------------------------------------------------------++{-@ deleteMin            :: RBT a -> RBT a @-}+deleteMin (Leaf)         = Leaf+deleteMin (Node _ x l r) = makeBlack t+  where +    (_, t)               = deleteMin' x l r+++{-@ deleteMin'                   :: k:a -> l:RBT a -> r:RBTN a {(bh l)} -> (a, ARBT2 a l r) @-}+deleteMin' k Leaf r              = (k, r)+deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr +deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr ++---------------------------------------------------------------------------+-- | Rotations ------------------------------------------------------------+---------------------------------------------------------------------------++{-@ lbalS  :: k:a -> l:ARBT a -> r:RBTN a {1 + (bh l)} -> {v: ARBTN a {1 + (bh l)} | ((IsB r) => (isRB v))} @-}+lbalS k (Node R x a b) r              = Node R k (Node B x a b) r+lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t +lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))+lbalS k l r                           = liquidError "nein" -- Node R l k r++{-@ rbalS  :: k:a -> l:RBT a -> r:ARBTN a {(bh l) - 1} -> {v: ARBTN a {(bh l)} | ((IsB l) => (isRB v))} @-}+rbalS k l (Node R y b c)              = Node R k l (Node B y b c)+rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t +rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)+rbalS k l r                           = liquidError "nein" -- Node R l k r++{-@ lbal  :: k:a -> l:ARBT a -> RBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}+lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)+lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)+lbal k l r                            = Node B k l r++{-@ rbal  :: k:a -> l:RBT a -> ARBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}+rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)+rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)+rbal x l r                            = Node B x l r++---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------++{-@ type BlackRBT a = {v: RBT a | ((IsB v) && (bh v) > 0)} @-}++{-@ makeRed :: l:BlackRBT a -> ARBTN a {(bh l) - 1} @-}+makeRed (Node _ x l r) = Node R x l r+makeRed Leaf           = liquidError "nein" ++{-@ makeBlack :: ARBT a -> RBT a @-}+makeBlack Leaf           = Leaf+makeBlack (Node _ x l r) = Node B x l r++---------------------------------------------------------------------------+-- | Specifications -------------------------------------------------------+---------------------------------------------------------------------------++-- | Red-Black Trees++{-@ type RBT a    = {v: RBTree a | ((isRB v) && (isBH v)) } @-}++{-@ type RBTN a N = {v: (RBT a) | (bh v) = N }              @-}++{-@ measure isRB        :: RBTree a -> Prop+    isRB (Leaf)         = true+    isRB (Node c x l r) = ((isRB l) && (isRB r) && ((c == R) => ((IsB l) && (IsB r))))+  @-}++-- | Almost Red-Black Trees++{-@ type ARBT a    = {v: RBTree a | ((isARB v) && (isBH v))} @-}++{-@ type ARBTN a N = {v: ARBT a   | (bh v) = N }             @-}++{-@ measure isARB        :: (RBTree a) -> Prop+    isARB (Leaf)         = true +    isARB (Node c x l r) = ((isRB l) && (isRB r))+  @-}++-- | Conditionally Red-Black Tree++{-@ type ARBT2 a L R = {v:ARBTN a {(bh L)} | (((IsB L) && (IsB R)) => (isRB v))} @-}++-- | Color of a tree++{-@ measure col         :: RBTree a -> Color+    col (Node c x l r)  = c+    col (Leaf)          = B+  @-}++{-@ measure isB        :: RBTree a -> Prop+    isB (Leaf)         = false+    isB (Node c x l r) = c == B +  @-}++{-@ predicate IsB T = not ((col T) == R) @-}++-- | Black Height++{-@ measure isBH        :: RBTree a -> Prop+    isBH (Leaf)         = true+    isBH (Node c x l r) = ((isBH l) && (isBH r) && (bh l) = (bh r))+  @-}++{-@ measure bh        :: RBTree a -> Int+    bh (Leaf)         = 0+    bh (Node c x l r) = (bh l) + (if (c == R) then 0 else 1) +  @-}++-------------------------------------------------------------------------------+-- Auxiliary Invariants -------------------------------------------------------+-------------------------------------------------------------------------------++{-@ predicate Invs V = ((Inv1 V) && (Inv2 V) && (Inv3 V))   @-}+{-@ predicate Inv1 V = (((isARB V) && (IsB V)) => (isRB V)) @-}+{-@ predicate Inv2 V = ((isRB v) => (isARB v))              @-}+{-@ predicate Inv3 V = 0 <= (bh v)                          @-}++{-@ invariant {v: Color | (v = R || v = B)}                 @-}++{-@ invariant {v: RBTree a | (Invs v)}                      @-}++{-@ inv            :: RBTree a -> {v:RBTree a | (Invs v)}   @-}+inv Leaf           = Leaf+inv (Node c x l r) = Node c x (inv l) (inv r)
+ tests/pos/RBTree-color.hs view
@@ -0,0 +1,189 @@+{-@ LIQUID "--no-termination"   @-}++module RedBlackTree where++import Language.Haskell.Liquid.Prelude++data RBTree a = Leaf +              | Node Color a !(RBTree a) !(RBTree a)+              deriving (Show)++data Color = B -- ^ Black+           | R -- ^ Red+           deriving (Eq,Show)++---------------------------------------------------------------------------+-- | Add an element -------------------------------------------------------+---------------------------------------------------------------------------++{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}+add x s = makeBlack (ins x s)++{-@ ins :: (Ord a) => a -> t:RBT a -> {v: ARBT a | ((IsB t) => (isRB v))} @-}+ins kx Leaf             = Node R kx Leaf Leaf+ins kx s@(Node B x l r) = case compare kx x of+                            LT -> let t = lbal x (ins kx l) r in t +                            GT -> let t = rbal x l (ins kx r) in t +                            EQ -> s+ins kx s@(Node R x l r) = case compare kx x of+                            LT -> Node R x (ins kx l) r+                            GT -> Node R x l (ins kx r)+                            EQ -> s++---------------------------------------------------------------------------+-- | Delete an element ----------------------------------------------------+---------------------------------------------------------------------------++{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}+remove x t = makeBlack (del x t)++{-@ del              :: (Ord a) => a -> t:RBT a -> {v:ARBT a | ((isB t) || (isRB v))} @-}+del x Leaf           = Leaf+del x (Node _ y a b) = case compare x y of+   EQ -> append y a b +   LT -> case a of+           Leaf         -> Node R y Leaf b+           Node B _ _ _ -> lbalS y (del x a) b+           _            -> let t = Node R y (del x a) b in t +   GT -> case b of+           Leaf         -> Node R y a Leaf +           Node B _ _ _ -> rbalS y a (del x b)+           _            -> Node R y a (del x b)++{-@ append :: y:a -> l:RBT a -> r:RBT a -> (ARBT2 a l r) @-}++append :: a -> RBTree a -> RBTree a -> RBTree a++append _ Leaf r +  = r++append _ l Leaf +  = l++append piv (Node R lx ll lr) (Node R rx rl rr)  +  = case append piv lr rl of +      Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)+      lrl              -> Node R lx ll (Node R rx lrl rr)++append piv (Node B lx ll lr) (Node B rx rl rr)  +  = case append piv lr rl of +      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)+      lrl              -> lbalS lx ll (Node B rx lrl rr)++append piv l@(Node B _ _ _) (Node R rx rl rr)   +  = Node R rx (append piv l rl) rr++append piv l@(Node R lx ll lr) r@(Node B _ _ _) +  = Node R lx ll (append piv lr r)++---------------------------------------------------------------------------+-- | Delete Minimum Element -----------------------------------------------+---------------------------------------------------------------------------++{-@ deleteMin :: RBT a -> RBT a @-}+deleteMin (Leaf)         = Leaf+deleteMin (Node _ x l r) = makeBlack t+  where +    (_, t)               = deleteMin' x l r+++{-@ deleteMin' :: k:a -> l:RBT a -> r:RBT a -> (a, ARBT2 a l r) @-}+deleteMin' k Leaf r              = (k, r)+deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr +deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr ++---------------------------------------------------------------------------+-- | Rotations ------------------------------------------------------------+---------------------------------------------------------------------------++{-@ lbalS                             :: k:a -> l:ARBT a -> r:RBT a -> {v: ARBT a | ((IsB r) => (isRB v))} @-}+lbalS k (Node R x a b) r              = Node R k (Node B x a b) r+lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t +lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))+lbalS k l r                           = error "nein"++{-@ rbalS                             :: k:a -> l:RBT a -> r:ARBT a -> {v: ARBT a | ((IsB l) => (isRB v))} @-}+rbalS k l (Node R y b c)              = Node R k l (Node B y b c)+rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t +rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)+rbalS k l r                           = error "nein" ++{-@ lbal                              :: k:a -> l:ARBT a -> RBT a -> RBT a @-}+lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)+lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)+lbal k l r                            = Node B k l r++{-@ rbal                              :: k:a -> l:RBT a -> ARBT a -> RBT a  @-}+rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)+rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)+rbal x l r                            = Node B x l r++---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------++{-@ type BlackRBT a = {v: RBT a | (IsB v)} @-}++{-@ makeRed :: l:BlackRBT a -> ARBT a @-}+makeRed (Node B x l r) = Node R x l r+makeRed _              = error "nein" ++{-@ makeBlack :: ARBT a -> RBT a @-}+makeBlack Leaf           = Leaf+makeBlack (Node _ x l r) = Node B x l r++---------------------------------------------------------------------------+-- | Specifications -------------------------------------------------------+---------------------------------------------------------------------------++-- | Red-Black Trees++{-@ type RBT a    = {v: RBTree a | (isRB v)} @-}++{-@ measure isRB        :: RBTree a -> Prop+    isRB (Leaf)         = true+    isRB (Node c x l r) = ((isRB l) && (isRB r) && ((c == R) => ((IsB l) && (IsB r))))+  @-}++-- | Almost Red-Black Trees++{-@ type ARBT a    = {v: RBTree a | (isARB v) } @-}++{-@ measure isARB        :: (RBTree a) -> Prop+    isARB (Leaf)         = true +    isARB (Node c x l r) = ((isRB l) && (isRB r))+  @-}++-- | Conditionally Red-Black Tree++{-@ type ARBT2 a L R = {v:ARBT a | (((IsB L) && (IsB R)) => (isRB v))} @-}++-- | Color of a tree++{-@ measure col         :: RBTree a -> Color+    col (Node c x l r)  = c+    col (Leaf)          = B+  @-}++{-@ measure isB        :: RBTree a -> Prop+    isB (Leaf)         = false+    isB (Node c x l r) = c == B +  @-}++{-@ predicate IsB T = not ((col T) == R) @-}++------------------------------------------------------------------+-- | Auxiliary Invariants ----------------------------------------+------------------------------------------------------------------++{-@ predicate Invs V = ((Inv1 V) && (Inv2 V))               @-}+{-@ predicate Inv1 V = (((isARB V) && (IsB V)) => (isRB V)) @-}+{-@ predicate Inv2 V = ((isRB v) => (isARB v))              @-}++{-@ invariant {v: Color | (v = R || v = B)}                 @-}++{-@ invariant {v: RBTree a | (Invs v)}                      @-}++{-@ inv            :: RBTree a -> {v:RBTree a | (Invs v)}   @-}+inv Leaf           = Leaf+inv (Node c x l r) = Node c x (inv l) (inv r)
+ tests/pos/RBTree-height.hs view
@@ -0,0 +1,176 @@++{-@ LIQUID "--no-termination"   @-}++module RedBlackTree where++import Language.Haskell.Liquid.Prelude++data RBTree a = Leaf +              | Node Color a !(RBTree a) !(RBTree a)+              deriving (Show)++data Color = B -- ^ Black+           | R -- ^ Red+           deriving (Eq,Show)++---------------------------------------------------------------------------+-- | Add an element -------------------------------------------------------+---------------------------------------------------------------------------++{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}+add x s = makeBlack (ins x s)++{-@ ins :: (Ord a) => a -> t:RBT a -> RBTN a {(bh t)}  @-}+ins kx Leaf             = Node R kx Leaf Leaf+ins kx s@(Node B x l r) = case compare kx x of+                            LT -> let t = lbal x (ins kx l) r in t +                            GT -> let t = rbal x l (ins kx r) in t +                            EQ -> s+ins kx s@(Node R x l r) = case compare kx x of+                            LT -> Node R x (ins kx l) r+                            GT -> Node R x l (ins kx r)+                            EQ -> s++---------------------------------------------------------------------------+-- | Delete an element ----------------------------------------------------+---------------------------------------------------------------------------++{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}+remove x t = makeBlack (del x t)++{-@ predicate HDel T V = (bh V) = (if (isB T) then (bh T) - 1 else (bh T)) @-}++{-@ del              :: (Ord a) => a -> t:RBT a -> {v:RBT a | (HDel t v)} @-}+del x Leaf           = Leaf+del x (Node _ y a b) = case compare x y of+   EQ -> append y a b +   LT -> case a of+           Leaf         -> Node R y Leaf b+           Node B _ _ _ -> lbalS y (del x a) b+           _            -> let t = Node R y (del x a) b in t +   GT -> case b of+           Leaf         -> Node R y a Leaf +           Node B _ _ _ -> rbalS y a (del x b)+           _            -> Node R y a (del x b)++{-@ append :: y:a -> l:RBT a -> r:RBTN a {(bh l)} -> RBTN a {(bh l)} @-}+append :: a -> RBTree a -> RBTree a -> RBTree a++append _ Leaf r                               +  = r++append _ l Leaf                               +  = l++append piv (Node R lx ll lr) (Node R rx rl rr)  +  = case append piv lr rl of +     Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)+     lrl              -> Node R lx ll (Node R rx lrl rr)++append piv (Node B lx ll lr) (Node B rx rl rr)  +  = case append piv lr rl of +      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)+      lrl              -> lbalS lx ll (Node B rx lrl rr)++append piv l@(Node B _ _ _) (Node R rx rl rr)   +  = Node R rx (append piv l rl) rr++append piv l@(Node R lx ll lr) r@(Node B _ _ _) +  = Node R lx ll (append piv lr r)++---------------------------------------------------------------------------+-- | Delete Minimum Element -----------------------------------------------+---------------------------------------------------------------------------++{-@ deleteMin            :: RBT a -> RBT a @-}+deleteMin (Leaf)         = Leaf+deleteMin (Node _ x l r) = makeBlack t+  where +    (_, t)               = deleteMin' x l r+++{-@ deleteMin'                   :: k:a -> l:RBT a -> r:RBTN a {(bh l)} -> (a, RBTN a {(bh l)}) @-}+deleteMin' k Leaf r              = (k, r)+deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr +deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr ++---------------------------------------------------------------------------+-- | Rotations ------------------------------------------------------------+---------------------------------------------------------------------------++{-@ lbalS  :: k:a -> l:RBT a -> r:RBTN a {1 + (bh l)} -> RBTN a {1 + (bh l)} @-}+lbalS k (Node R x a b) r              = Node R k (Node B x a b) r+lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t +lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))+lbalS k l r                           = error "nein"++{-@ rbalS  :: k:a -> l:RBT a -> r:RBTN a {(bh l) - 1} -> RBTN a {(bh l)}    @-}+rbalS k l (Node R y b c)              = Node R k l (Node B y b c)+rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t +rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)+rbalS k l r                           = error "nein"++{-@ lbal  :: k:a -> l:RBT a -> RBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}+lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)+lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)+lbal k l r                            = Node B k l r++{-@ rbal  :: k:a -> l:RBT a -> RBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}+rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)+rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)+rbal x l r                            = Node B x l r++---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------++{-@ makeRed :: l:RBT a -> RBTN a {(bh l) - 1} @-}+makeRed (Node B x l r) = Node R x l r+makeRed _              = error "nein"++{-@ makeBlack :: RBT a -> RBT a @-}+makeBlack Leaf           = Leaf+makeBlack (Node _ x l r) = Node B x l r++---------------------------------------------------------------------------+-- | Specifications -------------------------------------------------------+---------------------------------------------------------------------------++-- | Red-Black Trees++{-@ type RBT a    = {v: RBTree a | (isBH v) }   @-}++{-@ type RBTN a N = {v: RBT a  | (bh v) = N }   @-}++-- | Color of a tree++{-@ measure isB        :: RBTree a -> Prop+    isB (Leaf)         = false+    isB (Node c x l r) = c == B +  @-}++-- | Black Height++{-@ measure isBH        :: RBTree a -> Prop+    isBH (Leaf)         = true+    isBH (Node c x l r) = ((isBH l) && (isBH r) && (bh l) = (bh r))+  @-}++{-@ measure bh        :: RBTree a -> Int+    bh (Leaf)         = 0+    bh (Node c x l r) = (bh l) + (if (c == R) then 0 else 1) +  @-}++-------------------------------------------------------------------------------+-- Auxiliary Invariants -------------------------------------------------------+-------------------------------------------------------------------------------++{-@ invariant {v: RBTree a | (Invs v)}        @-}+{-@ predicate Invs V = (Inv3 V)               @-}+{-@ predicate Inv3 V = 0 <= (bh v)            @-}++{-@ invariant {v: Color | (v = R || v = B)}   @-}++{-@ inv            :: RBTree a -> {v:RBTree a | (Invs v)}   @-}+inv Leaf           = Leaf+inv (Node c x l r) = Node c x (inv l) (inv r)
+ tests/pos/RBTree-ord.hs view
@@ -0,0 +1,143 @@++{-@ LIQUID "--no-termination"   @-}++module Foo (add, remove, deleteMin, deleteMin') where++import Language.Haskell.Liquid.Prelude++data RBTree a = Leaf +              | Node Color a !(RBTree a) !(RBTree a)+              deriving (Show)++data Color = B -- ^ Black+           | R -- ^ Red+           deriving (Eq,Show)++---------------------------------------------------------------------------+-- | Add an element -------------------------------------------------------+---------------------------------------------------------------------------++{-@ add :: (Ord a) => a -> ORBT a -> ORBT a @-}+add x s = makeBlack (ins x s)++{-@ ins :: (Ord a) => a -> ORBT a -> ORBT a @-}+ins kx Leaf             = Node R kx Leaf Leaf+ins kx s@(Node B x l r) = case compare kx x of+                            LT -> let t = lbal x (ins kx l) r in t +                            GT -> let t = rbal x l (ins kx r) in t +                            EQ -> s+ins kx s@(Node R x l r) = case compare kx x of+                            LT -> Node R x (ins kx l) r+                            GT -> Node R x l (ins kx r)+                            EQ -> s++---------------------------------------------------------------------------+-- | Delete an element ----------------------------------------------------+---------------------------------------------------------------------------++{-@ remove :: (Ord a) => a -> ORBT a -> ORBT a @-}+remove x t = makeBlack (del x t)++{-@ del              :: (Ord a) => a -> ORBT a -> ORBT a @-}+del x Leaf           = Leaf+del x (Node _ y a b) = case compare x y of+   EQ -> append y a b +   LT -> case a of+           Leaf         -> Node R y Leaf b+           Node B _ _ _ -> lbalS y (del x a) b+           _            -> let t = Node R y (del x a) b in t +   GT -> case b of+           Leaf         -> Node R y a Leaf +           Node B _ _ _ -> rbalS y a (del x b)+           _            -> Node R y a (del x b)++{-@ append  :: y:a -> ORBT {v:a | v < y} -> ORBT {v:a | y < v} -> ORBT a @-}+append :: a -> RBTree a -> RBTree a -> RBTree a++append _ Leaf r                               +  = r++append _ l Leaf                               +  = l++append piv (Node R lx ll lr) (Node R rx rl rr)  +  = case append piv lr rl of +      Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)+      lrl              -> Node R lx ll (Node R rx lrl rr)++append piv (Node B lx ll lr) (Node B rx rl rr)  +  = case append piv lr rl of +      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)+      lrl              -> lbalS lx ll (Node B rx lrl rr)++append piv l@(Node B _ _ _) (Node R rx rl rr)   +  = Node R rx (append piv l rl) rr++append piv l@(Node R lx ll lr) r@(Node B _ _ _) +  = Node R lx ll (append piv lr r)++---------------------------------------------------------------------------+-- | Delete Minimum Element -----------------------------------------------+---------------------------------------------------------------------------++{-@ deleteMin  :: ORBT a -> ORBT a @-}+deleteMin (Leaf)         = Leaf+deleteMin (Node _ x l r) = makeBlack t+  where +    (_, t)               = deleteMin' x l r+++{-@ deleteMin' :: k:a -> ORBT {v:a | v < k} -> ORBT {v:a | k < v} -> (a, ORBT a) @-}+deleteMin' k Leaf r              = (k, r)+deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr +deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr ++---------------------------------------------------------------------------+-- | Rotations ------------------------------------------------------------+---------------------------------------------------------------------------++lbalS k (Node R x a b) r              = Node R k (Node B x a b) r+lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t +lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))+lbalS k l r                           = error "nein" ++rbalS k l (Node R y b c)              = Node R k l (Node B y b c)+rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t +rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)+rbalS k l r                           = error "nein"++lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)+lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)+lbal k l r                            = Node B k l r++rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)+rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)+rbal x l r                            = Node B x l r++---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------++makeRed (Node _ x l r) = Node R x l r+makeRed Leaf           = error "nein" ++makeBlack Leaf           = Leaf+makeBlack (Node _ x l r) = Node B x l r++---------------------------------------------------------------------------+-- | Specifications -------------------------------------------------------+---------------------------------------------------------------------------++-- | Ordered Red-Black Trees++{-@ type ORBT a = RBTree <{\root v -> v < root }, {\root v -> v > root}> a @-}++-- | Binary Search Ordering++{-@ data RBTree a <l :: a -> a -> Prop, r :: a -> a -> Prop>+            = Leaf+            | Node (c     :: Color)+                   (key   :: a)+                   (left  :: RBTree <l, r> (a <l key>))+                   (right :: RBTree <l, r> (a <r key>))+  @-}
+ tests/pos/RBTree.hs view
@@ -0,0 +1,213 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--diff"           @-}++module Foo where++import Language.Haskell.Liquid.Prelude++data RBTree a = Leaf +              | Node Color a !(RBTree a) !(RBTree a)+              deriving (Show)++data Color = B -- ^ Black+           | R -- ^ Red+           deriving (Eq,Show)++---------------------------------------------------------------------------+-- | Add an element -------------------------------------------------------+---------------------------------------------------------------------------++{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}+add x s = makeBlack (ins x s)++{-@ ins :: (Ord a) => a -> t:RBT a -> {v: ARBTN a {bh t} | IsB t => isRB v} @-}+ins kx Leaf             = Node R kx Leaf Leaf+ins kx s@(Node B x l r) = case compare kx x of+                            LT -> let t = lbal x (ins kx l) r in t +                            GT -> let t = rbal x l (ins kx r) in t +                            EQ -> s+ins kx s@(Node R x l r) = case compare kx x of+                            LT -> Node R x (ins kx l) r+                            GT -> Node R x l (ins kx r)+                            EQ -> s++---------------------------------------------------------------------------+-- | Delete an element ----------------------------------------------------+---------------------------------------------------------------------------++{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}+remove x t = makeBlack (del x t)++{-@ predicate HDel T V = bh V = if (isB T) then (bh T) - 1 else bh T @-}++{-@ del              :: (Ord a) => a -> t:RBT a -> {v:ARBT a | HDel t v && (isB t || isRB v)} @-}+del x Leaf           = Leaf+del x (Node _ y a b) = case compare x y of+   EQ -> append y a b +   LT -> case a of+           Leaf         -> Node R y Leaf b+           Node B _ _ _ -> lbalS y (del x a) b+           _            -> let t = Node R y (del x a) b in t +   GT -> case b of+           Leaf         -> Node R y a Leaf +           Node B _ _ _ -> rbalS y a (del x b)+           _            -> Node R y a (del x b)++{-@ append :: y:a -> l:RBT {v:a | v < y} -> r:RBTN {v:a | y < v} {bh l} -> ARBT2 a l r @-}+append :: a -> RBTree a -> RBTree a -> RBTree a+append _ Leaf r                               = r+append _ l Leaf                               = l+append piv (Node R lx ll lr) (Node R rx rl rr)  = case append piv lr rl of +                                                    Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)+                                                    lrl              -> Node R lx ll (Node R rx lrl rr)+append piv (Node B lx ll lr) (Node B rx rl rr)  = case append piv lr rl of +                                                    Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)+                                                    lrl              -> lbalS lx ll (Node B rx lrl rr)+append piv l@(Node B _ _ _) (Node R rx rl rr)   = Node R rx (append piv l rl) rr+append piv l@(Node R lx ll lr) r@(Node B _ _ _) = Node R lx ll (append piv lr r)++---------------------------------------------------------------------------+-- | Delete Minimum Element -----------------------------------------------+---------------------------------------------------------------------------++{-@ deleteMin            :: RBT a -> RBT a @-}+deleteMin (Leaf)         = Leaf+deleteMin (Node _ x l r) = makeBlack t+  where +    (_, t)               = deleteMin' x l r+++{-@ deleteMin'                   :: k:a -> l:RBT {v:a | v < k} -> r:RBTN {v:a | k < v} {bh l} -> (a, ARBT2 a l r) @-}+deleteMin' k Leaf r              = (k, r)+deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr +deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr ++---------------------------------------------------------------------------+-- | Rotations ------------------------------------------------------------+---------------------------------------------------------------------------++{-@ lbalS                             :: k:a -> l:ARBT {v:a | v < k} -> r:RBTN {v:a | k < v} {1 + bh l} -> {v: ARBTN a {1 + bh l} | IsB r => isRB v} @-}+lbalS k (Node R x a b) r              = Node R k (Node B x a b) r+lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t +lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))+lbalS k l r                           = liquidError "nein"++{-@ rbalS                             :: k:a -> l:RBT {v:a | v < k} -> r:ARBTN {v:a | k < v} {bh l - 1} -> {v: ARBTN a {bh l} | IsB l => isRB v} @-}+rbalS k l (Node R y b c)              = Node R k l (Node B y b c)+rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r  in t +rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)+rbalS k l r                           = liquidError "nein"++{-@ lbal                              :: k:a -> l:ARBT {v:a | v < k} -> RBTN {v:a | k < v} {bh l} -> RBTN a {1 + bh l} @-}+lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)+lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)+lbal k l r                            = Node B k l r++{-@ rbal                              :: k:a -> l:RBT {v:a | v < k} -> ARBTN {v:a | k < v} {bh l} -> RBTN a {1 + bh l} @-}+rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)+rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)+rbal x l r                            = Node B x l r++---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------++{-@ type BlackRBT a = {v: RBT a | IsB v && bh v > 0} @-}++{-@ makeRed :: l:BlackRBT a -> ARBTN a {bh l - 1} @-}+makeRed (Node B x l r) = Node R x l r+makeRed _              = liquidError "nein"++{-@ makeBlack :: ARBT a -> RBT a @-}+makeBlack Leaf           = Leaf+makeBlack (Node _ x l r) = Node B x l r++---------------------------------------------------------------------------+-- | Specifications -------------------------------------------------------+---------------------------------------------------------------------------++-- | Ordered Red-Black Trees++{-@ type ORBT a = RBTree <{\root v -> v < root }, {\root v -> v > root}> a @-}++-- | Red-Black Trees++{-@ type RBT a    = {v: ORBT a | isRB v && isBH v } @-}+{-@ type RBTN a N = {v: RBT a  | bh v = N }         @-}++{-@ type ORBTL a X = RBT {v:a | v < X} @-}+{-@ type ORBTG a X = RBT {v:a | X < v} @-}++{-@ measure isRB        :: RBTree a -> Prop+    isRB (Leaf)         = true+    isRB (Node c x l r) = isRB l && isRB r && (c == R => (IsB l && IsB r))+  @-}++-- | Almost Red-Black Trees++{-@ type ARBT a    = {v: ORBT a | isARB v && isBH v} @-}+{-@ type ARBTN a N = {v: ARBT a | bh v = N }         @-}++{-@ measure isARB        :: (RBTree a) -> Prop+    isARB (Leaf)         = true +    isARB (Node c x l r) = (isRB l && isRB r)+  @-}++-- | Conditionally Red-Black Tree++{-@ type ARBT2 a L R = {v:ARBTN a {bh L} | (IsB L && IsB R) => isRB v} @-}++-- | Color of a tree++{-@ measure col         :: RBTree a -> Color+    col (Node c x l r)  = c+    col (Leaf)          = B+  @-}++{-@ measure isB        :: RBTree a -> Prop+    isB (Leaf)         = false+    isB (Node c x l r) = c == B +  @-}++{-@ predicate IsB T = not (col T == R) @-}++-- | Black Height++{-@ measure isBH        :: RBTree a -> Prop+    isBH (Leaf)         = true+    isBH (Node c x l r) = (isBH l && isBH r && bh l = bh r)+  @-}++{-@ measure bh        :: RBTree a -> Int+    bh (Leaf)         = 0+    bh (Node c x l r) = bh l + if (c == R) then 0 else 1 +  @-}++-- | Binary Search Ordering++{-@ data RBTree a <l :: a -> a -> Prop, r :: a -> a -> Prop>+            = Leaf+            | Node (c     :: Color)+                   (key   :: a)+                   (left  :: RBTree <l, r> (a <l key>))+                   (right :: RBTree <l, r> (a <r key>))+  @-}++-------------------------------------------------------------------------------+-- Auxiliary Invariants -------------------------------------------------------+-------------------------------------------------------------------------------++{-@ predicate Invs V = Inv1 V && Inv2 V && Inv3 V   @-}+{-@ predicate Inv1 V = (isARB V && IsB V) => isRB V @-}+{-@ predicate Inv2 V = isRB v => isARB v            @-}+{-@ predicate Inv3 V = 0 <= bh v                    @-}+{-@ invariant {v: Color | v = R || v = B}           @-}+{-@ invariant {v: RBTree a | Invs v}                @-}++{-@ inv :: RBTree a -> {v:RBTree a | Invs v}        @-}+inv Leaf           = Leaf+inv (Node c x l r) = Node c x (inv l) (inv r)++{-@ invc :: t:RBTree a -> {v:RBTree a | Invs t }  @-}+invc Leaf           =  Leaf+invc (Node c x l r) =  Node c x  (invc l) (invc r)
+ tests/pos/RealProps.hs view
@@ -0,0 +1,30 @@+module Div where++{-@ LIQUID "--real" @-}+++{-@ type Valid = {v:Bool | ( (Prop v) <=> true ) } @-}++{-@ mulAssoc :: Double -> Double -> Double -> Valid @-}+mulAssoc :: Double -> Double -> Double -> Bool+mulAssoc x y z = (x * y) * z == x * (y * z) ++{-@ mulCommut :: Double -> Double -> Valid @-}+mulCommut :: Double -> Double -> Bool+mulCommut x y = x * y == y * x ++{-@ mulId :: Double -> Valid @-}+mulId :: Double -> Bool+mulId x = x == 1 * x ++{-@ mulDistr :: Double -> Double -> Double -> Valid @-}+mulDistr :: Double -> Double -> Double -> Bool+mulDistr x y z = x * (y + z)  == (x * y) + (x * z)++{-@ divId :: Double -> Valid @-}+divId :: Double -> Bool+divId x = x / 1.0 == x++{-@ inverse :: {v:Double | v != 0.0} -> Valid @-}+inverse :: Double -> Bool+inverse x = 1.0 == x * (1.0 / x)
+ tests/pos/RealProps1.hs view
@@ -0,0 +1,30 @@+module Div where++{-@ LIQUID "--real" @-}+++{-@ type Valid = {v:Bool | ( (Prop v) <=> true ) } @-}++{-@ mulAssoc :: (Eq a, Fractional a) => a -> a -> a -> Valid @-}+mulAssoc :: (Eq a, Fractional a) => a -> a -> a -> Bool+mulAssoc x y z = (x * y) * z == x * (y * z) ++{-@ mulCommut :: (Eq a, Fractional a) => a -> a -> Valid @-}+mulCommut :: (Eq a, Fractional a) => a -> a -> Bool+mulCommut x y = x * y == y * x ++{-@ mulId :: (Eq a, Fractional a) => a -> Valid @-}+mulId :: (Eq a, Fractional a) => a -> Bool+mulId x = x == 1 * x ++{-@ mulDistr :: Double -> Double -> Double -> Valid @-}+mulDistr :: Double -> Double -> Double -> Bool+mulDistr x y z = x * (y + z)  == (x * y) + (x * z)++{-@ divId :: Double -> Valid @-}+divId :: Double -> Bool+divId x = x / 1.0 == x++{-@ inverse :: {v:Double | v != 0.0} -> Valid @-}+inverse :: Double -> Bool+inverse x = 1.0 == x * (1.0 / x)
+ tests/pos/RecQSort.hs view
@@ -0,0 +1,29 @@+module GhcSort (qsort) where++{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}++{-@ assert sort3 :: (Ord a) => [a] -> OList a @-}+sort3 :: (Ord a) => [a] -> [a]+sort3 = qsort +++qsort:: (Ord a) => [a] -> [a]+{-@ qsort:: (Ord a) => xs:[a] -> OList a / [(len xs), 0]@-}+qsort []     = []+qsort (x:xs) = qpart x xs [] []++qpart  :: (Ord a) => a -> [a] -> [a] -> [a] -> [a]+{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | (v < x)}] -> p:[{v:a |(v >= x)}] -> OList a / [((len p) + (len r) + (len q)), ((len q) + 1)]@-}+qpart x [] rlt rge =+    app x (qsort rlt) (x:qsort rge)+qpart x (y:ys) rlt rge =+    case compare x y of+        GT -> qpart x ys (y:rlt) rge+        _  -> qpart x ys rlt (y:rge)+++{-@ app :: Ord a => x:a -> (OList ({v:a | v < x})) -> (OList ({v:a| v >= x})) -> OList a @-} +app :: Ord a => a -> [a] -> [a] -> [a]+app k []     ys = ys+app k (x:xs) ys = x : (app k xs ys)+
+ tests/pos/RecQSort0.hs view
@@ -0,0 +1,30 @@+module GhcSort () where++{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}++{-@ assert sort3 :: (Ord a) => [a] -> OList a @-}+sort3 :: (Ord a) => [a] -> [a]+sort3 ls = qsort ls +  where d = (length ls) +++qsort:: (Ord a) => [a] -> [a]+{-@ qsort:: (Ord a) => xs:[a] -> OList a / [(len xs), 0] @-}+qsort []     = []+qsort (x:xs) = qpart x xs [] [] ++qpart  :: (Ord a) => a -> [a] -> [a] -> [a] -> [a]+{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | ((true) && (v < x))}] -> p:[{v:a | ((true) && (v >= x))}] -> OList a / [((len r)+(len q)+(len p)), ((len q)+1)]@-}+qpart x [] rlt rge =+    app x (qsort rlt) (x:qsort rge)+qpart x (y:ys) rlt rge =+    case compare x y of+        GT -> qpart x ys (y:rlt) rge+        _  -> qpart x ys rlt (y:rge)+++{-@ app :: Ord a => x:a -> (OList ({v:a | v < x})) -> (OList ({v:a| v >= x})) -> OList a @-} +app :: Ord a => a -> [a] -> [a] -> [a]+app k []     ys = ys+app k (x:xs) ys = x : (app k xs ys)+
+ tests/pos/RecSelector.hs view
@@ -0,0 +1,15 @@+module Invariant where++data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}++{-@ data F a = F {fx :: a, fy :: a, fz :: a}+             | G {fx :: a} +  @-}++{-@ fooG :: x:a -> {v : F a | (fx v) = x} @-}+fooG :: a -> F a+fooG x = G x ++{-@ foo :: x:a -> {v : F a | (fx v) = x} @-}+foo :: a -> F a+foo x = F x x x
+ tests/pos/RecordSelectorError.hs view
@@ -0,0 +1,18 @@+module Foo where++{-@ LIQUID "--totality" @-}+++data F a b = F {fx :: a, fy :: b} | G {fx :: a}+{-@ data F a b = F {fx :: a, fy :: b} | G {fx :: a} @-}++{-@ measure isF :: F a b -> Prop+    isF (F x y) = true+    isF (G x)   = false+  @-}++-- Record's selector type is defaulted to true as imported+{-@ fy  :: {v:F a b | (isF v)} -> b @-}+{-@ bar :: {v:F a b | (isF v)} -> b @-}+bar :: F a b  -> b+bar = fy
+ tests/pos/RelativeComplete.hs view
@@ -0,0 +1,25 @@+module Compose where++{-@ LIQUID "--no-termination" @-}++-- Here p and q of `app` will be instantiated to +-- p , q := \v -> i <= v++main i = app (check i) i++{-@ check :: x:Int -> {v:Int | x <= v} -> () @-}+check :: Int -> Int -> ()+check = undefined+++{-@ app :: forall <p :: Int -> Prop, q :: Int -> Prop>. +           {Int<q> <: Int<p>}+           {x::Int<q> |- {v:Int| v = x + 1} <: Int<q>}+           (Int<p> -> ()) -> x:Int<q> -> () @-}+app :: (Int -> ()) -> Int -> ()+app f x = if p x then app f (x + 1) else f x+++p :: a -> Bool+{-@ p :: a -> Bool @-}+p = undefined
+ tests/pos/Repeat.hs view
@@ -0,0 +1,28 @@+module Foo where+import Prelude hiding (repeat, take)++data L a = N | C a (L a)++{-@+data L a <p :: (L a) -> Prop>+  = N+  | C (x::a) (xs::L <p> a <<p>>)+@-}++{-@+measure isCons :: L a -> Prop+isCons (N)     = false+isCons (C a l) = true+@-}++{-@ type Stream a = {v: L <{\v -> (isCons v)}> a | (isCons v)} @-}++{-@ Lazy repeat @-}+{-@ repeat :: a -> Stream a @-}+repeat :: a -> L a+repeat x = C x (repeat x)++{-@ take :: Nat -> Stream a -> L a @-}+take :: Int -> L a -> L a+take 0 _           = N+take n ys@(C x xs) = x `C` take (n-1) xs
+ tests/pos/Resolve.hs view
@@ -0,0 +1,8 @@+module Resolve where++import qualified ResolveA as RA+import qualified ResolveB as RB+++{-@ x :: {v:RB.Bar | ((v = RB.B) && (NotA v))} @-}+x = RB.B
+ tests/pos/ResolveA.hs view
@@ -0,0 +1,21 @@+module ResolveA  where++import qualified ResolveB as RB++{-@ measure getFooA :: Foo -> Int+    getFooA (Foo x) = x+  @-}++data Foo = Foo Int++y = RB.Foo 1++{-@ qualif NotA(v:RB.Bar): (notA v) @-}++{-@ measure notA :: RB.Bar -> Prop+    notA (RB.A) = false+    notA (RB.B) = true+    notA (RB.C) = false+  @-}++{-@ predicate NotA V = V != RB.A @-}
+ tests/pos/ResolveB.hs view
@@ -0,0 +1,9 @@+module ResolveB where++{-@ measure getFoo :: Foo -> Int+    getFoo (Foo x) = x+  @-}++data Foo = Foo Int++data Bar = A | B | C
+ tests/pos/ResolvePred.hs view
@@ -0,0 +1,26 @@+module ResolvePred () where++{-@ data L [llen] = C (h :: Int) (t :: L) | N @-}+{-@ invariant {v:L | (llen v) >= 0} @-}++data L = C Int L | N++{-@ myFold :: forall <q :: L -> b -> Prop>.+              (as:L -> a:Int -> b<q as> -> b<q (C a as)>)+           -> b<q N>+           -> l:L+           -> b<q l>+  @-}+myFold f z = go+  where+    go N       = z+    go (C a as) = f as a (go as)++{-@ measure llen :: L -> Int+    llen (N)      = 0+    llen (C x xs) = 1 + (llen xs)+  @-}++{-@ qualif PappL(v:a, p:Pred a L , a:int, as:L ):+        papp2(p, v, C(a, as))+  @-}
+ tests/pos/SafePartialFunctions.hs view
@@ -0,0 +1,27 @@+module SafePartialFunctions (gotail, gohead) where++{-@ LIQUID "--totality" @-}+import Prelude hiding (fromJust, tail, head)++{-@ fromJust :: {v:Maybe a | (isJust v)} -> a @-}+fromJust :: Maybe a -> a+fromJust (Just a) = a++{-@ tail :: {v:[a] | ((len v) > 0)}-> [a] @-}+tail :: [a] -> [a]+tail (x:xs) = xs++{-@ head :: {v:[a] | ((len v) > 0)}-> a @-}+head :: [a] -> a+head (x:xs) = x+++-- USERS++gotail xs = case xs of+             [] -> []+             y : ys -> tail xs++{-@ gohead :: [{v:[a] | ((len v) > 0)}] -> [a] @-}+gohead :: [[a]] -> [a]+gohead xs = map head xs
+ tests/pos/SimplerNotation.hs view
@@ -0,0 +1,5 @@+module SimplerNotation () where++{-@ myDiv :: x:Int -> y:{Int | y != 0} -> {v:Int | v = x / y} @-}+myDiv :: Int -> Int -> Int+myDiv = div
+ tests/pos/StackClass.hs view
@@ -0,0 +1,28 @@+module SClass where++import qualified Data.Set++data Stack a = S [a]++data Foo a = F {stack :: Stack a}++{-@ bar :: xs:[Foo a] -> {v:[Foo a] |(eltss v) = (eltss xs)} @-}+bar :: [Foo a] -> [Foo a]+bar = (F (S []):)++foo = F +{-@ class measure elts  :: forall f a. f a -> Data.Set.Set a @-}+{-@ class measure eltss  :: forall f a. [f a] -> Data.Set.Set a @-}++{-@ instance measure elts :: Stack a -> (Data.Set.Set a)+    elts (S xs) = (listElts xs)+  @-}++{-@ instance measure elts :: Foo a -> (Data.Set.Set a)+    elts (F st) = (elts st)+  @-}++{-@ instance measure  eltss :: [(Foo a)] -> (Data.Set.Set a)+    eltss([]) = {v| Set_emp v }+    eltss(x:xs) = (Set_cup (elts x) (eltss xs))+  @-}
+ tests/pos/State.hs view
@@ -0,0 +1,34 @@+module State (+   returnST -- :: a -> ST a s+ , bindST   -- :: ST a s -> (a -> ST b s) -> ST b s+ , ST(..)+ ) where++import Prelude hiding (snd, fst)++data ST a s = S (s -> (a, s))+{-@ data ST a s <pre :: s -> Prop, post :: a -> s -> Prop> +       = S (ys::(x:s<pre> -> ((a, s)<post>)))+  @-}++{-@ returnST :: forall <pre :: s -> Prop, post :: a -> s -> Prop>.+               xState:a +           -> ST <{v:s<post xState>| true}, post> a s+  @-}+returnST :: a -> ST a s+returnST x = S $ \s -> (x, s)+++{-@ bindST :: forall <pbind :: s -> Prop, qbind :: a -> s -> Prop, rbind :: b -> s -> Prop>.+            ST <pbind, qbind> a s +         -> (xbind:a -> ST <{v:s<qbind xbind> | true}, rbind> b s) +         -> ST <pbind, rbind> b s+ @-}+bindST :: ST a s -> (a -> ST b s) -> ST b s+bindST (S m) k = S $ \s -> let (a, s') = m s in apply (k a) s'++{-@ apply :: forall <p :: s -> Prop, q :: a -> s -> Prop>.+             ST <p, q> a s -> s<p> -> (a, s)<q>+  @-}+apply :: ST a s -> s -> (a, s)+apply (S f) s = f s
+ tests/pos/State1.hs view
@@ -0,0 +1,11 @@+module State0 () where++import State++{-@ fresh :: ST <{\v -> (v >= 0)}, {\xx v -> ((xx>=0) && (v>=0))}> Int Int @-}+fresh :: ST Int Int+fresh = S (\n -> (n, n+1))++{-@ incr4' :: ST <{\v -> (v>=0)}, {\xxxx v -> ((v>=0) && (xxxx>=0))}> Int Int @-}+incr4' :: ST Int Int+incr4' = fresh `bindST` returnST
+ tests/pos/StateConstraints.hs view
@@ -0,0 +1,113 @@+module Compose where+++++data ST s a = ST {runState :: s -> (a,s)}++{-@ data ST s a <p :: s -> Prop, q :: s -> s -> Prop, r :: s -> a -> Prop> +  = ST (runState :: x:s<p> -> (a<r x>, s<q x>)) @-}++ {-@ runState :: forall <p :: s -> Prop, q :: s -> s -> Prop, r :: s -> a -> Prop>. ST <p, q, r> s a -> x:s<p> -> (a<r x>, s<q x>) @-}++++{-+cmp :: forall < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              >. +       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b)+@-}++cmp :: (ST s a)+    -> (ST s b)+    -> (ST s b)++cmp (ST g) (ST f) = ST (\x -> case g x of {(_, s) -> f s})    ++{-@ +bind :: forall < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              , pref0 :: a -> Prop +              >. +       {x::s<pre> |- a<rg x> <: a<pref0>}      +       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (a<pref0> -> ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b)+@-}++bind :: (ST s a)+    -> (a -> ST s b)+    -> (ST s b)++bind (ST g) f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})    ++{-@ incr :: ST <{\x -> x >= 0}, {\x v -> v = x + 1}, {\x v -> v = x}>  Nat Nat @-}+incr :: ST Int Int+incr = ST $ \x ->  (x, x + 1)++{-@ incr2 :: ST <{\x -> x >= 0}, {\x v -> v = x + 2}, {\x v -> v = x + 1}>  Nat Nat @-}+incr2 :: ST Int Int+incr2 = bind incr (\_ -> incr)+++{-@ incr3 :: ST <{\x -> x >= 0}, {\x v -> v = x + 3}, {\x v -> v = x + 2}>  Nat Nat @-}+incr3 :: ST Int Int+incr3 = bind (bind incr (\_ -> incr)) (\_ -> incr)+++foo :: (Int, Int)+{-@ foo :: ({v:Nat |  v = 2}, {v:Nat |  v = 3}) @-}+foo = (runState incr3) 0+++++++++++++++++++++++++++++++++++++
+ tests/pos/StateConstraints0.hs view
@@ -0,0 +1,102 @@+module Compose where+++-- | TODO +-- | +-- | 1. default methods are currently not supported+-- | ie. if we remove the definition of fail method it fails+-- | as I assume that dictionaries are Non Recursive+-- |+-- | 2. check what happens if we import the instance (it should work)  ++data ST s a = ST {runState :: s -> (a,s)}++{-@ data ST s a <p :: s -> Prop, q :: s -> s -> Prop, r :: s -> a -> Prop> +  = ST (runState :: x:s<p> -> (a<r x>, s<q x>)) @-}++{-@ runState :: forall <p :: s -> Prop, q :: s -> s -> Prop, r :: s -> a -> Prop>. ST <p, q, r> s a -> x:s<p> -> (a<r x>, s<q x>) @-}+++++instance Monad (ST s) where+  {-@ instance Monad ST s where+    return :: forall s a <p :: s -> Prop >. x:a -> ST <p, {\s v -> v == s}, {\s v -> x == v}> s a;+    >>= :: forall s a b  < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              , pref0 :: a -> Prop +              >. +       {x::s<pre> |- a<rg x> <: a<pref0>}      +       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (a<pref0> -> ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b) ;+    >>  :: forall s a b  < pref :: s -> Prop, postf :: s -> s -> Prop+              , pre  :: s -> Prop, postg :: s -> s -> Prop+              , post :: s -> s -> Prop+              , rg   :: s -> a -> Prop+              , rf   :: s -> b -> Prop+              , r    :: s -> b -> Prop+              >. +       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+       {ww::s<pre> |- s<postg ww> <: s<pref>}+       (ST <pre, postg, rg> s a)+    -> (ST <pref, postf, rf> s b)+    -> (ST <pre, post, r> s b)+    @-}+  return x     = ST $ \s -> (x, s)+  (ST g) >>= f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})    +  (ST g) >>  f = ST (\x -> case g x of {(y, s) -> (runState f) s})    +  fail         = error++{-@ incr :: ST <{\x -> true}, {\x v -> v = x + 1}, {\x v -> v = x}>  Int Int @-}+incr :: ST Int Int+incr = ST $ \x ->  (x, x + 1)++{-@ foo :: ST <{\x -> true}, {\x v -> true}, {\x v -> v = 0}>  Bool Int @-}+foo :: ST Bool Int+foo = do return 0++{-@ incr2 :: ST <{\x -> true}, {\x v -> v = x + 2}, {\x v -> v = x + 1}>  Int Int @-}+incr2 :: ST Int Int+incr2 = incr >> incr++{-@ incr3 :: ST <{\x -> true}, {\x v -> v = x + 3}, {\x v -> v = x + 2}>  Int Int @-}+incr3 :: ST Int Int+incr3 +  = do incr+       incr+       incr++run :: (Int, Int)+{-@ run :: ({v:Int |  v = 1}, {v:Int |  v = 2}) @-}+run = (runState incr2) 0++++++++++++++++++++++
+ tests/pos/StateConstraints00.hs view
@@ -0,0 +1,47 @@+module Compose where++import Prelude hiding (Monad, return )++-- | TODO +-- | +-- | 1. default methods are currently not supported++data ST s a = ST {runState :: s -> (a,s)}++{-@ data ST s a <r :: a -> Prop> +  = ST (runState :: x:s -> (a<r>, s)) @-}++{-@ runState :: forall <r :: a -> Prop>. ST <r> s a -> x:s -> (a<r>, s) @-}+++class Foo m where+  return :: a -> m a+++instance Foo (ST s) where+  {-@ instance Foo ST s where+    return :: forall s a. x:a -> ST <{\v -> x == v}> s a+    @-}+  return x     = ST $ \s -> (x, s)+ ++{-@ foo :: w:a -> ST <{v:a | v = w}>  Bool a @-}+foo :: a -> ST Bool a+foo x = return x+++bar = runState (foo 0) True++++++++++++++
+ tests/pos/StateF00.hs view
@@ -0,0 +1,19 @@+module State (+   returnST -- :: a -> ST a s+--  , bindST   -- :: ST a s -> (a -> ST b s) -> ST b s+ , ST(..)+ ) where++import Prelude hiding (snd, fst)++data ST a s = S (s -> (a, s))+{-@ data ST a s <post :: s -> a -> s -> Prop> +       = S (ys::(x:s -> ((a, s)<\xx -> {v:s<post x xx> | true} > )))+  @-}++{-@ returnST :: xState:a +             -> ST <{\xs xa v -> (xa = xState)}> a s +  @-}++returnST :: a -> ST a s+returnST x = S $ \s -> (x, s)
+ tests/pos/StreamInvariants.hs view
@@ -0,0 +1,11 @@+module Invariant where++{-@ using [a] as {v : [a] | (len v) > 0 } @-}+++xs = repeat 1++add x xs = x:xs++bar xs = head xs+foo xs = tail xs
+ tests/pos/StrictPair0.hs view
@@ -0,0 +1,15 @@+-- Compare with tests/pos/StrictPair1.hs++module SPair (poo) where++import Language.Haskell.Liquid.Prelude (liquidAssert)++{-@ measure tsnd :: (a, b) -> b +    tsnd (x, y) = y +  @-} ++{-@ type Foo  a = ((a, Int), Int)<{\z v -> v <= (tsnd z)}> @-}++{-@ poo :: (Foo a) -> () @-}+poo     :: ((a, Int), Int) -> ()+poo ((x, n), m) = liquidAssert (m <= n) ()
+ tests/pos/StrictPair1.hs view
@@ -0,0 +1,30 @@+-- From Data.ByteString.Fusion++-- Compare with tests/pos/StrictPair1.hs++module SPair (+    PairS(..)+  , moo+  ) where++import Language.Haskell.Liquid.Prelude (liquidAssert)++infixl 2 :*:++-- | Strict pair+--   But removing the strictness annotation does not change the fact that+--   this program is marked as SAFE...+data PairS a b = !a :*: !b deriving (Eq,Ord,Show)++{-@ data PairS a b <p :: x0:a -> b -> Prop> = (:*:) (x::a) (y::b<p x>)  @-}++{-@ measure psnd :: (PairS a b) -> b +    psnd ((:*:) x y) = y +  @-} ++{-@ type FooS a = PairS <{\z v -> v <= (psnd z)}> (PairS a Int) Int @-}++{-@ moo :: (FooS a) -> () @-}+moo :: PairS (PairS a Int) Int -> () +moo (x :*: n :*: m) = liquidAssert (m <= n) ()+
+ tests/pos/Strings.hs view
@@ -0,0 +1,38 @@+module DBC where++import GHC.CString  -- This import interprets Strings as constants!+++import Data.Set+{-+bar :: () -> String +{- bar :: () -> {x:String | x = unpack "foo" && len x >= 0} @-}+bar _ = "foo"+++{- prop :: {v:Bool | Prop v <=> true} @-}+prop :: Bool+prop = foo1 == foo2 +  where foo1 = "foo"+        foo2 = "foo"+-}+++data Foo = FFFF | QQQQ deriving Eq++{-@ prop2 :: {v:Bool | Prop v <=> true} @-}+prop2 :: Bool+prop2 = foo1 /= foo2 +  where foo1 = FFFF+        foo2 = QQQQ+++{-@ prop3 :: {v:[String] | listElts v ~~ Set_sng "xx"} @-}+prop3 :: [String]+prop3 = ["xx"]++{-@ prop1 :: {v:Bool | Prop v <=> true} @-}+prop1 :: Bool+prop1 = foo1 /= foo2 +  where foo1 = "foo"+        foo2 = "bar"
+ tests/pos/Sum.hs view
@@ -0,0 +1,10 @@+module Sum where++{-@ ssum :: forall<p :: a -> Prop, q :: a -> Prop>. +            {{v:a | v == 0} <: a<q>}+            {x::a<p> |- {v:a | x <= v} <: a<q>}+            xs:[{v:a<p> | 0 <= v}] -> {v:a<q> | len xs >= 0 && 0 <= v } @-}+ssum :: Num a => [a] -> a+ssum []       = 0+ssum [x]      = x+ssum (x:xs)   = x + ssum xs
+ tests/pos/Term.hs view
@@ -0,0 +1,19 @@+module Term where++++{-@ f :: _ -> xs : [a] -> [a] / [len xs] @-}+f er [] = error er+f er (x:xs) = (x+1) : f er xs++{-@ f' :: _ -> xs : [a] -> [a] / [len xs] @-}+f' er [] = error er+f' er (x:xs) = x : f' er xs++{-@ type ListN a N = {v:[a] | len v = N} @-}+{-@ type ListL a L = ListN a (len L) @-}++{-@ safeZipWithError :: _ -> xs:[a] -> ListL b xs -> ListL (a,b) xs / [len xs] @-}+safeZipWithError msg (x:xs) (y:ys) = (x,y) : safeZipWithError msg xs ys+safeZipWithError _   []     []     = []+safeZipWithError msg _      _      = error msg
+ tests/pos/TerminationNum.hs view
@@ -0,0 +1,6 @@+module Fixme where++{-@ fak2 :: (Ord a, Eq a, Num a) => y:{x: a | x >= 0} -> a /[y]@-}+fak2 :: (Ord a, Eq a, Num a) => a -> a+fak2 0 = 1+fak2 x = x * fak2 (x - 1)
+ tests/pos/TerminationNum0.hs view
@@ -0,0 +1,18 @@+module Fixme where++{-@fak2 :: (Ord a, Eq a, Num a) => {x: a | x >= 0} -> a @-}+fak2 :: (Ord a, Eq a, Num a) => a -> a+fak2 0 = 1+fak2 x = x * fak2 (x - 1)+++{-@ fak :: {x: Int | x >= 0} -> a -> Int @-}+fak :: (Ord a, Eq a, Num a) => Int -> a -> Int +fak 0 _ = 1+fak x y = fak (x - 1) y+++{-@ fak1 :: {x: Int | x >= 0} -> a -> Int @-}+fak1 :: (Num a) => Int -> a -> Int +fak1 0 _ = 1+fak1 x y = fak1 (x - 1) y
+ tests/pos/Test761.hs view
@@ -0,0 +1,10 @@+module Test761 () where++import Language.Haskell.Liquid.Prelude++x = choose 0++prop_abs ::  Bool+prop_abs = if x > 0 then baz x else False++baz gooberding = liquidAssertB (gooberding >= 0)
+ tests/pos/TokenType.hs view
@@ -0,0 +1,9 @@+module Fixme where+++data TokenType = Foo | Char+++{-@ bar :: Char @-}+bar :: Char+bar = undefined
+ tests/pos/TopLevel.hs view
@@ -0,0 +1,7 @@+module TopLevel (bar) where++import Language.Haskell.Liquid.Prelude++foo b = liquidAssertB b++bar = foo True
+ tests/pos/ToyMVar.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++{-@ LIQUID "--no-termination" @-}+module ToyMVar where++import Prelude hiding (IO)+import Data.Set +data RealWorld+data MVar# s a +data State# s +data MVar a = MVar (MVar# RealWorld a)++data IO a = IO (State# RealWorld -> (State# RealWorld, a))+{-@ data IO a <p :: State# RealWorld -> Prop, q :: State# RealWorld-> a -> Prop>+      = IO (io :: (State# RealWorld)<p> -> ((State# RealWorld, a)<q>))+  @-}++{-@ measure inState :: MVar a -> State# RealWorld -> Prop @-}+{-@ measure stateMVars :: State# RealWorld -> Set (MVar a) @-}++{-@ newEmptyMVar  :: forall < p :: State# RealWorld -> Prop+                            , q :: State# RealWorld -> (MVar a) -> Prop>. +                     IO <p, {\x y -> (inState y x)}> (MVar a) @-}+newEmptyMVar  :: IO (MVar a)+newEmptyMVar = IO $ \ s# ->+    case newMVar# s# of+         (s2#, svar#) -> (s2#, MVar svar#)++newMVar :: a -> IO (MVar a)+newMVar value =+    newEmptyMVar        >>= \ mvar ->+    putMVar mvar value  >>+    return mvar++putMVar  :: MVar a -> a -> IO ()+putMVar (MVar mvar#) x = IO $ \ s# ->+    case putMVar# mvar# x s# of+        s2# -> (s2#, ())+++putMVar# :: MVar# s a -> a -> State# s -> State# s+putMVar# = let x = x in x++{-@ newMVar#  :: forall < p :: State# s -> Prop+                            , q :: State# s -> (MVar# s a) -> Prop>. +                     (State# s)<p> -> +                     ((State# s)<p>, (MVar# s a))<q> @-}++newMVar# :: State# s -> (State# s, MVar# s a)+newMVar# = let x = x in x++instance Monad IO where --  GHC-Base.lhs+  return = undefined+  _ >> _ = undefined
+ tests/pos/TypeAlias.hs view
@@ -0,0 +1,14 @@+module TypeAlias where++data Foo a b = Foo a b++type Bar = Foo Int+++{-@ foo :: String  @-}+foo :: String+foo = "mpla"++{-@ bar :: Bar {v:Int | v = 2} @-}+bar :: Bar Int+bar = Foo 1 2
+ tests/pos/Variance.hs view
@@ -0,0 +1,47 @@+module Variance where++{-@ data variance Foo invariant bivariant covariant contravariant @-}+data Foo a b c d++++{-@ check_covariant :: Foo a b {v:Int | v = 1} c -> Foo a b {v:Int | v > 0} c @-}+check_covariant :: Foo a b Int c -> Foo a b Int c+check_covariant r = r+++{-@ check_contravariant0 :: Foo a b c {v:Int | v > 0} -> Foo a b c {v:Int | v = 1} @-}+check_contravariant0 :: Foo a b c Int-> Foo a b c Int+check_contravariant0 r = r++{-@ check_contravariant :: ((Foo a b c {v:Int | v = 1}) -> ()) -> (Foo a b c {v:Int | v > 0}) -> () @-}+check_contravariant :: ((Foo a b c Int) -> ()) -> Foo a b c Int -> ()+check_contravariant r = r++{-@ check_bivariant :: Foo a {v: Int | v = 1} c d -> Foo a {v:Int | ((v > 0) && (v < 2))} c d @-}+check_bivariant :: Foo a Int c d -> Foo a Int c d+check_bivariant r = r+++{-@ check_invariant :: Foo {v: Int | v = 1} b c d -> Foo {v:Int | ((v > 0) && (v < 2))} b c d @-}+check_invariant :: Foo Int b c d -> Foo Int b c d+check_invariant r = r+++++++++++++++++++
+ tests/pos/WBL.hs view
@@ -0,0 +1,177 @@++-----------------------------------------------------------------------+-- Weight-Biased Leftist Heap, verified using LiquidHaskell -----------+-----------------------------------------------------------------------+-- ORIGINAL SOURCE ----------------------------------------------------+-----------------------------------------------------------------------+-- Copyright: 2014, Jan Stolarek, Politechnika Łódzka                --+--                                                                   --+-- License: See LICENSE file in root of the repo                     --+-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps-hs --+--                                                                   --+-- Basic implementation of weight-biased leftist heap. No proofs     --+-- and no dependent types. Uses a two-pass merging algorithm.        --+-----------------------------------------------------------------------++{-@ LIQUID "--no-termination" @-}++module WBL where++type Priority = Int++type Rank     = Int++type Nat      = Int++data Heap a   = Empty | Node { pri   :: a+                             , rnk   :: Rank+                             , left  :: Heap a+                             , right :: Heap a+                             }++{-@ data Heap a <q :: a -> a -> Prop> =+      Empty | Node { pri   :: a+                   , rnk   :: Nat+                   , left  :: {v: Heap<q> (a<q pri>) | ValidRank v}+                   , right :: {v: Heap<q> (a<q pri>) | ValidRank v}+                   }+ @-}++{-@ predicate ValidRank V = okRank V && realRank V = rank V  @-}+{-@ type PHeap a = {v:OHeap a | ValidRank v}                 @-}+{-@ type OHeap a = Heap <{\root v -> root <= v}> a           @-}++{-@ measure okRank        :: Heap a -> Prop+    okRank (Empty)        = true+    okRank (Node p k l r) = ((realRank l >= realRank r) && k == (1 + (realRank l) + (realRank r)))+  @-}++{-@ measure realRank :: Heap a -> Int+    realRank (Empty)        = 0+    realRank (Node p k l r) = (1 + realRank l + realRank r)+  @-}++{-@ measure rank @-}+{-@ rank :: h:PHeap a -> {v:Nat | v = realRank h} @-}+rank Empty          = 0+rank (Node _ r _ _) = r+++-- Creates heap containing a single element with a given Priority+{-@ singleton :: a -> PHeap a  @-}+singleton p = Node p 1 Empty Empty++-- Note [Two-pass merging algorithm]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We use a two-pass implementation of merging algorithm. One pass,+-- implemented by merge, performs merging in a top-down manner. Second+-- one, implemented by makeT, ensures that rank invariant of weight+-- biased leftist tree is not violated after merging.+--+-- Notation:+--+--  h1, h2 - heaps being merged+--  p1, p2 - priority of root element in h1 and h2+--  l1     - left  subtree in the first  heap+--  r1     - right subtree in the first  heap+--  l2     - left  subtree in the second heap+--  r2     - right subtree in the second heap+--+-- Merge function analyzes four cases. Two of them are base cases:+--+--    a) h1 is empty - return h2+--+--    b) h2 is empty - return h1+--+-- The other two cases form the inductive definition of merge:+--+--    c) priority p1 is higher than p2 - p1 becomes new root, l1+--       becomes its one child and result of merging r1 with h2+--       becomes the other child:+--+--               p1+--              /  \+--             /    \+--            l1  r1+h2 -- here "+" denotes merging+--+--    d) priority p2 is higher than p2 - p2 becomes new root, l2+--       becomes its one child and result of merging r2 with h1+--       becomes the other child.+--+--               p2+--              /  \+--             /    \+--            l2  r2+h1+--+-- Note that there is no guarantee that rank of r1+h2 (or r2+h1) will+-- be smaller than rank of l1 (or l2). To ensure that merged heap+-- maintains the rank invariant we pass both childred - ie. either l1+-- and r1+h2 or l2 and r2+h1 - to makeT, which creates a new node by+-- inspecting sizes of children and swapping them if necessary.++-- makeT takes an element (Priority) and two heaps (trees). It+-- constructs a new heap with element at the root and two heaps as+-- children. makeT ensures that WBL heap rank invariant is maintained+-- in the newly created tree by reversing left and right subtrees when+-- necessary (note the inversed r and l in the False alternative of+-- case expression).+{-@ makeT   :: p:a -> h1:PHeap {v:a | p <= v} -> h2:PHeap {v:a | p <= v}+            -> {v:PHeap a | realRank v = 1 + realRank h1 + realRank h2} @-}+makeT p l r = case rank l >= rank r of+                True  ->  Node p (1 + rank l + rank r) l r+                False ->  Node p (1 + rank l + rank r) r l++-- merge combines two heaps into one. There are two base cases and two+-- recursive cases - see [Two-pass Merging algorithm]. Recursive cases+-- call makeT to ensure that rank invariant is maintained after+-- merging.+{-@ merge :: (Ord a) => h1:PHeap a -> h2:PHeap a -> {v:PHeap a | realRank v = realRank h1 + realRank h2}  @-}+merge Empty h2 = h2+merge h1 Empty = h1+merge h1@(Node p1 k1 l1 r1) h2@(Node p2 k2 l2 r2) = case p1 < p2 of+  True  -> makeT p1 l1 (merge r1 (Node p2 k2 l2 r2))+  False -> makeT p2 l2 (merge (Node p1 k1 l1 r1) r2)++-- Inserting into a heap is performed by merging that heap with newly+-- created singleton heap.+{-@ insert :: (Ord a) => a -> PHeap a -> PHeap a @-}+insert p h = merge (singleton p) h++-- findMin returns element with highest priority, ie. root+-- element. Here we encounter first serious problem: we can't return+-- anything sensible for empty node.+{-@ findMin :: PHeap a -> a @-}+findMin Empty          = undefined+findMin (Node p _ _ _) = p++-- and write a safer version of findMinM+{-@ findMinM :: PHeap a -> Maybe a @-}+findMinM Empty          = Nothing+findMinM (Node p _ _ _) = Just p++-- deleteMin removes the element with the highest priority by merging+-- subtrees of a root element. Again the case of empty heap is+-- problematic. We could give it semantics by returning Empty, but+-- this just doesn't feel right. Why should we be able to remove+-- elements from an empty heap?+{-@ deleteMin :: (Ord a) => PHeap a -> PHeap a @-}+deleteMin Empty          = undefined -- should we insert empty?+deleteMin (Node _ _ l r) = merge l r++-- As a quick sanity check let's construct some examples. Here's a+-- heap constructed by inserting following priorities into an empty+-- heap: 3, 0, 1, 2.+{-@ heap :: PHeap Int @-}+heap = insert (2 :: Int)+      (insert 1+      (insert 0+      (insert 3 Empty)))++-- Example usage of findMin+findMinInHeap :: Priority+findMinInHeap = findMin heap++-- Example usage of deleteMin+deleteMinFromHeap :: Heap Int+deleteMinFromHeap = deleteMin heap
+ tests/pos/WBL0.hs view
@@ -0,0 +1,177 @@++-----------------------------------------------------------------------+-- Weight-Biased Leftist Heap, verified using LiquidHaskell -----------+-----------------------------------------------------------------------+-- ORIGINAL SOURCE ----------------------------------------------------+-----------------------------------------------------------------------+-- Copyright: 2014, Jan Stolarek, Politechnika Łódzka                --+--                                                                   --+-- License: See LICENSE file in root of the repo                     --+-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps-hs --+--                                                                   --+-- Basic implementation of weight-biased leftist heap. No proofs     --+-- and no dependent types. Uses a two-pass merging algorithm.        --+-----------------------------------------------------------------------++{-@ LIQUID "--no-termination" @-}++module WBL where++type Priority = Int++type Rank     = Int++type Nat      = Int++data Heap a   = Empty | Node { pri   :: a+                             , rnk   :: Rank+                             , left  :: Heap a+                             , right :: Heap a+                             }++{-@ data Heap a <q :: a -> a -> Prop> =+      Empty | Node { pri   :: a+                   , rnk   :: Nat+                   , left  :: {v: Heap<q> (a<q pri>) | ValidRank v}+                   , right :: {v: Heap<q> (a<q pri>) | ValidRank v}+                   }+ @-}++{-@ predicate ValidRank V = okRank V && realRank V = rank V  @-}+{-@ type PHeap a = {v:OHeap a | ValidRank v}                 @-}+{-@ type OHeap a = Heap <{\root v -> root <= v}> a           @-}++{-@ measure okRank @-}+okRank :: Heap a -> Bool+okRank (Empty)        = True+okRank (Node p k l r) = realRank l >= realRank r && k == 1 + realRank l + realRank r++{-@ measure realRank @-}+realRank :: Heap a -> Int+realRank (Empty)        = 0+realRank (Node p k l r) = 1 + realRank l + realRank r++{-@ measure rank @-}+{-@ rank :: h:PHeap a -> {v:Nat | v = realRank h} @-}+rank Empty          = 0+rank (Node _ r _ _) = r+++-- Creates heap containing a single element with a given Priority+{-@ singleton :: a -> PHeap a  @-}+singleton p = Node p 1 Empty Empty++-- Note [Two-pass merging algorithm]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We use a two-pass implementation of merging algorithm. One pass,+-- implemented by merge, performs merging in a top-down manner. Second+-- one, implemented by makeT, ensures that rank invariant of weight+-- biased leftist tree is not violated after merging.+--+-- Notation:+--+--  h1, h2 - heaps being merged+--  p1, p2 - priority of root element in h1 and h2+--  l1     - left  subtree in the first  heap+--  r1     - right subtree in the first  heap+--  l2     - left  subtree in the second heap+--  r2     - right subtree in the second heap+--+-- Merge function analyzes four cases. Two of them are base cases:+--+--    a) h1 is empty - return h2+--+--    b) h2 is empty - return h1+--+-- The other two cases form the inductive definition of merge:+--+--    c) priority p1 is higher than p2 - p1 becomes new root, l1+--       becomes its one child and result of merging r1 with h2+--       becomes the other child:+--+--               p1+--              /  \+--             /    \+--            l1  r1+h2 -- here "+" denotes merging+--+--    d) priority p2 is higher than p2 - p2 becomes new root, l2+--       becomes its one child and result of merging r2 with h1+--       becomes the other child.+--+--               p2+--              /  \+--             /    \+--            l2  r2+h1+--+-- Note that there is no guarantee that rank of r1+h2 (or r2+h1) will+-- be smaller than rank of l1 (or l2). To ensure that merged heap+-- maintains the rank invariant we pass both childred - ie. either l1+-- and r1+h2 or l2 and r2+h1 - to makeT, which creates a new node by+-- inspecting sizes of children and swapping them if necessary.++-- makeT takes an element (Priority) and two heaps (trees). It+-- constructs a new heap with element at the root and two heaps as+-- children. makeT ensures that WBL heap rank invariant is maintained+-- in the newly created tree by reversing left and right subtrees when+-- necessary (note the inversed r and l in the False alternative of+-- case expression).+{-@ makeT   :: p:a -> h1:PHeap {v:a | p <= v} -> h2:PHeap {v:a | p <= v}+            -> {v:PHeap a | realRank v = 1 + realRank h1 + realRank h2} @-}+makeT p l r = case rank l >= rank r of+                True  ->  Node p (1 + rank l + rank r) l r+                False ->  Node p (1 + rank l + rank r) r l++-- merge combines two heaps into one. There are two base cases and two+-- recursive cases - see [Two-pass Merging algorithm]. Recursive cases+-- call makeT to ensure that rank invariant is maintained after+-- merging.+{-@ merge :: (Ord a) => h1:PHeap a -> h2:PHeap a -> {v:PHeap a | realRank v = realRank h1 + realRank h2}  @-}+merge Empty h2 = h2+merge h1 Empty = h1+merge h1@(Node p1 k1 l1 r1) h2@(Node p2 k2 l2 r2) = case p1 < p2 of+  True  -> makeT p1 l1 (merge r1 (Node p2 k2 l2 r2))+  False -> makeT p2 l2 (merge (Node p1 k1 l1 r1) r2)++-- Inserting into a heap is performed by merging that heap with newly+-- created singleton heap.+{-@ insert :: (Ord a) => a -> PHeap a -> PHeap a @-}+insert p h = merge (singleton p) h++-- findMin returns element with highest priority, ie. root+-- element. Here we encounter first serious problem: we can't return+-- anything sensible for empty node.+{-@ findMin :: PHeap a -> a @-}+findMin Empty          = undefined+findMin (Node p _ _ _) = p++-- and write a safer version of findMinM+{-@ findMinM :: PHeap a -> Maybe a @-}+findMinM Empty          = Nothing+findMinM (Node p _ _ _) = Just p++-- deleteMin removes the element with the highest priority by merging+-- subtrees of a root element. Again the case of empty heap is+-- problematic. We could give it semantics by returning Empty, but+-- this just doesn't feel right. Why should we be able to remove+-- elements from an empty heap?+{-@ deleteMin :: (Ord a) => PHeap a -> PHeap a @-}+deleteMin Empty          = undefined -- should we insert empty?+deleteMin (Node _ _ l r) = merge l r++-- As a quick sanity check let's construct some examples. Here's a+-- heap constructed by inserting following priorities into an empty+-- heap: 3, 0, 1, 2.+{-@ heap :: PHeap Int @-}+heap = insert (2 :: Int)+      (insert 1+      (insert 0+      (insert 3 Empty)))++-- Example usage of findMin+findMinInHeap :: Priority+findMinInHeap = findMin heap++-- Example usage of deleteMin+deleteMinFromHeap :: Heap Int+deleteMinFromHeap = deleteMin heap
+ tests/pos/absref-crash.hs view
@@ -0,0 +1,9 @@+module Foo where++data L a = C (L a)++{-@ data L a <p :: L a -> Prop> = C { xs :: L<p> a } @-}++{-@ Lazy foo @-}+foo :: b -> L a+foo x = C $ foo x
+ tests/pos/absref-crash0.hs view
@@ -0,0 +1,36 @@+{-@ LIQUID "--short-names"    @-}+{-@ LIQUID "--no-warnings"    @-}+{-@ LIQUID "--no-termination" @-}+++module Foo (insertSort) where++data List a = N | C a (List a)++infixr 9 `C`++{-@ ifoldr :: forall a b <p :: List a -> b -> Prop>. +                 (xs:_ -> x:_ -> b<p xs> -> b<p(C x xs)>) +               -> b<p N> +               -> ys:List a+               -> b<p ys>                            @-}+ifoldr :: (List a -> a -> b -> b) -> b -> List a -> b+ifoldr = undefined++{-@ data List a <p :: a -> a -> Prop> +     = N | C {x :: a, xs :: List<p> a<p x>} @-}++{-@ type IncrList a = List <{\x y -> x <= y}> a @-} ++{-@ insert :: a -> IncrList a -> IncrList a @-}+insert :: a -> List a -> List a+insert = undefined++{-@ insertSort      :: xs:List a -> {v:IncrList a | true } @-}+insertSort :: List a -> List a+insertSort = undefined++++nil :: List a +nil = N
+ tests/pos/adt0.hs view
@@ -0,0 +1,10 @@+module Adt () where++import Language.Haskell.Liquid.Prelude++data Pair a = P a Int | D a Bool+++goo z = P z z++baz = goo 10
+ tests/pos/alias00.hs view
@@ -0,0 +1,12 @@+module Test0 () where++{-@ type PosInt = {v: Int | v >= 0} @-}++{-@ assert myabs :: Int -> PosInt @-}+myabs   :: Int -> Int+myabs x = if (x > 0) then x else (0 - x)++{-@ type NNList a = {v: [a] | len v > 0} @-}++{-@ assert single :: a -> NNList a @-}+single x = [x]
+ tests/pos/alias01.hs view
@@ -0,0 +1,14 @@+module Test0 () where++{-@ type GeNum a N = {v: a | N <= v} @-}++{-@ type PosInt = GeNum Int {0} @-}++{-@ myabs :: Int -> PosInt @-}+myabs :: Int -> Int+myabs x = if (x > 0) then x else (0 - x)++{-@ incr :: x:Int -> GeNum Int {x} @-}+incr :: Int -> Int+incr x = x + 1+
+ tests/pos/alphaconvert-List.hs view
@@ -0,0 +1,145 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}+{-@ LIQUID "--fullcheck"      @-}+{-@ LIQUID "--maxparams=3"    @-}++-- | An example from "A Relational Framework for Higher-Order Shape Analysis",+--   by Gowtham Kaki Suresh Jagannathan, ICFP 2014.++module AlphaConvert (subst, alpha) where++import Prelude hiding ((++), elem)+import Data.Set (Set (..))+import Language.Haskell.Liquid.Prelude   ++alpha  :: [Bndr] -> Expr -> Expr +subst  :: Expr -> Bndr -> Expr -> Expr+maxs   :: [Int] -> Int +lemma1 :: Int -> [Int] -> Bool+fresh  :: [Bndr] -> Bndr+free   :: Expr -> [Bndr]++---------------------------------------------------------------------+-- | Datatype Definition --------------------------------------------+---------------------------------------------------------------------++type Bndr +  = Int++data Expr +  = Var Bndr  +  | Abs Bndr Expr+  | App Expr Expr++{-@ measure fv       :: Expr -> (Set Bndr)+    fv (Var x)       = (Set_sng x)+    fv (Abs x e)     = (Set_dif (fv e) (Set_sng x))+    fv (App e a)     = (Set_cup (fv e) (fv a)) +  @-}++{-@ measure isAbs    :: Expr -> Prop+    isAbs (Var v)    = false+    isAbs (Abs v e)  = true+    isAbs (App e a)  = false             +  @-}++{-@ predicate AddV E E2 X E1   = fv E = Set_cup (Set_dif (fv E2) (Set_sng X)) (fv E1) @-}+{-@ predicate EqV E1 E2        = fv E1 = fv E2                                        @-}+{-@ predicate Occ X E          = Set_mem X (fv E)                                     @-}+{-@ predicate Subst E E1 X E2  = if (Occ X E2) then (AddV E E2 X E1) else (EqV E E2)  @-}++----------------------------------------------------------------------------+-- | Part 5: Capture Avoiding Substitution ---------------------------------+----------------------------------------------------------------------------+{-@ subst :: e1:Expr -> x:Bndr -> e2:Expr -> {e:Expr | Subst e e1 x e2} @-} +----------------------------------------------------------------------------++subst e1 x e2@(Var y)+  | x == y                = e1+  | otherwise             = e2++subst e1 x (App ea eb)    = App ea' eb'+  where+    ea'                   = subst e1 x ea+    eb'                   = subst e1 x eb++subst e1 x e2@(Abs y e)  +  | x == y                = e2+  | y `elem` xs           = subst e1 x (alpha xs e2) +  | otherwise             = Abs y      (subst e1 x e)+     where+      xs                  = free e1 ++----------------------------------------------------------------------------+-- | Part 4: Alpha Conversion ----------------------------------------------+----------------------------------------------------------------------------+{-@ alpha :: ys:[Bndr] -> e:{Expr | isAbs e} -> {v:Expr | EqV v e} @-}+----------------------------------------------------------------------------+alpha ys (Abs x e) = Abs x' (subst (Var x') x e)+  where +    xs             = free e+    x'             = fresh (x : ys ++ xs)++alpha _  _         = liquidError "never"+++----------------------------------------------------------------------------+-- | Part 3: Fresh Variables -----------------------------------------------+----------------------------------------------------------------------------+{-@ fresh :: xs:[Bndr] -> {v:Bndr | NotElem v xs} @-}+----------------------------------------------------------------------------+fresh bs = liquidAssert (lemma1 n bs) n+  where +    n    = 1 + maxs bs++{-@ maxs :: xs:_ -> {v:_ | v = maxs xs} @-}+maxs ([])   = 0+maxs (x:xs) = if (x > maxs xs) then x else (maxs xs) + + +{-@ measure maxs :: [Int] -> Int +    maxs ([])   = 0+    maxs (x:xs) = if (x > maxs xs) then x else (maxs xs) +  @-}++{-@ lemma1 :: x:Int -> xs:{[Int] | x > maxs xs} -> {v:Bool | Prop v && NotElem x xs} @-}+lemma1 _ []     = True +lemma1 x (_:ys) = lemma1 x ys +++----------------------------------------------------------------------------+-- | Part 2: Free Variables ------------------------------------------------+----------------------------------------------------------------------------++----------------------------------------------------------------------------+{-@ free         :: e:Expr -> {v:[Bndr] | elts v = fv e} @-}+----------------------------------------------------------------------------+free (Var x)     = [x]+free (App e e')  = free e ++ free e'+free (Abs x e)   = free e \\ x+++----------------------------------------------------------------------------+-- | Part I: Sets with Lists -----------------------------------------------+----------------------------------------------------------------------------++{-@ predicate IsCup X Y Z  = elts X = Set_cup (elts Y) (elts Z)    @-}+{-@ predicate IsDel X Y Z  = elts X = Set_dif (elts Y) (Set_sng Z) @-}+{-@ predicate Elem  X Ys   = Set_mem X (elts Ys)                   @-}+{-@ predicate NotElem X Ys = not (Elem X Ys)                       @-}++{-@ (++)      :: xs:[a] -> ys:[a] -> {v:[a] | IsCup v xs ys}  @-}+[]     ++ ys  = ys+(x:xs) ++ ys  = x : (xs ++ ys)++{-@ (\\)      :: (Eq a) => xs:[a] -> y:a -> {v:[a] | IsDel v xs y} @-}+xs   \\ y     = [x | x <- xs, x /= y]++{-@ elem      :: (Eq a) => x:a -> ys:[a] -> {v:Bool | Prop v <=> Elem x ys} @-}+elem x []     = False+elem x (y:ys) = x == y || elem x ys+ +{-@ measure elts :: [a] -> (Set a) +    elts ([])    = {v | Set_emp v}+    elts (x:xs)  = {v | v = Set_cup (Set_sng x) (elts xs) }+  @-}
+ tests/pos/alphaconvert-Set.hs view
@@ -0,0 +1,104 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}+{-@ LIQUID "--fullcheck"      @-}+{-@ LIQUID "--maxparams=3"    @-}++module AlphaConvert (subst) where++import qualified Data.Set as S++import Language.Haskell.Liquid.Prelude   ++freshS  :: S.Set Bndr -> Bndr+alpha   :: S.Set Bndr -> Expr -> Expr +subst   :: Expr -> Bndr -> Expr -> Expr+free    :: Expr -> S.Set Bndr+++---------------------------------------------------------------------+-- | Datatype Definition --------------------------------------------+---------------------------------------------------------------------++type Bndr +  = Int++data Expr +  = Var Bndr  +  | Abs Bndr Expr+  | App Expr Expr++{-@ measure fv       :: Expr -> (S.Set Bndr)+    fv (Var x)       = (Set_sng x)+    fv (Abs x e)     = (Set_dif (fv e) (Set_sng x))+    fv (App e a)     = (Set_cup (fv e) (fv a)) +  @-}++{-@ measure isAbs    :: Expr -> Prop+    isAbs (Var v)    = false+    isAbs (Abs v e)  = true+    isAbs (App e a)  = false             +  @-}++{-@ predicate Elem  X Ys       = Set_mem X Ys               @-}+{-@ predicate NotElem X Ys     = not (Elem X Ys)            @-}+{-@ predicate AddV E E2 X E1   = fv E = Set_cup (Set_dif (fv E2) (Set_sng X)) (fv E1) @-}+{-@ predicate EqV E1 E2        = fv E1 = fv E2                                        @-}+{-@ predicate Occ X E          = Set_mem X (fv E)                                     @-}+{-@ predicate Subst E E1 X E2  = if (Occ X E2) then (AddV E E2 X E1) else (EqV E E2)  @-}++----------------------------------------------------------------------------+-- | Part 5: Capture Avoiding Substitution ---------------------------------+----------------------------------------------------------------------------+{-@ subst :: e1:Expr -> x:Bndr -> e2:Expr -> {e:Expr | Subst e e1 x e2} @-} +----------------------------------------------------------------------------++subst e' x e@(Var y)+  | x == y                = e' +  | otherwise             = e++subst e' x (App ea eb)    = App ea' eb'+  where+    ea'                   = subst e' x ea+    eb'                   = subst e' x eb++subst e1 x e2@(Abs y e)   +  | x == y                = e2+  | y `S.member` xs       = subst e1 x (alpha xs e2) +  | otherwise             = Abs y (subst e1 x e)+    where+      xs                  = free e1  ++----------------------------------------------------------------------------+-- | Part 4: Alpha Conversion ----------------------------------------------+----------------------------------------------------------------------------+{-@ alpha :: ys:(S.Set Bndr) -> e:{Expr | isAbs e} -> {v:Expr | EqV v e} @-}+----------------------------------------------------------------------------+alpha ys (Abs x e) = Abs x' (subst (Var x') x e)+  where +    xs             = free e+    x'             = freshS zs+    zs             = S.insert x (S.union ys xs)++alpha _  _         = liquidError "never"+++----------------------------------------------------------------------------+-- | Part 3: Fresh Variables -----------------------------------------------+----------------------------------------------------------------------------+{-@ freshS :: xs:(S.Set Bndr) -> {v:Bndr | NotElem v xs} @-}+----------------------------------------------------------------------------+freshS xs = undefined+++----------------------------------------------------------------------------+-- | Part 2: Free Variables ------------------------------------------------+----------------------------------------------------------------------------++----------------------------------------------------------------------------+{-@ free         :: e:Expr -> {v : S.Set Bndr | v = fv e} @-}+----------------------------------------------------------------------------+free (Var x)     = S.singleton x+free (App e e')  = S.union  (free e) (free e')+free (Abs x e)   = S.delete x (free e)++
+ tests/pos/anfbug.hs view
@@ -0,0 +1,21 @@+{-@ LIQUID "--no-termination" @-}++module Tx (x,y) where++import Control.Exception (assert)++-- TransformRec BUG: this causes a temporary to get hoisted out of scope+getTails' :: Int -> [[a]] -> [[a]]+getTails' n xss = assert (n > 0) [t | (_:t) <- xss]++x = getTails' 1 []++-- HACK give hints for internal variables....+{- Decrease ds_d258 3 @-}+{- Decrease ds_d25g 3 @-}++-- TransformRec BUG: this causes some wierd unused variable error (occurrence of DEAD ID)?+getTails'' :: Int -> [[a]] -> [[a]]+getTails'' n xss = [t | (_:t) <- xss]++y = getTails'' 1 []
+ tests/pos/anftest.hs view
@@ -0,0 +1,29 @@+module AnfWierd () where++-- xs :: [Int]+-- xs = let x0 = 0+--          x1 = 1+--          x2 = 2+--          x3 = 3+--          x4 = 4+--          x5 = 5+--          x6 = 6+--          x7 = 7+--          x8 = 8+--          x9 = 9+--      in [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9]++xs :: [Int]+xs = let x0 = 0+         x1 = 1+     in [x0, x1]++ys :: [Int]+ys = [y0, y1]+     where y0 = 0+           y1 = 1++{-@ incr :: x: Int -> {v: Int | v > x} @-}+incr :: Int -> Int+incr y = y + length xs +
+ tests/pos/bangPatterns.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE BangPatterns #-}+module Min where++import Data.IORef++import Language.Haskell.Liquid.Prelude++foo :: IORef a -> IORef a+{-@ foo :: x:IORef a -> {v:IORef a |  v = x} @-}+foo !x = x
+ tests/pos/bar.hs view
@@ -0,0 +1,5 @@+module Bar where++import Foo++foo = bar
+ tests/pos/bounds1.hs view
@@ -0,0 +1,14 @@+module Fixme where++{-+Interesting example as subtyping of bounds is instantiated+with function types!+-}++zipWith :: (b -> Char -> a) +        -> b -> b -> a+zipWith f =  (bar . f)++bar :: (Char -> c) -> a -> c+bar = undefined+
+ tests/pos/case-lambda-join.hs view
@@ -0,0 +1,26 @@+{-@ LIQUID "--no-termination"   @-}++module Foo where++import Language.Haskell.Liquid.Prelude+import Data.Set (Set (..))++data RBTree a = Leaf | Node Color a !(RBTree a) !(RBTree a)+data Color    = B | R deriving (Eq)++{-@ rbalBAD, rbalOK :: k:_ -> l:_ -> r:_ -> {v:_ | Join v k l r} @-}+rbalBAD x l r = case r of+  Node R y b (Node R z c d) -> error "ASD" -- Node R y (Node B x l b) (Node B z c d)+  Node R z (Node R y b c) d -> Node R y (Node B x l b) (Node B z c d)++rbalOK x l r = case r of+  -- Node R y b (Node R z c d) -> Node R y (Node B x l b) (Node B z c d)+  Node R z (Node R y b c) d -> Node R y (Node B x l b) (Node B z c d)++{-@ measure elems :: RBTree a -> (Set a)+    elems (Leaf)         = (Set_empty 0)+    elems (Node c k l r) = (Set_cup (Set_sng k) (Set_cup (elems l) (elems r))) +  @-}++{-@ predicate Union V L R  = elems V = Set_cup (elems L) (elems R)                       @-}+{-@ predicate Join V X L R = elems V = Set_cup (Set_sng X) (Set_cup (elems L) (elems R)) @-}
+ tests/pos/cmptag0.hs view
@@ -0,0 +1,13 @@+module Test () where++{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}++{-@ foo :: (Ord a) => z:a -> OList a -> [{v:a | z <= v}] @-}+foo y xs = bar y xs++bar :: (Ord a) => a -> [a] -> [a]+bar y []     = []+bar y z@(x:xs) = case compare y x of +                   EQ -> xs+                   GT -> bar y xs+                   LT -> x:xs
+ tests/pos/compare.hs view
@@ -0,0 +1,13 @@+module Cmp () where++import Language.Haskell.Liquid.Prelude++foo x y+ = case compare x y of +    EQ -> liquidAssertB (x == y)+    LT -> liquidAssertB (x < y)+    GT -> liquidAssertB (x > y)++prop = foo n m +  where n = choose 0+        m = choose 1
+ tests/pos/compare1.hs view
@@ -0,0 +1,12 @@+module Cmp () where++import Language.Haskell.Liquid.Prelude++foo x y+ | compare x y == EQ = liquidAssertB (x == y)+ | compare x y == LT = liquidAssertB (x < y)+ | compare x y == GT = liquidAssertB (x >  y)++prop = foo n m +  where n = choose 0+        m = choose 1
+ tests/pos/compare2.hs view
@@ -0,0 +1,11 @@+module Cmp () where++import Language.Haskell.Liquid.Prelude++foo x y+ | compare x y == EQ = liquidAssertB (x == y)+ | otherwise         = liquidAssertB (True)++prop = foo n m +  where n = choose 0+        m = choose 1
+ tests/pos/comprehensionTerm.hs view
@@ -0,0 +1,27 @@+{-@ LIQUID "--no-termination" @-}+module Blank (quickSort, foo, qsort) where++-- This is a blank file.++{- foo :: xs:[Int] -> {v:[Int] | (len v) = (len xs)} @-}+foo :: [Int] -> [Int]+foo []     = []+foo (x:xs) = (x+1) : foo [y | y <- xs] ++{- qsort :: (Ord a) => xs:[a] -> {v:[a] | (len v) <= (len xs)} @-}+qsort []     = []+qsort (x:xs) = x : qsort [y | y <- xs, y < x]++{-@ quickSort    :: (Ord a) => [a] -> SList a @-}+quickSort []       = []+quickSort xs@(x:_) = append x lts gts +  where +    lts          = quickSort [y | y <- xs, y < x]+    gts          = quickSort [z | z <- xs, z >= x]++{- append :: k:a -> SList {v:a | v<k} -> SList {v:a | v >= k} -> SList a @-}+append k []     ys  = k : ys+append k (x:xs) ys  = x : append k xs ys++{-@ type SList a = [a]<{\x v -> (v >= x)}> @-}+
+ tests/pos/contra0.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}++module Foo () where++import Language.Haskell.Liquid.Prelude (liquidAssert)+import Data.IORef+++{-@ data variance IO bivariant @-}+{-@ data variance IORef bivariant @-}++job :: IO () +job = do+  p <- newIORef (0 :: Int)+  writeIORef p 10+  v <- readIORef p+  liquidAssert (v >= 0) $ return ()
+ tests/pos/coretologic.hs view
@@ -0,0 +1,19 @@+module CoreToLog where++import Data.Set++-- ISSUE: can we please allow things like `empty` to also+-- appear in type and alias specifications, not just in+-- measures as in `goo` below?++{-@ type IsEmp a = {v:[a] | Data.Set.elems v = Data.Set.empty } @-}++{-@ foo :: IsEmp Int @-}+foo :: [Int]+foo = []+++{-@ measure goo @-}+goo        :: (Ord a) => [a] -> Set a+goo []     = empty+goo (x:xs) = (singleton x) `union` (goo xs)
+ tests/pos/data2.hs view
@@ -0,0 +1,26 @@+module Range (prop_rng1) where++import Control.Applicative+import Language.Haskell.Liquid.Prelude++data LL a = N | C { head :: a, tail :: (LL a) }+{-@ data LL [llen] a = N | C { head :: a, tail :: (LL a) } @-}++{-@ measure llen :: (LL a) -> Int+    llen(N)      = 0+    llen(C x xs) = 1 + (llen xs) +  @-}++{-@ invariant {v:LL a | (llen v) >= 0} @-}++--instance Functor LL where+--  fmap f N                = N+--  fmap f (C jhala jhalas) = C (f jhala) (fmap f jhalas)++lmap f N = N+lmap f (C jhala jhalas) = C (f jhala) (lmap f jhalas)++range :: Int -> Int -> LL Int+range i j = C i N++prop_rng1 n   = (liquidAssertB . (0 <=)) `lmap` range 0 n
+ tests/pos/dataConQuals.hs view
@@ -0,0 +1,27 @@+module Quals () where++data G = G { gx :: Int, gy :: Int }+++-- | We should scrape qualifiers from data definitions; why doesn't it happen+--   "automatically" from the data-con-function signature anyway?++{-@ data G = G { gx :: Int, gy :: {v:Int | v = gx + 5} } @-}++poo :: Int -> Int+poo n = n + 5++-- | `goo` fails because `poo` doesn't have the type `n -> n + 5` because no qual...++{-@ goo :: {v:Int | v = 105} @-}+goo :: Int+goo = poo 100++-- | But `goo` succeeds if we add `chump` into the mix, because+--   it picks up the qualifers.++{- chump :: z:Int -> {v:Int | v = z + 5} @-}+chump   :: Int -> Int+chump z = z + 5++
+ tests/pos/datacon-inv.hs view
@@ -0,0 +1,8 @@+module Zoo where++data T =  A | B++{-@ invariant {v:T | (v = A || v = B)} @-}++thisIsA = A+thisIsB = B
+ tests/pos/datacon0.hs view
@@ -0,0 +1,29 @@+module Range () where++import Language.Haskell.Liquid.Prelude++data Foo a = F a a a ++data LL a = N | C a (LL a)++{-@ data LL [llen] a = N | C (x::a) (xs::(LL a)) @-}++{-@ invariant {v:LL a | (llen v) >= 0} @-}++{-@ measure llen :: (LL a) -> Int +    llen(N)      = 0+    llen(C x xs) = 1 + (llen xs)+  @-}++lmap f N = N+lmap f (C x xs) = C (f x) (lmap f xs)++range :: Int -> Int -> LL Int+range i j = C i N++n = choose 0++prop_rng1 = (liquidAssertB . (0 <=)) `lmap` range 0 n++--poo :: LL Int+poo = C (1 :: Int)
+ tests/pos/datacon1.hs view
@@ -0,0 +1,7 @@+module DC () where++data Foo a = F a a a ++z :: Foo Int+z = F 1 2 3 +
+ tests/pos/deepmeas0.hs view
@@ -0,0 +1,28 @@+module DeepMeasure () where++import Language.Haskell.Liquid.Prelude (liquidError)+import Data.Set++{-@ measure getfst :: (a, b) -> a+    getfst (x, y) = x+  @-}++{-@ measure keys :: [(k, v)] -> (Set k) +    keys ([])   = {v | Set_emp v }+    keys (x:xs) = {v | (v = (Set_cup (Set_sng (getfst x)) (keys xs))) }+  @-}++{-@ getKeys :: kvs:[(a, b)] -> {v:[a] | ((keys kvs) = (listElts v))} @-}+getKeys []           = [] +getKeys ((x,_) : xs) = x : getKeys xs++{-@ klookup :: forall k v. (Eq k) => k:k -> {v: [(k, v)] | (Set_mem k (keys v))} -> v @-}++klookup k ((k',v):kvs)+  | k == k'          = v+  | otherwise        = klookup k kvs+klookup _ []         = liquidError "Never!"++++
+ tests/pos/deppair0.hs view
@@ -0,0 +1,13 @@+module Niki () where++import Language.Haskell.Liquid.Prelude++incr x = x + 1++baz x = (x, incr x)++prop :: Bool+prop = chk $ baz n+  where n = choose 100++chk (x, y) = liquidAssertB (x < y)
+ tests/pos/deppair1.hs view
@@ -0,0 +1,19 @@+module Niki () where++import Language.Haskell.Liquid.Prelude++incr  :: Int -> Int+incr x = x + 1+++-- THIS DOES NOT WORK: baz  :: Int -> (y: Int, {v: Int | v > y}) @-}+-- BUT THIS DOES+{-@ baz  :: Int -> (Int, Int)<{\fld v -> fld < v }> @-}+baz x = (x, incr x)+++{-@ goo :: Int -> (Int, Int, Int)<{\x v -> x < v}, {\x y v -> true}> @-}+goo x = (x, y, z)+  where +    y = incr x+    z = incr y
+ tests/pos/deptup.hs view
@@ -0,0 +1,29 @@+module Deptup0 () where++import Language.Haskell.Liquid.Prelude++{-@ data Pair a b <p :: x0:a -> x1:b -> Prop> = P (x :: a) (y :: b<p x>) @-} +data Pair a b = P a b+++{-- TODO: mkP :: forall a b <p :: a -> b -> Prop>. x: a -> y: b<p x> -> Pair <p> a b  --}++mkP :: a -> a -> Pair a a +mkP x y = P x y++incr x = x + 1++baz x  = mkP x (incr x)++chk (P x y) = liquidAssertB (x < y)++prop = chk $ baz n+  where n = choose 100++bazList  xs = map baz xs++n           = choose 0++xs          = [0,1,2,3,4]++prop_baz    = map chk $ bazList xs
+ tests/pos/deptup0.hs view
@@ -0,0 +1,17 @@+module Niki () where++import Language.Haskell.Liquid.Prelude++{-@ data Pair a b <p :: x0:a -> x1:b -> Prop> = P (x :: a) (y :: b<p x>) @-} +data Pair a b = P a b++incr x = x + 1++baz x = P x $ incr x ++prop :: Bool+prop = chk $ baz n+  where n = choose 100++chk (P x y) = liquidAssertB (x < y)+
+ tests/pos/deptup1.hs view
@@ -0,0 +1,19 @@+module Deptup () where++import Language.Haskell.Liquid.Prelude++{-@ data Pair a b <p :: x0:a -> x1:b -> Prop> = P (x :: a) (y :: b<p x>) @-} +data Pair a b = P a b++incr        :: Int -> Int+incr x      = x + 1++baz x       = P x (incr x)++bazList xs  = map baz xs ++n           = choose 0+xs          = [0..n]++chk (P x y) = liquidAssertB (x < y)+prop_baz    = map chk $ bazList xs
+ tests/pos/deptup3.hs view
@@ -0,0 +1,19 @@+module Deptup () where++import Language.Haskell.Liquid.Prelude++data Pair a b = P a b++incr :: Int -> Int+incr x = x + 1++baz    :: Int -> Pair Int Int+baz x  = P x (incr x)++n :: Int+n           = choose 0++prop_baz    = chk (baz n) ++chk :: Pair Int Int -> Bool								+chk (P x y) = liquidAssertB (x <= y)
+ tests/pos/deptupW.hs view
@@ -0,0 +1,21 @@+module Deptup0 () where++import Language.Haskell.Liquid.Prelude++{-@ data Pair a b <p :: x0:a -> x1:b -> Prop> = P (x :: a) (y :: b<p x>) @-} +data Pair a b = P a b++{-@ mkP :: forall a <q :: y0:a -> y1:a -> Prop>. x: a -> y: a<q x> -> Pair <q> a a @-}+mkP :: a -> a -> Pair a a+mkP x y = P x y ++incr :: Int -> Int+incr x = x + 1++baz x = mkP x (incr x)++chk :: Pair Int Int -> Bool+chk (P x y) = liquidAssertB (x < y)++prop = chk $ baz n+  where n = choose 100
+ tests/pos/duplicate-bind.hs view
@@ -0,0 +1,6 @@+module Meas where++import Language.Haskell.Liquid.Prelude++insert key value [] = [(key, value)]+insert _ _ _        = error ""
+ tests/pos/elements.hs view

file too large to diff

+ tests/pos/elems.hs view

file too large to diff

+ tests/pos/eqelems.hs view

file too large to diff

+ tests/pos/ex0.hs view

file too large to diff

+ tests/pos/ex01.hs view

file too large to diff

+ tests/pos/ex1.hs view

file too large to diff

+ tests/pos/exp0.hs view

file too large to diff

+ tests/pos/extype.hs view

file too large to diff

+ tests/pos/failName.hs view

file too large to diff

+ tests/pos/filterAbs.hs view

file too large to diff

+ tests/pos/foldN.hs view

file too large to diff

+ tests/pos/foldr.hs view

file too large to diff

+ tests/pos/for.hs view

file too large to diff

+ tests/pos/forloop.hs view

file too large to diff

+ tests/pos/gadtEval.hs view

file too large to diff

+ tests/pos/gimme.hs view

file too large to diff

+ tests/pos/go.hs view

file too large to diff

+ tests/pos/go_ugly_type.hs view

file too large to diff

+ tests/pos/grty0.hs view

file too large to diff

+ tests/pos/grty1.hs view

file too large to diff

+ tests/pos/grty2.hs view

file too large to diff

+ tests/pos/grty3.hs view

file too large to diff

+ tests/pos/hello.hs view

file too large to diff

+ tests/pos/hole-app.hs view

file too large to diff

+ tests/pos/imp0.hs view

file too large to diff

+ tests/pos/implies.hs view

file too large to diff

+ tests/pos/infix.hs view

file too large to diff

+ tests/pos/initarray.hs view

file too large to diff

+ tests/pos/inline.hs view

file too large to diff

+ tests/pos/inline1.hs view

file too large to diff

+ tests/pos/invlhs.hs view

file too large to diff

+ tests/pos/ite.hs view

file too large to diff

+ tests/pos/ite1.hs view

file too large to diff

+ tests/pos/kmp.hs view

file too large to diff

+ tests/pos/kmpIO.hs view

file too large to diff

+ tests/pos/kmpVec.hs view

file too large to diff

+ tests/pos/lets.hs view

file too large to diff

+ tests/pos/lex.hs view

file too large to diff

+ tests/pos/listAnf.hs view

file too large to diff

+ tests/pos/listSet.hs view

file too large to diff

+ tests/pos/listSetDemo.hs view

file too large to diff

+ tests/pos/malformed0.hs view

file too large to diff

+ tests/pos/mapTvCrash.hs view

file too large to diff

+ tests/pos/mapreduce-bare.hs view

file too large to diff

+ tests/pos/mapreduce.hs view

file too large to diff

+ tests/pos/maps.hs view

file too large to diff

+ tests/pos/maps1.hs view

file too large to diff

+ tests/pos/maybe.hs view

file too large to diff

+ tests/pos/maybe0.hs view

file too large to diff

+ tests/pos/maybe00.hs view

file too large to diff

+ tests/pos/maybe000.hs view

file too large to diff

+ tests/pos/maybe1.hs view

file too large to diff

+ tests/pos/maybe2.hs view

file too large to diff

+ tests/pos/maybe3.hs view

file too large to diff

+ tests/pos/maybe4.hs view

file too large to diff

+ tests/pos/meas0.hs view

file too large to diff

+ tests/pos/meas00.hs view

file too large to diff

+ tests/pos/meas00a.hs view

file too large to diff

+ tests/pos/meas0a.hs view

file too large to diff

+ tests/pos/meas1.hs view

file too large to diff

+ tests/pos/meas10.hs view

file too large to diff

+ tests/pos/meas11.hs view

file too large to diff

+ tests/pos/meas2.hs view

file too large to diff

+ tests/pos/meas3.hs view

file too large to diff

+ tests/pos/meas4.hs view

file too large to diff

+ tests/pos/meas5.hs view

file too large to diff

+ tests/pos/meas6.hs view

file too large to diff

+ tests/pos/meas7.hs view

file too large to diff

+ tests/pos/meas8.hs view

file too large to diff

+ tests/pos/meas9.hs view

file too large to diff

+ tests/pos/modTest.hs view

file too large to diff

+ tests/pos/monad1.hs view

file too large to diff

+ tests/pos/monad2.hs view

file too large to diff

+ tests/pos/monad5.hs view

file too large to diff

+ tests/pos/monad6.hs view

file too large to diff

+ tests/pos/monad7.hs view

file too large to diff

+ tests/pos/multi-pred-app-00.hs view

file too large to diff

+ tests/pos/mutrec.hs view

file too large to diff

+ tests/pos/niki.hs view

file too large to diff

+ tests/pos/niki1.hs view

file too large to diff

+ tests/pos/nullterm.hs view

file too large to diff

+ tests/pos/pair.hs view

file too large to diff

+ tests/pos/pair0.hs view

file too large to diff

+ tests/pos/pair00.hs view

file too large to diff

+ tests/pos/pargs.hs view

file too large to diff

+ tests/pos/pargs1.hs view

file too large to diff

+ tests/pos/partial-tycon.hs view

file too large to diff

+ tests/pos/partialmeasure.hs view

file too large to diff

+ tests/pos/poly0.hs view

file too large to diff

+ tests/pos/poly1.hs view

file too large to diff

+ tests/pos/poly2-degenerate.hs view

file too large to diff

+ tests/pos/poly2.hs view

file too large to diff

+ tests/pos/poly3.hs view

file too large to diff

+ tests/pos/poly3a.hs view

file too large to diff

+ tests/pos/poly4.hs view

file too large to diff

+ tests/pos/polyfun.hs view

file too large to diff

+ tests/pos/polyqual.hs view

file too large to diff

+ tests/pos/poslist.hs view

file too large to diff

+ tests/pos/poslist_dc.hs view

file too large to diff

+ tests/pos/pragma0.hs view

file too large to diff

+ tests/pos/pred.hs view

file too large to diff

+ tests/pos/primInt0.hs view

file too large to diff

+ tests/pos/profcrasher.hs view

file too large to diff

+ tests/pos/propmeasure.hs view

file too large to diff

+ tests/pos/qualTest.hs view

file too large to diff

+ tests/pos/range.hs view

file too large to diff

+ tests/pos/range1.hs view

file too large to diff

+ tests/pos/rangeAdt.hs view

file too large to diff

+ tests/pos/rec_annot_go.hs view

file too large to diff

+ tests/pos/record0.hs view

file too large to diff

+ tests/pos/record1.hs view

file too large to diff

+ tests/pos/risers.hs view

file too large to diff

+ tests/pos/scanr.hs view

file too large to diff

+ tests/pos/selfList.hs view

file too large to diff

+ tests/pos/spec0.hs view

file too large to diff

+ tests/pos/stacks0.hs view

file too large to diff

+ tests/pos/state00.hs view

file too large to diff

+ tests/pos/stateInvarint.hs view

file too large to diff

+ tests/pos/string00.hs view

file too large to diff

+ tests/pos/tagBinder.hs view

file too large to diff

+ tests/pos/take.hs view

file too large to diff

+ tests/pos/term0.hs view

file too large to diff

+ tests/pos/test0.hs view

file too large to diff

+ tests/pos/test00-int.hs view

file too large to diff

+ tests/pos/test00.hs view

file too large to diff

+ tests/pos/test000.hs view

file too large to diff

+ tests/pos/test00b.hs view

file too large to diff

+ tests/pos/test00c.hs view

file too large to diff

+ tests/pos/test1.hs view

file too large to diff

+ tests/pos/test2.hs view

file too large to diff

+ tests/pos/testRec.hs view

file too large to diff

+ tests/pos/top0.hs view

file too large to diff

+ tests/pos/trans.hs view

file too large to diff

+ tests/pos/transTAG.hs view

file too large to diff

+ tests/pos/transpose.hs view

file too large to diff

+ tests/pos/tup0.hs view

file too large to diff

+ tests/pos/tupparse.hs view

file too large to diff

+ tests/pos/tyExpr.hs view

file too large to diff

+ tests/pos/tyclass0.hs view

file too large to diff

+ tests/pos/tyfam0.hs view

file too large to diff

+ tests/pos/tyvar.hs view

file too large to diff

+ tests/pos/unusedtyvars.hs view

file too large to diff

+ tests/pos/vecloop.hs view

file too large to diff

+ tests/pos/vector0.hs view

file too large to diff

+ tests/pos/vector00.hs view

file too large to diff

+ tests/pos/vector1.hs view

file too large to diff

+ tests/pos/vector1a.hs view

file too large to diff

+ tests/pos/vector1b.hs view

file too large to diff

+ tests/pos/vector2.hs view

file too large to diff

+ tests/pos/wrap0.hs view

file too large to diff

+ tests/pos/wrap1.hs view

file too large to diff

+ tests/pos/zipSO.hs view

file too large to diff

+ tests/pos/zipW.hs view

file too large to diff

+ tests/pos/zipW1.hs view

file too large to diff

+ tests/pos/zipW2.hs view

file too large to diff

+ tests/pos/zipper.hs view

file too large to diff

+ tests/pos/zipper0.hs view

file too large to diff

tests/test.hs view

file too large to diff