+\end{verbatim}
+
+
+\begin{code}
+matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All NPlusKPats, for the *same* literal k
+matchNPlusKPats (var:vars) ty (eqn1:eqns)
+ = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
+ ; ge_expr <- dsExpr ge
+ ; minus_expr <- dsExpr minus
+ ; lit_expr <- dsOverLit lit
+ ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
+ minusk_expr = mkApps minus_expr [Var var, lit_expr]
+ (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
+ ; match_result <- match vars ty eqns'
+ ; return (mkGuardedMatchResult pred_expr $
+ mkCoLetMatchResult (NonRec n1 minusk_expr) $
+ adjustMatchResult (foldr1 (.) wraps) $
+ match_result) }
+ where
+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
+ = (wrapBind n n1, eqn { eqn_pats = pats })
+ -- The wrapBind is a no-op for the first equation
+ shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
+
+matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
+\end{code}
diff --git a/Language/Haskell/Liquid/DiffCheck.hs b/Language/Haskell/Liquid/DiffCheck.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/DiffCheck.hs
@@ -0,0 +1,213 @@
+-- | 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.
+
+module Language.Haskell.Liquid.DiffCheck (slice, save, thin) where
+
+import Control.Applicative ((<$>))
+import Data.Algorithm.Diff
+import CoreSyn
+import Name
+import SrcLoc
+-- import Outputable
+import Var
+import qualified Data.HashSet as S
+import qualified Data.HashMap.Strict as M
+import qualified Data.List as L
+import Data.Function (on)
+import System.Directory (copyFile, doesFileExist)
+
+import Language.Fixpoint.Files
+import Language.Haskell.Liquid.GhcInterface
+import Language.Haskell.Liquid.GhcMisc
+import Text.Parsec.Pos (sourceLine)
+import Control.Monad(forM)
+
+
+-------------------------------------------------------------------------
+-- Data Types -----------------------------------------------------------
+-------------------------------------------------------------------------
+
+data Def = D { start :: Int
+ , end :: Int
+ , binder :: Var
+ }
+ deriving (Eq, Ord)
+
+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
+-- and their transitive dependencies.
+-------------------------------------------------------------------------
+slice :: FilePath -> [CoreBind] -> IO [CoreBind]
+-------------------------------------------------------------------------
+slice target cbs
+ = do let saved = extFileName Saved target
+ ex <- doesFileExist saved
+ if ex then do is <- {- tracePpr "INCCHECK: changed lines" <$> -} lineDiff target saved
+ let dfs = coreDefs cbs
+ forM dfs $ putStrLn . ("INCCHECK: Def " ++) . show
+ let xs = diffVars is dfs
+ return $ thin cbs xs
+ else return cbs
+
+-- | `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 cbs xs = filterBinds cbs ys
+ where
+ ys = dependentVars (coreDeps cbs) $ S.fromList xs
+
+-------------------------------------------------------------------------
+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
+
+-------------------------------------------------------------------------
+coreDefs :: [CoreBind] -> [Def]
+-------------------------------------------------------------------------
+coreDefs cbs = L.sort [D l l' x | b <- cbs, let (l, l') = coreDef b, x <- bindersOf 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
+-- 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`)
+-- 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
+-- 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.
+
+meetSpans b Nothing _
+ = error $ "INCCHECK: cannot find span for top-level binders: "
+ ++ showPpr (bindersOf b)
+ ++ "\nRun without --diffcheck option\n"
+
+meetSpans b (Just (l,l')) Nothing
+ = (l, l')
+meetSpans b (Just (l,l')) (Just (m,_))
+ = (max l m, l')
+
+-- coreDef b = lineSpan $ catSpans b $ map getSrcSpan
+-- $ tracePpr ("INCCHECK: letvars " ++ showPpr (bindersOf b))
+-- $ letVars b
+
+lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp)
+lineSpan b _ = Nothing -- error $ "INCCHECK: lineSpan unexpected dummy span in lineSpan" ++ showPpr (bindersOf b)
+
+catSpans b [] = error $ "INCCHECK: catSpans: no spans found for " ++ showPpr b
+catSpans b xs = foldr1 combineSrcSpans xs
+
+bindSpans (NonRec x e) = getSrcSpan x : exprSpans e
+bindSpans (Rec xes) = map getSrcSpan xs ++ concatMap exprSpans es
+ where
+ (xs, es) = unzip xes
+exprSpans (Tick t _) = [tickSrcSpan t]
+exprSpans (Var x) = [getSrcSpan x]
+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 e = []
+
+altSpans (_, xs, e) = map getSrcSpan xs ++ exprSpans e
+
+
+-- coreDefs cbs = mkDefs lxs
+-- where
+-- lxs = coreDefs' cbs
+-- -- lxs = L.sortBy (compare `on` fst) [(line x, x) | x <- xs ]
+-- -- xs = concatMap bindersOf cbs
+-- -- line = sourceLine . getSourcePos
+--
+-- mkDefs [] = []
+-- mkDefs ((l,x):lxs) = case lxs of
+-- [] -> [D l Nothing x]
+-- (l',_):_ -> (D l (Just l') x) : mkDefs lxs
+--
+-- coreDefs' cbs = L.sort [(l, x) | b <- cbs, let (l, l') = coreDef b, x <- bindersOf b]
+
+
+-------------------------------------------------------------------------
+coreDeps :: [CoreBind] -> Deps
+-------------------------------------------------------------------------
+coreDeps = M.fromList . concatMap bindDep
+
+bindDep b = [(x, ys) | x <- bindersOf b]
+ where
+ ys = S.fromList $ freeVars S.empty b
+
+type Deps = M.HashMap Var (S.HashSet Var)
+
+-------------------------------------------------------------------------
+dependentVars :: Deps -> S.HashSet Var -> S.HashSet Var
+-------------------------------------------------------------------------
+dependentVars d xs = {- tracePpr "INCCHECK: tx changed vars" $ -}
+ go S.empty $ {- tracePpr "INCCHECK: seed changed vars" -} xs
+ 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) (L.sort defs)
+ where
+ 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 -------------------------------------------------------
+-------------------------------------------------------------------------
+
+-- | `save` creates an .saved version of the `target` file, which will be
+-- used to find what has changed the /next time/ `target` is checked.
+-------------------------------------------------------------------------
+save :: FilePath -> IO ()
+-------------------------------------------------------------------------
+save target = copyFile target $ extFileName Saved target
+
+
+-- | `lineDiff src dst` compares the contents of `src` with `dst`
+-- and returns the lines of `src` that are different.
+-------------------------------------------------------------------------
+lineDiff :: FilePath -> FilePath -> IO [Int]
+-------------------------------------------------------------------------
+lineDiff src dst
+ = do s1 <- getLines src
+ s2 <- getLines dst
+ let ns = diffLines 1 $ getGroupedDiff s1 s2
+ putStrLn $ "INCCHECK: diff lines = " ++ show ns
+ return ns
+
+diffLines _ [] = []
+diffLines n (Both ls _ : d) = diffLines n' d where n' = n + length ls
+diffLines n (First ls : d) = [n .. (n' - 1)] ++ diffLines n' d where n' = n + length ls
+diffLines n (Second _ : d) = diffLines n d
+
+getLines = fmap lines . readFile
diff --git a/Language/Haskell/Liquid/Fresh.hs b/Language/Haskell/Liquid/Fresh.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Fresh.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.Haskell.Liquid.Fresh (
+ Freshable(..), TCInfo(..)
+ ) where
+
+import Control.Monad.State
+import Control.Applicative ((<$>))
+
+import qualified TyCon as TC
+
+import qualified Data.HashMap.Strict as M
+
+import Language.Haskell.Liquid.Types
+import Language.Haskell.Liquid.RefType (uTop, expandRApp)
+import Language.Fixpoint.Types
+import Language.Fixpoint.Misc
+
+type TTCInfo = M.HashMap TC.TyCon RTyCon
+type TTCEmbed = TCEmb TC.TyCon
+
+class Monad m => Freshable m a where
+ fresh :: m a
+ true :: a -> m a
+ true = return . id
+ refresh :: a -> m a
+ refresh = return . id
+
+class Monad m => TCInfo m where
+ getTyConInfo :: m TTCInfo
+ getTyConInfo = return $ M.empty
+ getTyConEmbed :: m TTCEmbed
+ getTyConEmbed = return $ M.empty
+
+instance Freshable m Integer => Freshable m Symbol where
+ fresh = liftM (tempSymbol "x") fresh
+
+instance Freshable m Integer => Freshable m Refa where
+ fresh = liftM (`RKvar` emptySubst) freshK
+ where freshK = liftM intKvar fresh
+
+instance Freshable m Integer => Freshable m [Refa] where
+ fresh = liftM single fresh
+
+-- instance Monad m => Freshable m TCEmbed where
+
+instance Freshable m Integer => Freshable m Reft where
+ fresh = errorstar "fresh Reft"
+ true (Reft (v,_)) = return $ Reft (v, [])
+ refresh (Reft (_,_)) = liftM2 (curry Reft) freshVV fresh
+ where freshVV = liftM (vv . Just) fresh
+
+instance Freshable m Integer => Freshable m RReft where
+ fresh = errorstar "fresh RReft"
+ true (U r _) = liftM uTop (true r)
+ refresh (U r _) = liftM uTop (refresh r)
+
+instance (Freshable m Integer, Freshable m r, TCInfo m, Reftable r) => Freshable m (RRType r) where
+ fresh = errorstar "fresh RefType"
+ refresh = refreshRefType
+ true = trueRefType
+
+trueRefType (RAllT α t)
+ = liftM (RAllT α) (true t)
+trueRefType (RAllP π t)
+ = liftM (RAllP π) (true t)
+trueRefType (RFun _ t t' _)
+ = liftM3 rFun fresh (true t) (true t')
+trueRefType (RApp c ts _ _)
+ = liftM (\ts -> RApp c ts truerefs top) (mapM true ts)
+ where truerefs = (RPoly [] . ofRSort . ptype) <$> (rTyConPs c)
+trueRefType (RAppTy t t' _)
+ = liftM2 rAppTy (true t) (true t')
+trueRefType t
+ = return t
+
+
+refreshRefType :: (Freshable m Integer, Freshable m r, TCInfo m, Reftable r)
+ => RRType r
+ -> m (RRType r)
+refreshRefType (RAllT α t)
+ = liftM (RAllT α) (refresh t)
+refreshRefType (RAllP π t)
+ = liftM (RAllP π) (refresh t)
+refreshRefType (RFun b t t' _)
+ | b == dummySymbol -- b == (RB F.dummySymbol)
+ = liftM3 rFun fresh (refresh t) (refresh t')
+ | otherwise
+ = liftM2 (rFun b) (refresh t) (refresh t')
+refreshRefType (RApp rc ts _ r)
+ = do tyi <- getTyConInfo
+ tce <- getTyConEmbed
+ let RApp rc' _ rs _ = expandRApp tce tyi (RApp rc ts [] r)
+ let rπs = safeZip "refreshRef" rs (rTyConPs rc')
+ liftM3 (RApp rc') (mapM refresh ts) (mapM refreshRef rπs) (refresh r)
+refreshRefType (RVar a r)
+ = liftM (RVar a) (refresh r)
+refreshRefType (RAppTy t t' _)
+ = liftM2 rAppTy (refresh t) (refresh t')
+refreshRefType t
+ = return t
+
+refreshRef :: (Freshable m Integer, Freshable m r, TCInfo m, Reftable r)
+ => (Ref RSort r (RRType r), PVar RSort)
+ -> m (Ref RSort r (RRType r))
+
+refreshRef (RPoly s t, π) = liftM2 RPoly (mapM freshSym (pargs π)) (refreshRefType t)
+refreshRef (RMono _ _, _) = errorstar "refreshRef: unexpected"
+
+freshSym s = liftM (, fst3 s) fresh
diff --git a/Language/Haskell/Liquid/GhcInterface.hs b/Language/Haskell/Liquid/GhcInterface.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/GhcInterface.hs
@@ -0,0 +1,501 @@
+
+{-# LANGUAGE NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances, TupleSections, DeriveDataTypeable, ScopedTypeVariables #-}
+
+module Language.Haskell.Liquid.GhcInterface (
+
+ -- * extract all information needed for verification
+ getGhcInfo
+
+ -- * visitors
+ , CBVisitable (..)
+ ) where
+
+import Bag (bagToList)
+import ErrUtils
+import Panic
+import GHC hiding (Target)
+import Text.PrettyPrint.HughesPJ
+import HscTypes hiding (Target)
+import TidyPgm (tidyProgram)
+import Literal
+import CoreSyn
+
+import Var
+import Name (getSrcSpan)
+import CoreMonad (liftIO)
+import DataCon
+import qualified TyCon as TC
+import HscMain
+import Module
+import Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc)
+import qualified Control.Exception as Ex
+
+import GHC.Paths (libdir)
+import System.FilePath ( replaceExtension
+ , dropExtension
+ , takeFileName
+ , splitFileName
+ , combine
+ , dropFileName
+ , normalise)
+
+import DynFlags
+import Control.Arrow (second)
+import Control.Monad (filterM, zipWithM, when, forM, liftM)
+import Control.DeepSeq
+import Control.Applicative hiding (empty)
+import Data.Monoid hiding ((<>))
+import Data.List (intercalate, foldl', find, (\\), delete, nub)
+import Data.Maybe (catMaybes, maybeToList)
+import qualified Data.HashSet as S
+import qualified Data.HashMap.Strict as M
+
+import System.Console.CmdArgs.Verbosity (whenLoud)
+import System.Directory (removeFile, doesFileExist)
+import Language.Fixpoint.Types hiding (Expr)
+import Language.Fixpoint.Misc
+
+import Language.Haskell.Liquid.Types
+import Language.Haskell.Liquid.RefType
+import Language.Haskell.Liquid.ANFTransform
+import Language.Haskell.Liquid.Bare
+import Language.Haskell.Liquid.GhcMisc
+import Language.Haskell.Liquid.Misc
+
+import Language.Haskell.Liquid.CmdLine (withPragmas)
+import Language.Haskell.Liquid.Parse
+
+import Language.Fixpoint.Parse hiding (brackets, comma)
+import Language.Fixpoint.Names
+import Language.Fixpoint.Files
+
+import qualified Language.Haskell.Liquid.Measure as Ms
+
+
+--------------------------------------------------------------------
+getGhcInfo :: Config -> FilePath -> IO (Either ErrorResult GhcInfo)
+--------------------------------------------------------------------
+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
+ handle = return . Left . result
+
+-- parseSpec :: (String, FilePath) -> IO (Either ErrorResult Ms.BareSpec)
+-- parseSpec (name, file)
+-- = Ex.catch (parseSpec' name file) $ \(e :: Ex.IOException) ->
+-- ioError $ userError $
+-- printf "Hit exception: %s while parsing spec file: %s for module %s"
+-- (show e) file name
+
+
+getGhcInfo' cfg0 target
+ = runGhc (Just libdir) $ do
+ liftIO $ deleteBinFilez target
+ addTarget =<< guessTarget target Nothing
+ (name,tgtSpec) <- liftIO $ parseSpec target
+ cfg <- liftIO $ withPragmas cfg0 $ Ms.pragmas tgtSpec
+ let paths = idirs cfg
+ df <- getSessionDynFlags
+ setSessionDynFlags $ updateDynFlags df (idirs cfg)
+ liftIO $ whenLoud $ putStrLn ("paths = " ++ show paths)
+ let name' = ModName Target (getModName name)
+ impNames <- allDepNames <$> depanal [] False
+ impSpecs <- getSpecs (totality cfg) target paths impNames [Spec, Hs, LHs]
+ impSpecs' <- forM impSpecs $ \(f,n,s) -> do
+ when (not $ isSpecImport n) $
+ addTarget =<< guessTarget f Nothing
+ return (n,s)
+ load LoadAllTargets
+ modguts <- getGhcModGuts1 target
+ hscEnv <- getSession
+ coreBinds <- liftIO $ anormalize hscEnv modguts
+ let impVs = importVars coreBinds
+ let defVs = definedVars coreBinds
+ let useVs = readVars coreBinds
+ let letVs = letVars coreBinds
+ (spec, imps, incs) <- moduleSpec cfg (impVs ++ defVs) letVs name' modguts tgtSpec impSpecs'
+ liftIO $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps
+ hqualFiles <- moduleHquals modguts (idirs cfg) target imps incs
+ return $ GI hscEnv coreBinds impVs defVs useVs hqualFiles imps incs spec
+
+updateDynFlags df ps
+ = df { importPaths = ps ++ importPaths df
+ , libraryPaths = ps ++ libraryPaths df
+ , profAuto = ProfAutoCalls
+ , ghcLink = NoLink
+ , hscTarget = HscInterpreted
+ , ghcMode = CompManager
+ } `xopt_set` Opt_MagicHash
+ `dopt_set` Opt_ImplicitImportQualified
+
+mgi_namestring = moduleNameString . moduleName . mgi_module
+
+importVars = freeVars S.empty
+
+definedVars = concatMap defs
+ where
+ defs (NonRec x _) = [x]
+ defs (Rec xes) = map fst xes
+
+
+------------------------------------------------------------------
+-- | Extracting CoreBindings From File ---------------------------
+------------------------------------------------------------------
+
+getGhcModGuts1 fn = do
+ modGraph <- getModuleGraph
+ case find ((== fn) . msHsFilePath) modGraph of
+ Just modSummary -> do
+ -- mod_guts <- modSummaryModGuts modSummary
+ mod_guts <- coreModule <$> (desugarModuleWithLoc =<< typecheckModule =<< parseModule modSummary)
+ return $! (miModGuts mod_guts)
+ Nothing -> exitWithPanic "Ghc Interface: Unable to get GhcModGuts"
+
+
+-- Generates Simplified ModGuts (INLINED, etc.) but without SrcSpan
+getGhcModGutsSimpl1 fn = do
+ modGraph <- getModuleGraph
+ case find ((== fn) . msHsFilePath) modGraph of
+ Just modSummary -> do
+ mod_guts <- coreModule `fmap` (desugarModule =<< typecheckModule =<< parseModule modSummary)
+ hsc_env <- getSession
+ simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
+ (cg,_) <- liftIO $ tidyProgram hsc_env simpl_guts
+ liftIO $ putStrLn "************************* CoreGuts ****************************************"
+ liftIO $ putStrLn (showPpr $ cg_binds cg)
+ return $! (miModGuts mod_guts) { mgi_binds = cg_binds cg }
+ Nothing -> error "GhcInterface : getGhcModGutsSimpl1"
+
+peepGHCSimple fn
+ = do z <- compileToCoreSimplified fn
+ liftIO $ putStrLn "************************* peepGHCSimple Core Module ************************"
+ liftIO $ putStrLn $ showPpr z
+ liftIO $ putStrLn "************************* peepGHCSimple Bindings ***************************"
+ liftIO $ putStrLn $ showPpr (cm_binds z)
+ errorstar "Done peepGHCSimple"
+
+deleteBinFilez :: FilePath -> IO ()
+deleteBinFilez fn = mapM_ (tryIgnore "delete binaries" . removeFileIfExists)
+ $ (fn `replaceExtension`) `fmap` exts
+ where exts = ["hi", "o"]
+
+removeFileIfExists f = doesFileExist f >>= (`when` removeFile f)
+
+--------------------------------------------------------------------------------
+-- | Desugaring (Taken from GHC, modified to hold onto Loc in Ticks) -----------
+--------------------------------------------------------------------------------
+
+desugarModuleWithLoc tcm = do
+ let ms = pm_mod_summary $ tm_parsed_module tcm
+ -- let ms = modSummary tcm
+ let (tcg, _) = tm_internals_ tcm
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ guts <- liftIO $ hscDesugarWithLoc hsc_env_tmp ms tcg
+ return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }
+
+--------------------------------------------------------------------------------
+-- | Extracting Qualifiers -----------------------------------------------------
+--------------------------------------------------------------------------------
+
+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
+ return rv
+
+--------------------------------------------------------------------------------
+-- | Extracting Specifications (Measures + Assumptions) ------------------------
+--------------------------------------------------------------------------------
+
+moduleSpec cfg vars defVars target mg tgtSpec impSpecs
+ = do addImports impSpecs
+ addContext $ IIModule $ moduleName $ mgi_module mg
+ env <- getSession
+ let specs = (target,tgtSpec):impSpecs
+ let imps = sortNub $ impNames ++ [ symbolString x
+ | (_,spec) <- specs
+ , x <- Ms.imports spec
+ ]
+ ghcSpec <- liftIO $ makeGhcSpec cfg target vars defVars env specs
+ return (ghcSpec, imps, Ms.includes tgtSpec)
+ where
+ name = mgi_namestring mg
+ impNames = map (getModString.fst) impSpecs
+ addImports is
+ = mapM (addContext . IIDecl . qualImportDecl . getModName) (map fst is)
+
+allDepNames = concatMap (map declNameString . ms_textual_imps)
+
+declNameString = moduleNameString . unLoc . ideclName . unLoc
+
+depNames = map fst . dep_mods . mgi_deps
+dirImportNames = map moduleName . moduleEnvKeys . mgi_dir_imps
+targetName = dropExtension . takeFileName
+-- starName fn = combine dir ('*':f) where (dir, f) = splitFileName fn
+starName = ("*" ++)
+
+patErrorName = "PatErr"
+
+getSpecs tflag target paths names exts
+ = do fs' <- sortNub <$> moduleImports exts paths names
+ patSpec <- getPatSpec paths tflag
+ let fs = patSpec ++ fs'
+ liftIO $ whenLoud $ putStrLn ("getSpecs: " ++ show fs)
+ transParseSpecs exts paths (S.singleton target) mempty (map snd fs)
+
+getPatSpec paths totalitycheck
+ | totalitycheck
+ = (map (patErrorName, )) . maybeToList <$> moduleFile paths patErrorName Spec
+ | otherwise
+ = return []
+
+transParseSpecs _ _ _ specs []
+ = return specs
+transParseSpecs exts paths seenFiles specs newFiles
+ = do newSpecs <- liftIO $ mapM (\f -> addFst3 f <$> parseSpec f) newFiles
+ impFiles <- moduleImports exts paths $ specsImports newSpecs
+ let seenFiles' = seenFiles `S.union` (S.fromList newFiles)
+ let specs' = specs ++ map (third noTerm) newSpecs
+ let newFiles' = [f | (_,f) <- impFiles, not (f `S.member` seenFiles')]
+ transParseSpecs exts paths seenFiles' specs' newFiles'
+ where
+ specsImports ss = nub $ concatMap (map symbolString . Ms.imports . thd3) ss
+ noTerm spec = spec { Ms.decr=mempty, Ms.lazy=mempty }
+ third f (a,b,c) = (a,b,f c)
+
+parseSpec :: FilePath -> IO (ModName, Ms.BareSpec)
+parseSpec file
+ = do whenLoud $ putStrLn $ "parseSpec: " ++ file
+ either Ex.throw return . specParser file =<< readFile file
+
+specParser file str
+ | isExtFile Spec file = specSpecificationP file str
+ | isExtFile Hs file = hsSpecificationP file str
+ | isExtFile LHs file = lhsSpecificationP file str
+ | otherwise = exitWithPanic $ "SpecParser: Cannot Parse File " ++ file
+
+moduleImports :: GhcMonad m => [Ext] -> [FilePath] -> [String] -> m [(String, FilePath)]
+moduleImports exts paths names
+ = do modGraph <- getModuleGraph
+ liftM concat $ forM names $ \name -> do
+ map (name,) . catMaybes <$> mapM (moduleFile paths name) exts
+
+moduleFile :: GhcMonad m => [FilePath] -> String -> Ext -> m (Maybe FilePath)
+moduleFile paths name ext
+ | ext `elem` [Hs, LHs]
+ = do mg <- getModuleGraph
+ case find ((==name) . moduleNameString . ms_mod_name) mg of
+ Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths
+ Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)
+ | otherwise
+ = do liftIO $ getFileInDirs (extModuleName name ext) paths
+
+isJust Nothing = False
+isJust (Just a) = True
+
+--moduleImports ext paths names
+-- = liftIO $ liftM catMaybes $ forM extNames (namePath paths)
+-- where extNames = (`extModuleName` ext) <$> names
+-- namePath paths fileName = getFileInDirs fileName paths
+
+--namePath_debug paths name
+-- = do res <- getFileInDirs name paths
+-- case res of
+-- Just p -> putStrLn $ "namePath: name = " ++ name ++ " expanded to: " ++ (show p)
+-- Nothing -> putStrLn $ "namePath: name = " ++ name ++ " not found in: " ++ (show paths)
+-- return res
+
+specIncludes :: GhcMonad m => Ext -> [FilePath] -> [FilePath] -> m [FilePath]
+specIncludes ext paths reqs
+ = do let libFile = extFileName ext preludeName
+ let incFiles = catMaybes $ reqFile ext <$> reqs
+ liftIO $ forM (libFile : incFiles) (`findFileInDirs` paths)
+
+reqFile ext s
+ | isExtFile ext s
+ = Just s
+ | otherwise
+ = Nothing
+
+
+------------------------------------------------------------------------------
+-------------------------------- A CoreBind Visitor --------------------------
+------------------------------------------------------------------------------
+
+-- TODO: syb-shrinkage
+
+class CBVisitable a where
+ freeVars :: S.HashSet Var -> a -> [Var]
+ readVars :: a -> [Var]
+ letVars :: a -> [Var]
+ literals :: a -> [Literal]
+
+instance CBVisitable [CoreBind] where
+ freeVars env cbs = (sortNub xs) \\ ys
+ where xs = concatMap (freeVars env) cbs
+ ys = concatMap bindings cbs
+
+ readVars = concatMap readVars
+ letVars = concatMap letVars
+ literals = concatMap literals
+
+instance CBVisitable CoreBind where
+ freeVars env (NonRec x e) = freeVars (extendEnv env [x]) e
+ freeVars env (Rec xes) = concatMap (freeVars env') es
+ where (xs,es) = unzip xes
+ env' = extendEnv env xs
+
+ readVars (NonRec _ e) = readVars e
+ readVars (Rec xes) = concat [x `delete` nubReadVars e |(x, e) <- xes]
+ where nubReadVars = sortNub . readVars
+
+ letVars (NonRec x e) = x : letVars e
+ letVars (Rec xes) = xs ++ concatMap letVars es
+ where
+ (xs, es) = unzip xes
+
+ literals (NonRec _ e) = literals e
+ literals (Rec xes) = concatMap literals $ map snd xes
+
+instance CBVisitable (Expr Var) where
+ freeVars = exprFreeVars
+ readVars = exprReadVars
+ letVars = exprLetVars
+ literals = exprLiterals
+
+exprFreeVars = go
+ where
+ go env (Var x) = if x `S.member` env then [] else [x]
+ go env (App e a) = (go env e) ++ (go env a)
+ go env (Lam x e) = go (extendEnv env [x]) e
+ go env (Let b e) = (freeVars env b) ++ (go (extendEnv env (bindings b)) e)
+ go env (Tick _ e) = go env e
+ go env (Cast e _) = go env e
+ go env (Case e x _ cs) = (go env e) ++ (concatMap (freeVars (extendEnv env [x])) cs)
+ go _ _ = []
+
+exprReadVars = go
+ where
+ go (Var x) = [x]
+ go (App e a) = concatMap go [e, a]
+ go (Lam _ e) = go e
+ go (Let b e) = readVars b ++ go e
+ go (Tick _ e) = go e
+ go (Cast e _) = go e
+ go (Case e _ _ cs) = (go e) ++ (concatMap readVars cs)
+ go _ = []
+
+exprLetVars = go
+ where
+ go (Var _) = []
+ go (App e a) = concatMap go [e, a]
+ go (Lam x e) = x : go e
+ go (Let b e) = letVars b ++ go e
+ go (Tick _ e) = go e
+ go (Cast e _) = go e
+ go (Case e x _ cs) = x : go e ++ concatMap letVars cs
+ go _ = []
+
+exprLiterals = go
+ where
+ go (Lit l) = [l]
+ go (App e a) = concatMap go [e, a]
+ go (Let b e) = literals b ++ go e
+ go (Lam _ e) = go e
+ go (Tick _ e) = go e
+ go (Cast e _) = go e
+ go (Case e _ _ cs) = (go e) ++ (concatMap literals cs)
+ go _ = []
+
+
+instance CBVisitable (Alt Var) where
+ freeVars env (a, xs, e) = freeVars env a ++ freeVars (extendEnv env xs) e
+ readVars (_,_, e) = readVars e
+ letVars (_,xs,e) = xs ++ letVars e
+ literals (c,_, e) = literals c ++ literals e
+
+
+instance CBVisitable AltCon where
+ freeVars _ (DataAlt dc) = dataConImplicitIds dc
+ freeVars _ _ = []
+ readVars _ = []
+ letVars _ = []
+ literals (LitAlt l) = [l]
+ literals _ = []
+
+
+
+extendEnv = foldl' (flip S.insert)
+
+-- names = (map varName) . bindings
+--
+bindings (NonRec x _)
+ = [x]
+bindings (Rec xes )
+ = map fst xes
+
+--------------------------------------------------------------------
+------ Strictness --------------------------------------------------
+--------------------------------------------------------------------
+
+instance NFData Var
+instance NFData SrcSpan
+
+instance PPrint GhcSpec where
+ pprint spec = (text "******* Target Variables ********************")
+ $$ (pprint $ tgtVars spec)
+ $$ (text "******* Type Signatures *********************")
+ $$ (pprintLongList $ tySigs spec)
+ $$ (text "******* DataCon Specifications (Measure) ****")
+ $$ (pprintLongList $ ctor spec)
+ $$ (text "******* Measure Specifications **************")
+ $$ (pprintLongList $ meas spec)
+
+instance PPrint GhcInfo where
+ pprint info = (text "*************** Imports *********************")
+ $+$ (intersperse comma $ text <$> imports info)
+ $+$ (text "*************** Includes ********************")
+ $+$ (intersperse comma $ text <$> includes info)
+ $+$ (text "*************** Imported Variables **********")
+ $+$ (pprDoc $ impVars info)
+ $+$ (text "*************** Defined Variables ***********")
+ $+$ (pprDoc $ defVars info)
+ $+$ (text "*************** Specification ***************")
+ $+$ (pprint $ spec info)
+ $+$ (text "*************** Core Bindings ***************")
+ $+$ (pprint $ cbs info)
+
+instance Show GhcInfo where
+ 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
+
+pprintLongList = brackets . vcat . map pprint
+
+------------------------------------------------------------------------
+-- Dealing With Errors -------------------------------------------------
+------------------------------------------------------------------------
+
+-- | Throw a panic exception
+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
+ . srcErrorMessages
+
+errMsgErrors e = [ ErrGhc l (pprint e) | l <- errMsgSpans e ]
+
diff --git a/Language/Haskell/Liquid/GhcMisc.hs b/Language/Haskell/Liquid/GhcMisc.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/GhcMisc.hs
@@ -0,0 +1,290 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | This module contains a wrappers and utility functions for
+-- accessing GHC module information. It should NEVER depend on
+-- ANY module inside the Language.Haskell.Liquid.* tree.
+
+module Language.Haskell.Liquid.GhcMisc where
+
+import Debug.Trace
+
+import Kind (superKind)
+import CoreSyn hiding (Expr)
+import CostCentre
+import FamInstEnv (FamInst)
+import GHC hiding (L)
+import HscTypes (Dependencies, ImportedMods, ModGuts(..))
+import SrcLoc (srcSpanFile, srcSpanStartLine, srcSpanStartCol)
+
+import Language.Fixpoint.Misc (errorstar, stripParens)
+import Text.Parsec.Pos (sourceName, sourceLine, sourceColumn, SourcePos, newPos)
+import Language.Fixpoint.Types hiding (SESearch(..))
+import Name (mkInternalName, getSrcSpan)
+import OccName (mkTyVarOcc, mkTcOcc)
+import Unique
+import Finder (findImportedModule, cannotFindModule)
+import DynamicLoading
+import ErrUtils
+import Exception
+import Panic (GhcException(..), throwGhcException)
+import RnNames (gresFromAvails)
+import HscMain
+import HscTypes (HscEnv(..), FindResult(..), ModIface(..), lookupTypeHscEnv)
+import FastString
+import TcRnDriver
+import OccName
+
+
+import RdrName
+import Type (liftedTypeKind)
+import TypeRep
+import Var
+-- import TyCon (mkSuperKindTyCon)
+import qualified TyCon as TC
+import qualified DataCon as DC
+import FastString (uniq, unpackFS, fsLit)
+import Data.Char (isLower, isSpace)
+import Data.Maybe
+import Data.Hashable
+import qualified Data.HashSet as S
+import qualified Data.List as L
+import Control.Applicative ((<$>))
+import Control.Arrow (second)
+import Control.Exception (assert, throw)
+import Outputable (Outputable (..), text, ppr)
+import qualified Outputable as Out
+import DynFlags
+-- import Language.Haskell.Liquid.Types
+
+-- import qualified Pretty as P
+import qualified Text.PrettyPrint.HughesPJ as PJ
+
+-----------------------------------------------------------------------
+--------------- Datatype For Holding GHC ModGuts ----------------------
+-----------------------------------------------------------------------
+
+data MGIModGuts = MI {
+ mgi_binds :: !CoreProgram
+ , mgi_module :: !Module
+ , mgi_deps :: !Dependencies
+ , mgi_dir_imps :: !ImportedMods
+ , mgi_rdr_env :: !GlobalRdrEnv
+ , mgi_tcs :: ![TyCon]
+ , mgi_fam_insts :: ![FamInst]
+ }
+
+miModGuts mg = MI {
+ mgi_binds = mg_binds mg
+ , mgi_module = mg_module mg
+ , mgi_deps = mg_deps mg
+ , mgi_dir_imps = mg_dir_imps mg
+ , mgi_rdr_env = mg_rdr_env mg
+ , mgi_tcs = mg_tcs mg
+ , mgi_fam_insts = mg_fam_insts mg
+ }
+
+-----------------------------------------------------------------------
+--------------- Generic Helpers for Encoding Location -----------------
+-----------------------------------------------------------------------
+
+srcSpanTick :: Module -> SrcSpan -> Tickish a
+srcSpanTick m loc
+ = ProfNote (AllCafsCC m loc) False True
+
+tickSrcSpan :: Outputable a => Tickish a -> SrcSpan
+tickSrcSpan (ProfNote (AllCafsCC _ loc) _ _)
+ = loc
+tickSrcSpan z
+ = errorstar $ "tickSrcSpan: unhandled tick: " ++ showPpr z
+
+-----------------------------------------------------------------------
+--------------- Generic Helpers for Accessing GHC Innards -------------
+-----------------------------------------------------------------------
+
+stringTyVar :: String -> TyVar
+stringTyVar s = mkTyVar name liftedTypeKind
+ where name = mkInternalName (mkUnique 'x' 24) occ noSrcSpan
+ occ = mkTcOcc s
+
+stringTyCon :: Char -> Int -> String -> TyCon
+stringTyCon c n s = TC.mkKindTyCon name superKind
+ where
+ name = mkInternalName (mkUnique c n) occ noSrcSpan
+ occ = mkTyVarOcc $ assert (validTyVar s) s
+
+hasBaseTypeVar = isBaseType . varType
+
+-- same as Constraint isBase
+isBaseType (TyVarTy _) = True
+isBaseType (TyConApp _ ts) = all isBaseType ts
+isBaseType (FunTy t1 t2) = isBaseType t1 && isBaseType t2
+isBaseType _ = False
+validTyVar :: String -> Bool
+validTyVar s@(c:_) = isLower c && all (not . isSpace) s
+validTyVar _ = False
+
+tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)
+
+tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x
+
+pprShow = text . show
+
+
+tidyCBs = map unTick
+
+unTick (NonRec b e) = NonRec b (unTickExpr e)
+unTick (Rec bs) = Rec $ map (second unTickExpr) bs
+
+unTickExpr (App e a) = App (unTickExpr e) (unTickExpr a)
+unTickExpr (Lam b e) = Lam b (unTickExpr e)
+unTickExpr (Let b e) = Let (unTick b) (unTickExpr e)
+unTickExpr (Case e b t as) = Case (unTickExpr e) b t (map unTickAlt as)
+ where unTickAlt (a, b, e) = (a, b, unTickExpr e)
+unTickExpr (Cast e c) = Cast (unTickExpr e) c
+unTickExpr (Tick _ e) = unTickExpr e
+unTickExpr x = x
+
+-----------------------------------------------------------------------
+------------------ Generic Helpers for DataConstructors ---------------
+-----------------------------------------------------------------------
+
+getDataConVarUnique v
+ | isId v && isDataConWorkId 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
+
+--instance (Uniquable a) => Hashable a where
+
+instance Hashable SrcSpan where
+ 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
+
+-------------------------------------------------------
+
+toFixSDoc = PJ.text . PJ.render . toFix
+sDocDoc = PJ.text . showSDoc
+pprDoc = sDocDoc . ppr
+
+-- Overriding Outputable functions because they now require DynFlags!
+showPpr = Out.showPpr tracingDynFlags
+showSDoc = Out.showSDoc tracingDynFlags
+showSDocDump = Out.showSDocDump tracingDynFlags
+
+typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr
+
+instance Fixpoint Var where
+ toFix = pprDoc
+
+instance Fixpoint Name where
+ toFix = pprDoc
+
+instance Fixpoint Type where
+ toFix = pprDoc
+
+
+sourcePosSrcSpan :: SourcePos -> SrcSpan
+sourcePosSrcSpan = srcLocSpan . sourcePosSrcLoc
+
+sourcePosSrcLoc :: SourcePos -> SrcLoc
+sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col
+ where
+ file = sourceName p
+ line = sourceLine p
+ col = sourceColumn p
+
+srcSpanSourcePos :: SrcSpan -> SourcePos
+srcSpanSourcePos (UnhelpfulSpan _) = dummyPos
+srcSpanSourcePos (RealSrcSpan s) = realSrcSpanSourcePos s
+
+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)
+dummyPos :: SourcePos
+dummyPos = newPos "?" 0 0
+
+realSrcSpanSourcePos :: RealSrcSpan -> SourcePos
+realSrcSpanSourcePos s = newPos file line col
+ where
+ file = unpackFS $ srcSpanFile s
+ line = srcSpanStartLine s
+ col = srcSpanStartCol s
+
+getSourcePos = srcSpanSourcePos . 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'
+ xs = vs' ++ vs
+
+collectValBinders' expr = go [] expr
+ where
+ go tvs (Lam b e) | isTyVar b = go tvs e
+ go tvs (Lam b e) | isId b = go (b:tvs) e
+ go tvs e = (reverse tvs, e)
+
+ignoreLetBinds e@(Let (NonRec x xe) e')
+ = ignoreLetBinds e'
+ignoreLetBinds e
+ = e
+
+isDictionary x = L.isPrefixOf "$d" (showPpr x)
+isInternal x = L.isPrefixOf "$" (showPpr x)
+
+
+instance Hashable Var where
+ hashWithSalt = uniqueHash
+
+instance Hashable TyCon where
+ hashWithSalt = uniqueHash
+
+uniqueHash i = hashWithSalt i . getKey . getUnique
+
+-- slightly modified version of DynamicLoading.lookupRdrNameInModule
+lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
+lookupRdrName hsc_env mod_name rdr_name = do
+ -- First find the package the module resides in by searching exposed packages and home modules
+ found_module <- findImportedModule hsc_env mod_name Nothing
+ case found_module of
+ Found _ mod -> do
+ -- Find the exports of the module
+ (_, mb_iface) <- getModuleInterface hsc_env mod
+ case mb_iface of
+ Just iface -> do
+ -- Try and find the required name in the exports
+ let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
+ , is_qual = False, is_dloc = noSrcSpan }
+ provenance = Imported [ImpSpec decl_spec ImpAll]
+ env = case mi_globals iface of
+ Nothing -> mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))
+ Just e -> e
+ case lookupGRE_RdrName rdr_name env of
+ [gre] -> return (Just (gre_name gre))
+ [] -> return Nothing
+ _ -> Out.panic "lookupRdrNameInModule"
+ Nothing -> throwCmdLineErrorS dflags $ Out.hsep [Out.ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
+ err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
+ where dflags = hsc_dflags hsc_env
+ throwCmdLineErrorS dflags = throwCmdLineError . Out.showSDoc dflags
+ throwCmdLineError = throwGhcException . CmdLineError
+
+
+addContext m = getContext >>= setContext . (m:)
+
+qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }
diff --git a/Language/Haskell/Liquid/Measure.hs b/Language/Haskell/Liquid/Measure.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Measure.hs
@@ -0,0 +1,297 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.Haskell.Liquid.Measure (
+ Spec (..)
+ , BareSpec
+ , MSpec (..)
+ , Measure (..)
+ , Def (..)
+ , Body (..)
+ , mkM, mkMSpec
+ , qualifySpec
+ , mapTy
+ , dataConTypes
+ , defRefType
+ ) where
+
+import GHC hiding (Located)
+import Var
+import qualified Outputable as O
+import Text.PrettyPrint.HughesPJ hiding (first)
+import Text.Printf (printf)
+import DataCon
+import qualified Data.HashMap.Strict as M
+import qualified Data.HashSet as S
+import Data.Monoid hiding ((<>))
+import Data.List (foldl1')
+import Data.Either (partitionEithers)
+import Data.Bifunctor
+import Control.Applicative ((<$>))
+import Control.Exception (assert)
+
+import Language.Fixpoint.Misc
+import Language.Fixpoint.Types
+import Language.Haskell.Liquid.GhcMisc
+import Language.Haskell.Liquid.Types hiding (GhcInfo(..), GhcSpec (..))
+import Language.Haskell.Liquid.RefType
+
+-- MOVE TO TYPES
+type BareSpec = Spec BareType Symbol
+
+data Spec ty bndr = Spec {
+ measures :: ![Measure ty bndr] -- ^ User-defined properties for ADTs
+ , sigs :: ![(LocSymbol, ty)] -- ^ Imported functions and types
+ , invariants :: ![Located ty] -- ^ Data type invariants
+ , imports :: ![Symbol] -- ^ Loaded spec module names
+ , dataDecls :: ![DataDecl] -- ^ Predicated data definitions
+ , includes :: ![FilePath] -- ^ Included qualifier files
+ , aliases :: ![RTAlias String BareType] -- ^ RefType aliases
+ , paliases :: ![RTAlias Symbol Pred] -- ^ Refinement/Predicate aliases
+ , embeds :: !(TCEmb (Located String)) -- ^ GHC-Tycon-to-fixpoint Tycon map
+ , qualifiers :: ![Qualifier] -- ^ Qualifiers in source/spec files
+ , decr :: ![(LocSymbol, [Int])] -- ^ Information on decreasing arguments
+ , lvars :: ![(LocSymbol)] -- ^ Variables that should be checked in the environment they are used
+ , lazy :: !(S.HashSet Symbol) -- ^ Ignore Termination Check in these Functions
+ , pragmas :: ![Located String] -- ^ Command-line configurations passed in through source
+ }
+
+
+-- MOVE TO TYPES
+data MSpec ty ctor = MSpec {
+ ctorMap :: M.HashMap Symbol [Def ctor]
+ , measMap :: M.HashMap Symbol (Measure ty ctor)
+ }
+
+instance Monoid (MSpec ty ctor) where
+ mempty = MSpec M.empty M.empty
+
+ (MSpec c1 m1) `mappend` (MSpec c2 m2) =
+ MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2)
+
+
+-- MOVE TO TYPES
+data Measure ty ctor = M {
+ name :: LocSymbol
+ , sort :: ty
+ , eqns :: [Def ctor]
+ }
+
+-- MOVE TO TYPES
+data Def ctor
+ = Def {
+ measure :: LocSymbol
+ , ctor :: ctor
+ , binds :: [Symbol]
+ , body :: Body
+ } deriving (Show)
+
+-- MOVE TO TYPES
+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)
+
+instance Subable (Measure ty ctor) where
+ syms (M _ _ es) = concatMap syms es
+ substa f (M n s es) = M n s $ substa f <$> es
+ 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 Body where
+ syms (E e) = syms e
+ syms (P e) = syms e
+ syms (R s e) = s:syms e
+
+ substa f (E e) = E $ substa f e
+ substa f (P e) = P $ substa f e
+ substa f (R s e) = R s $ substa f e
+
+ substf f (E e) = E $ substf f e
+ substf f (P e) = P $ substf f e
+ substf f (R s e) = R s $ substf f e
+
+ subst su (E e) = E $ subst su e
+ subst su (P e) = P $ subst su e
+ subst su (R s e) = R s $ subst su e
+
+qualifySpec name sp = sp { sigs = [ (qualifySymbol name <$> x, t) | (x, t) <- sigs sp] }
+
+mkM :: LocSymbol -> ty -> [Def bndr] -> Measure ty bndr
+mkM name typ eqns
+ | all ((name ==) . measure) eqns
+ = M name typ eqns
+ | otherwise
+ = errorstar $ "invalid measure definition for " ++ (show name)
+
+-- mkMSpec :: [Measure ty Symbol] -> MSpec ty Symbol
+mkMSpec ms = MSpec cm mm
+ where
+ cm = groupMap ctor $ concatMap eqns ms'
+ mm = M.fromList [(val $ name m, m) | m <- ms' ]
+ ms' = checkDuplicateMeasure ms
+ -- ms' = checkFail "Duplicate Measure Definition" (distinct . fmap name) ms
+
+checkDuplicateMeasure ms
+ = case M.toList dups of
+ [] -> ms
+ 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)
+
+
+
+
+-- MOVE TO TYPES
+instance Monoid (Spec ty bndr) where
+ mappend (Spec xs ys invs zs ds is as ps es qs drs lvs ss gs)
+ (Spec xs' ys' invs' zs' ds' is' as' ps' es' qs' drs' lvs' ss' gs')
+ = Spec (xs ++ xs')
+ (ys ++ ys')
+ (invs ++ invs')
+ (sortNub (zs ++ zs'))
+ (ds ++ ds')
+ (sortNub (is ++ is'))
+ (as ++ as')
+ (ps ++ ps')
+ (M.union es es')
+ (qs ++ qs')
+ (drs ++ drs')
+ (lvs ++ lvs')
+ (S.union ss ss')
+ (gs ++ gs')
+ mempty = Spec [] [] [] [] [] [] [] [] M.empty [] [] [] S.empty []
+
+-- MOVE TO TYPES
+instance Functor Def where
+ fmap f def = def { ctor = f (ctor def) }
+
+-- MOVE TO TYPES
+instance Functor (Measure t) where
+ fmap f (M n s eqs) = M n s (fmap (fmap f) eqs)
+
+-- MOVE TO TYPES
+instance Functor (MSpec t) where
+ fmap f (MSpec cm mm) = MSpec (fc cm) (fm mm)
+ where fc = fmap $ fmap $ fmap f
+ fm = fmap $ fmap f
+
+-- 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)
+
+-- MOVE TO TYPES
+instance Bifunctor MSpec where
+ first f (MSpec cm mm) = MSpec cm (fmap (first f) mm)
+ second = fmap
+
+-- MOVE TO TYPES
+instance Bifunctor Spec where
+ first f (Spec ms ss is x0 x1 x2 x3 x4 x5 x6 x7 x7a x8 x9)
+ = Spec { measures = first f <$> ms
+ , sigs = second f <$> ss
+ , invariants = fmap f <$> is
+ , imports = x0
+ , dataDecls = x1
+ , includes = x2
+ , aliases = x3
+ , paliases = x4
+ , embeds = x5
+ , qualifiers = x6
+ , decr = x7
+ , lvars = x7a
+ , lazy = x8
+ , pragmas = x9
+ }
+ second f (Spec ms x0 x1 x2 x3 x4 x5 x5' x6 x7 x8 x8a x9 x10)
+ = Spec { measures = fmap (second f) ms
+ , sigs = x0
+ , invariants = x1
+ , imports = x2
+ , dataDecls = x3
+ , includes = x4
+ , aliases = x5
+ , paliases = x5'
+ , embeds = x6
+ , qualifiers = x7
+ , decr = x8
+ , lvars = x8a
+ , lazy = x9
+ , pragmas = x10
+ }
+
+-- MOVE TO TYPES
+instance PPrint Body where
+ pprint (E e) = pprint e
+ pprint (P p) = 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))
+
+-- MOVE TO TYPES
+instance (PPrint t, PPrint a) => PPrint (Measure t a) where
+ pprint (M n s eqs) = pprint n <> text "::" <> pprint s
+ $$ vcat (pprint `fmap` eqs)
+
+-- MOVE TO TYPES
+instance (PPrint t, PPrint a) => PPrint (MSpec t a) where
+ pprint = vcat . fmap pprint . fmap snd . M.toList . measMap
+
+-- MOVE TO TYPES
+instance PPrint (Measure t a) => Show (Measure t a) where
+ show = showpp
+
+-- MOVE TO TYPES
+mapTy :: (tya -> tyb) -> Measure tya c -> Measure tyb c
+mapTy f (M n ty eqs) = M n (f ty) eqs
+
+dataConTypes :: MSpec RefType DataCon -> ([(Var, RefType)], [(LocSymbol, RefType)])
+dataConTypes s = (ctorTys, measTys)
+ where
+ measTys = [(name m, sort m) | m <- M.elems $ measMap s]
+ ctorTys = concatMap mkDataConIdsTy [(defsVar ds, defsTy ds) | (_, ds) <- M.toList $ ctorMap s]
+ defsTy = foldl1' meet . fmap defRefType
+ defsVar = ctor . safeHead "defsVar"
+
+defRefType :: Def DataCon -> RefType
+defRefType (Def f dc xs body) = mkArrow as [] 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
+ msg = "defRefType dc = " ++ showPpr dc
+
+
+refineWithCtorBody dc (Loc _ f) body t =
+ case stripRTypeBase t of
+ Just (Reft (v, _)) ->
+ strengthen t $ Reft (v, [RConc $ bodyPred (EApp f [eVar 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 (R v' p) = subst1 p (v', fv)
+
+
diff --git a/Language/Haskell/Liquid/Misc.hs b/Language/Haskell/Liquid/Misc.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Misc.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE TupleSections #-}
+
+module Language.Haskell.Liquid.Misc where
+
+import Control.Applicative
+import System.FilePath
+
+import Language.Fixpoint.Misc (errorstar)
+
+import Paths_liquidhaskell
+
+safeIndex err n ls
+ | n >= length ls
+ = errorstar err
+ | otherwise
+ = ls !! n
+
+safeFromJust err (Just x) = x
+safeFromJust err _ = errorstar err
+
+addFst3 a (b, c) = (a, b, c)
+dropFst3 (_, x, y) = (x, y)
+
+replaceN n y ls = [if i == n then y else x | (x, i) <- zip ls [0..]]
+
+mapSndM f (x, y) = return . (x,) =<< f y
+
+firstM f (a,b) = (,b) <$> f a
+secondM f (a,b) = (a,) <$> f b
+
+first3M f (a,b,c) = (,b,c) <$> f a
+second3M f (a,b,c) = (a,,c) <$> f b
+third3M f (a,b,c) = (a,b,) <$> f c
+
+zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : (zip4 xs1 xs2 xs3 xs4)
+zip4 _ _ _ _ = []
+
+getIncludeDir = dropFileName <$> getDataFileName "include/Prelude.spec"
+getCssPath = getDataFileName "syntax/liquid.css"
+getHqBotPath = getDataFileName "include/Bot.hquals"
diff --git a/Language/Haskell/Liquid/Parse.hs b/Language/Haskell/Liquid/Parse.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Parse.hs
@@ -0,0 +1,719 @@
+{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, TupleSections #-}
+
+module Language.Haskell.Liquid.Parse
+ (hsSpecificationP, lhsSpecificationP, specSpecificationP)
+ where
+
+import Control.Monad
+import Text.Parsec
+import Text.Parsec.Error (newErrorMessage, errorPos, Message (..))
+import Text.Parsec.Pos (newPos)
+
+import qualified Text.Parsec.Token as Token
+import qualified Data.HashMap.Strict as M
+import qualified Data.HashSet as S
+
+import Control.Applicative ((<$>), (<*), (<*>))
+import Data.Char (toLower, isLower, isSpace, isAlpha)
+import Data.List (partition)
+import Data.Monoid (mempty)
+
+import GHC (mkModuleName, ModuleName)
+import Text.PrettyPrint.HughesPJ (text)
+
+import Language.Preprocessor.Unlit (unlit)
+
+import Language.Fixpoint.Types
+
+import Language.Haskell.Liquid.GhcMisc
+import Language.Haskell.Liquid.Types
+import Language.Haskell.Liquid.RefType
+import qualified Language.Haskell.Liquid.Measure as Measure
+import Language.Fixpoint.Names (listConName, propConName, tupConName)
+import Language.Fixpoint.Misc hiding (dcolon, dot)
+import Language.Fixpoint.Parse
+
+----------------------------------------------------------------------------
+-- Top Level Parsing API ---------------------------------------------------
+----------------------------------------------------------------------------
+
+-------------------------------------------------------------------------------
+hsSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec)
+-------------------------------------------------------------------------------
+
+hsSpecificationP = parseWithError $ do
+ S name <- try (lookAhead $ skipMany (commentP >> spaces)
+ >> reserved "module" >> symbolP)
+ <|> return (S "Main")
+ liftM (mkSpec (ModName SrcImport $ mkModuleName name)) $ specWraps specP
+
+-------------------------------------------------------------------------------
+lhsSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec)
+-------------------------------------------------------------------------------
+
+lhsSpecificationP sn s = hsSpecificationP sn $ unlit sn s
+
+commentP = simpleComment (string "{-") (string "-}")
+ <|> simpleComment (string "--") newlineP
+ <|> simpleComment (string "\\") newlineP
+ <|> simpleComment (string "#") newlineP
+
+simpleComment open close = open >> manyTill anyChar (try close)
+
+newlineP = try (string "\r\n") <|> string "\n" <|> string "\r"
+
+
+-- | Used to parse .spec files
+
+--------------------------------------------------------------------------
+specSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec)
+--------------------------------------------------------------------------
+specSpecificationP = parseWithError specificationP
+
+specificationP :: Parser (ModName, Measure.BareSpec)
+specificationP
+ = do reserved "module"
+ reserved "spec"
+ S name <- symbolP
+ reserved "where"
+ xs <- grabs (specP <* whiteSpace)
+ return $ mkSpec (ModName SpecImport $ mkModuleName name) xs
+
+---------------------------------------------------------------------------
+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
+
+---------------------------------------------------------------------------
+parseErrorError :: SourceName -> ParseError -> Error
+---------------------------------------------------------------------------
+parseErrorError f e = ErrParse p msg e
+ where
+ p = sourcePosSrcSpan $ errorPos e
+ msg = text $ "Error Parsing Specification from: " ++ f
+
+---------------------------------------------------------------------------
+remParseError :: SourceName -> String -> String -> ParseError
+---------------------------------------------------------------------------
+remParseError f s r = newErrorMessage msg $ newPos f line col
+ where
+ msg = Message "Leftover while parsing"
+ (line, col) = remLineCol s r
+
+remLineCol :: String -> String -> (Int, Int)
+remLineCol src rem = (line, col)
+ where
+ line = 1 + srcLine - remLine
+ srcLine = length srcLines
+ remLine = length remLines
+ col = srcCol - remCol
+ srcCol = length $ srcLines !! (line - 1)
+ remCol = length $ remLines !! 0
+ srcLines = lines $ src
+ remLines = lines $ rem
+
+
+
+----------------------------------------------------------------------------------
+-- Lexer Tokens ------------------------------------------------------------------
+----------------------------------------------------------------------------------
+
+dot = Token.dot lexer
+braces = Token.braces lexer
+angles = Token.angles lexer
+stringLiteral = Token.stringLiteral lexer
+
+----------------------------------------------------------------------------------
+-- BareTypes ---------------------------------------------------------------------
+----------------------------------------------------------------------------------
+
+-- | The top-level parser for "bare" refinement types. If refinements are
+-- not supplied, then the default "top" refinement is used.
+
+bareTypeP :: Parser BareType
+
+bareTypeP
+ = try bareFunP
+ <|> bareAllP
+ <|> bareAllExprP
+ <|> bareExistsP
+ <|> bareAtomP
+
+bareArgP
+ = bareAtomP
+ <|> parens bareTypeP
+
+bareAtomP
+ = refP bbaseP
+ <|> try (dummyP (bbaseP <* spaces))
+
+bbaseP :: Parser (Reft -> BareType)
+bbaseP
+ = liftM2 bLst (brackets bareTypeP) predicatesP
+ <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP
+ <|> try (liftM2 bAppTy lowerIdP bareTyArgP)
+ <|> try (liftM2 bRVar lowerIdP monoPredicateP)
+ <|> liftM3 bCon upperIdP predicatesP (sepBy bareTyArgP blanks)
+
+bbaseNoAppP :: Parser (Reft -> BareType)
+bbaseNoAppP
+ = liftM2 bLst (brackets bareTypeP) predicatesP
+ <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP
+ <|> try (liftM3 bCon upperIdP predicatesP (return []))
+ <|> liftM2 bRVar lowerIdP monoPredicateP
+
+bareTyArgP
+ = try (braces $ liftM RExprArg exprP)
+ <|> try bareAtomNoAppP
+ <|> try (parens bareTypeP)
+
+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
+
+bareExistsP
+ = do reserved "exists"
+ zs <- brackets $ sepBy1 exBindP comma
+ dot
+ t <- bareTypeP
+ return $ foldr (uncurry REx) t zs
+
+exBindP
+ = xyP binderP colon bareTypeP
+
+
+bareAllP
+ = do reserved "forall"
+ as <- many tyVarIdP -- sepBy1 tyVarIdP comma
+ ps <- predVarDefsP
+ dot
+ t <- bareTypeP
+ return $ foldr RAllT (foldr RAllP t ps) as
+
+tyVarIdP :: Parser String
+tyVarIdP = condIdP alphanums (isLower . head)
+ where alphanums = ['a'..'z'] ++ ['0'..'9']
+
+predVarDefsP
+ = try (angles $ sepBy1 predVarDefP comma)
+ <|> return []
+
+predVarDefP
+ = liftM3 bPVar predVarIdP dcolon predVarTypeP
+
+predVarIdP
+ = stringSymbol <$> tyVarIdP
+
+bPVar p _ xts = PV p τ τxs
+ where (_, τ) = safeLast "bPVar last" xts
+ τxs = [ (τ, x, EVar x) | (x, τ) <- init xts ]
+
+predVarTypeP :: Parser [(Symbol, BSort)]
+predVarTypeP = do t <- bareTypeP
+ let (xs, ts, t') = bkArrow $ thd3 $ bkUniv $ t
+ if isPropBareType t'
+ then return $ zip xs (toRSort <$> ts)
+ else parserFail $ "Predicate Variable with non-Prop output sort: " ++ showpp t
+
+
+xyP lP sepP rP
+ = liftM3 (\x _ y -> (x, y)) lP (spaces >> sepP) rP
+
+data ArrowSym = ArrowFun | ArrowPred
+
+arrowP
+ = (reserved "->" >> return ArrowFun)
+ <|> (reserved "=>" >> return ArrowPred)
+
+positionNameP = dummyNamePos <$> getPosition
+
+dummyNamePos pos = "dummy." ++ name ++ ['.'] ++ line ++ ['.'] ++ col
+ where
+ name = san <$> sourceName pos
+ line = show $ sourceLine pos
+ col = show $ sourceColumn pos
+ san '/' = '.'
+ san c = toLower c
+
+bareFunP
+ = do b <- try bindP <|> dummyBindP
+ t1 <- bareArgP
+ a <- arrowP
+ t2 <- bareTypeP
+ return $ bareArrow b t1 a t2
+
+dummyBindP
+ = tempSymbol "db" <$> freshIntP
+ -- = stringSymbol <$> positionNameP
+
+bbindP = lowerIdP <* dcolon
+
+bindP = liftM stringSymbol (lowerIdP <* colon)
+
+bareArrow b t1 ArrowFun t2
+ = rFun b t1 t2
+bareArrow _ t1 ArrowPred t2
+ = foldr (rFun dummySymbol) t2 (getClasses t1)
+
+
+isPropBareType (RApp tc [] _ _) = tc == propConName
+isPropBareType _ = False
+
+
+getClasses (RApp tc ts _ _)
+ | isTuple tc
+ = getClass `fmap` ts
+getClasses t
+ = [getClass t]
+getClass (RApp c ts _ _)
+ = RCls c ts
+getClass t
+ = errorstar $ "Cannot convert " ++ (show t) ++ " to Class"
+
+dummyP :: Monad m => m (Reft -> b) -> m b
+dummyP fm
+ = fm `ap` return dummyReft
+
+refP :: Parser (Reft -> a) -> Parser a
+refP kindP
+ = braces $ do
+ v <- symbolP
+ colon
+ t <- kindP
+ reserved "|"
+ ras <- refasP
+ return $ t (Reft (v, ras))
+
+symsP
+ = do reserved "\\"
+ ss <- sepBy symbolP spaces
+ reserved "->"
+ return $ (, dummyRSort) <$> ss
+ <|> return []
+
+refasP :: Parser [Refa]
+refasP = (try (brackets $ sepBy (RConc <$> predP) semi))
+ <|> liftM ((:[]) . RConc) predP
+
+predicatesP
+ = try (angles $ sepBy1 predicate1P comma)
+ <|> return []
+
+predicate1P
+ = try (liftM2 RPoly symsP (refP bbaseP))
+ <|> liftM (RMono [] . predUReft) monoPredicate1P
+ <|> (braces $ liftM2 bRPoly symsP' refasP)
+ where
+ symsP' = do ss <- symsP
+ fs <- mapM refreshSym (fst <$> ss)
+ return $ zip ss fs
+ refreshSym s = liftM (intSymbol (symbolString s)) freshIntP
+
+monoPredicateP
+ = try (angles monoPredicate1P)
+ <|> return mempty
+
+monoPredicate1P
+ = try (reserved "True" >> return mempty)
+ <|> try (liftM pdVar (parens predVarUseP))
+ <|> liftM pdVar predVarUseP
+
+predVarUseP
+ = do p <- predVarIdP
+ xs <- sepBy exprP spaces
+ return $ PV p dummyTyId [ (dummyTyId, dummySymbol, x) | x <- xs ]
+
+
+------------------------------------------------------------------------
+----------------------- Wrapped Constructors ---------------------------
+------------------------------------------------------------------------
+
+bRPoly [] _ = errorstar "Parse.bRPoly empty list"
+bRPoly syms' expr = RPoly ss $ bRVar dummyName top r
+ where (ss, (v, _)) = (init syms, last syms)
+ syms = [(y, s) | ((_, s), y) <- syms']
+ su = mkSubst [(x, EVar y) | ((x, _), y) <- syms']
+ r = su `subst` Reft(v, expr)
+
+bRVar α p r = RVar α (U r p)
+bLst t rs r = RApp listConName [t] rs (reftUReft r)
+
+bTup [t] _ r | isTauto r = t
+ | otherwise = t `strengthen` (reftUReft r)
+bTup ts rs r = RApp tupConName ts rs (reftUReft r)
+
+bCon b [RMono _ r1] [] r = RApp b [] [] (r1 `meet` (reftUReft r))
+bCon b rs ts r = RApp b ts rs (reftUReft r)
+
+bAppTy v t r = RAppTy (RVar v top) t (reftUReft r)
+
+
+
+
+reftUReft = (`U` mempty)
+predUReft = (U dummyReft)
+dummyReft = top
+dummyTyId = ""
+dummyRSort = ROth "dummy"
+
+------------------------------------------------------------------
+--------------------------- Measures -----------------------------
+------------------------------------------------------------------
+
+data Pspec ty ctor
+ = Meas (Measure.Measure ty ctor)
+ | Assm (LocSymbol, ty)
+ | Assms ([LocSymbol], ty)
+ | Impt Symbol
+ | DDecl DataDecl
+ | Incl FilePath
+ | Invt (Located ty)
+ | Alias (RTAlias String BareType)
+ | PAlias (RTAlias Symbol Pred)
+ | Embed (Located String, FTycon)
+ | Qualif Qualifier
+ | Decr (LocSymbol, [Int])
+ | LVars LocSymbol
+ | Lazy Symbol
+ | Pragma (Located String)
+
+-- mkSpec :: String -> [Pspec ty LocSymbol] -> Measure.Spec ty LocSymbol
+mkSpec name xs = (name,)
+ $ Measure.qualifySpec (getModString name)
+ $ Measure.Spec
+ { Measure.measures = [m | Meas m <- xs]
+ , Measure.sigs = [a | Assm a <- xs]
+ ++ [(y, t) | Assms (ys, t) <- xs, y <- ys]
+ , Measure.invariants = [t | Invt t <- xs]
+ , Measure.imports = [i | Impt i <- xs]
+ , Measure.dataDecls = [d | DDecl d <- xs]
+ , Measure.includes = [q | Incl q <- xs]
+ , Measure.aliases = [a | Alias a <- xs]
+ , Measure.paliases = [p | PAlias p <- xs]
+ , Measure.embeds = M.fromList [e | Embed e <- xs]
+ , 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.pragmas = [s | Pragma s <- xs]
+ }
+
+specP :: Parser (Pspec BareType Symbol)
+specP
+ = try (reserved "assume" >> liftM Assm tyBindP )
+ <|> (reserved "assert" >> liftM Assm tyBindP )
+ <|> (reserved "measure" >> liftM Meas measureP )
+ <|> (reserved "import" >> liftM Impt symbolP )
+ <|> (reserved "data" >> liftM DDecl dataDeclP )
+ <|> (reserved "include" >> liftM Incl filePathP )
+ <|> (reserved "invariant" >> liftM Invt invariantP)
+ <|> (reserved "type" >> liftM Alias aliasP )
+ <|> (reserved "predicate" >> liftM PAlias paliasP )
+ <|> (reserved "embed" >> liftM Embed embedP )
+ <|> (reserved "qualif" >> liftM Qualif qualifierP)
+ <|> (reserved "Decrease" >> liftM Decr decreaseP )
+ <|> (reserved "LAZYVAR" >> liftM LVars lazyVarP )
+ <|> (reserved "Strict" >> liftM Lazy lazyP )
+ <|> (reserved "Lazy" >> liftM Lazy lazyP )
+ <|> (reserved "LIQUID" >> liftM Pragma pragmaP )
+ <|> ({- DEFAULT -} liftM Assms tyBindsP )
+
+pragmaP :: Parser (Located String)
+pragmaP = locParserP $ stringLiteral
+
+lazyP :: Parser Symbol
+lazyP = binderP
+
+lazyVarP :: Parser LocSymbol
+lazyVarP = locParserP binderP
+
+decreaseP :: Parser (LocSymbol, [Int])
+decreaseP = mapSnd f <$> liftM2 (,) (locParserP binderP) (spaces >> (many integer))
+ where f = ((\n -> fromInteger n - 1) <$>)
+
+filePathP :: Parser FilePath
+filePathP = angles $ many1 pathCharP
+ where
+ pathCharP = choice $ char <$> pathChars
+ pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/']
+
+tyBindsP :: Parser ([LocSymbol], BareType)
+tyBindsP = xyP (sepBy (locParserP binderP) comma) dcolon genBareTypeP
+
+tyBindP :: Parser (LocSymbol, BareType)
+tyBindP = xyP (locParserP binderP) dcolon genBareTypeP
+
+locParserP :: Parser a -> Parser (Located a)
+locParserP p = liftM2 Loc getPosition p
+
+invariantP = locParserP genBareTypeP
+
+genBareTypeP
+ = bareTypeP -- liftM generalize bareTypeP
+
+embedP
+ = xyP (locParserP upperIdP) (reserved "as") fTyConP
+
+
+aliasP = rtAliasP id bareTypeP
+paliasP = rtAliasP stringSymbol predP
+
+rtAliasP f bodyP
+ = do pos <- getPosition
+ name <- upperIdP
+ spaces
+ args <- sepBy aliasIdP spaces
+ whiteSpace >> reservedOp "=" >> whiteSpace
+ body <- bodyP
+ let (tArgs, vArgs) = partition (isLower . head) args
+ return $ RTA name (f <$> tArgs) (f <$> vArgs) body pos
+
+aliasIdP :: Parser String
+aliasIdP = condIdP (['A' .. 'Z'] ++ ['a'..'z'] ++ ['0'..'9']) (isAlpha . head)
+
+measureP :: Parser (Measure.Measure BareType Symbol)
+measureP
+ = do (x, ty) <- tyBindP
+ whiteSpace
+ eqns <- grabs $ measureDefP $ (rawBodyP <|> tyBodyP ty)
+ return $ Measure.mkM x ty eqns
+
+rawBodyP
+ = braces $ do
+ v <- symbolP
+ reserved "|"
+ p <- predP
+ return $ Measure.R v p
+
+-- tyBodyP :: BareType -> Parser Measure.Body
+tyBodyP ty
+ = case outTy ty of
+ Just bt | isPropBareType bt -> Measure.P <$> predP
+ _ -> Measure.E <$> exprP
+ where outTy (RAllT _ t) = outTy t
+ outTy (RAllP _ t) = outTy t
+ outTy (RFun _ _ t _) = Just t
+ outTy _ = Nothing
+
+binderP :: Parser Symbol
+binderP = try $ stringSymbol <$> idP badc
+ <|> pwr <$> parens (idP bad)
+ where
+ idP p = many1 (satisfy (not . p))
+ badc c = (c == ':') || (c == ',') || bad c
+ bad c = isSpace c || c `elem` "(,)"
+ pwr s = stringSymbol $ "(" ++ s ++ ")"
+
+grabs p = try (liftM2 (:) p (grabs p))
+ <|> return []
+
+measureDefP :: Parser Measure.Body -> Parser (Measure.Def Symbol)
+measureDefP bodyP
+ = do mname <- locParserP symbolP
+ (c, xs) <- {- ORIGINAL parens $ -} measurePatP
+ whiteSpace >> reservedOp "=" >> whiteSpace
+ body <- bodyP
+ whiteSpace
+ let xs' = (stringSymbol . val) <$> xs
+ return $ Measure.Def mname (stringSymbol c) xs' body
+
+-- ORIGINAL
+-- measurePatP :: Parser (String, [LocString])
+-- measurePatP
+-- = try (liftM2 (,) upperIdP (sepBy locLowerIdP whiteSpace))
+-- <|> try (liftM3 (\x c y -> (c, [x,y])) locLowerIdP colon locLowerIdP)
+-- <|> (brackets whiteSpace >> return ("[]",[]))
+
+measurePatP :: Parser (String, [LocString])
+measurePatP
+ = try tupPatP
+ <|> try (parens conPatP)
+ <|> try (parens consPatP)
+ <|> (parens nilPatP)
+
+tupPatP = mkTupPat <$> (parens $ sepBy locLowerIdP comma)
+conPatP = (,) <$> dataConNameP <*> sepBy locLowerIdP whiteSpace
+consPatP = mkConsPat <$> locLowerIdP <*> colon <*> locLowerIdP
+nilPatP = mkNilPat <$> brackets whiteSpace
+
+mkTupPat zs = (tupDataCon (length zs), zs)
+mkNilPat _ = ("[]", [] )
+mkConsPat x c y = (":" , [x, y])
+
+tupDataCon n = "(" ++ replicate (n - 1) ',' ++ ")"
+locLowerIdP = locParserP lowerIdP
+
+{- len (Cons x1 x2 ...) = e -}
+
+
+-------------------------------------------------------------------------------
+--------------------------------- Predicates ----------------------------------
+-------------------------------------------------------------------------------
+
+dataConFieldsP
+ = (braces $ sepBy predTypeDDP comma)
+ <|> (sepBy (parens predTypeDDP) spaces)
+
+predTypeDDP
+ = liftM2 (,) bbindP bareTypeP
+
+dataConP
+ = do x <- dataConNameP
+ spaces
+ xts <- dataConFieldsP
+ return (x, xts)
+
+-- dataConNameP = symbolString <$> binderP -- upperIdP
+dataConNameP
+ = try upperIdP
+ <|> pwr <$> parens (idP bad)
+ where
+ idP p = many1 (satisfy (not . p))
+ bad c = isSpace c || c `elem` "(,)"
+ pwr s = "(" ++ s ++ ")"
+
+dataSizeP
+ = (brackets $ (Just . mkFun) <$> lowerIdP)
+ <|> return Nothing
+ where mkFun s = \x -> EApp (stringSymbol s) [EVar x]
+
+dataDeclP
+ = do pos <- getPosition
+ x <- upperIdP
+ spaces
+ fsize <- dataSizeP
+ spaces
+ ts <- sepBy tyVarIdP spaces
+ ps <- predVarDefsP
+ whiteSpace >> reservedOp "=" >> whiteSpace
+ dcs <- sepBy dataConP (reserved "|")
+ whiteSpace
+ -- spaces
+ -- reservedOp "--"
+ return $ D x ts ps dcs pos fsize
+
+---------------------------------------------------------------------
+------------ Interacting with Fixpoint ------------------------------
+---------------------------------------------------------------------
+
+grabUpto p
+ = try (lookAhead p >>= return . Just)
+ <|> try (eof >> return Nothing)
+ <|> (anyChar >> grabUpto p)
+
+betweenMany leftP rightP p
+ = do z <- grabUpto leftP
+ case z of
+ Just _ -> liftM2 (:) (between leftP rightP p) (betweenMany leftP rightP p)
+ Nothing -> return []
+
+-- specWrap = between (string "{-@" >> spaces) (spaces >> string "@-}")
+specWraps = betweenMany (string "{-@" >> spaces) (spaces >> string "@-}")
+
+----------------------------------------------------------------------------------------
+------------------------ Bundling Parsers into a Typeclass -----------------------------
+----------------------------------------------------------------------------------------
+
+instance Inputable BareType where
+ rr' = doParse' bareTypeP
+
+instance Inputable (Measure.Measure BareType Symbol) where
+ rr' = doParse' measureP
+
+
+{-
+---------------------------------------------------------------
+--------------------------- Testing ---------------------------
+---------------------------------------------------------------
+
+sa = "0"
+sb = "x"
+sc = "(x0 + y0 + z0) "
+sd = "(x+ y * 1)"
+se = "_|_ "
+sf = "(1 + x + _|_)"
+sg = "f(x,y,z)"
+sh = "(f((x+1), (y * a * b - 1), _|_))"
+si = "(2 + f((x+1), (y * a * b - 1), _|_))"
+
+s0 = "true"
+s1 = "false"
+s2 = "v > 0"
+s3 = "(0 < v && v < 100)"
+s4 = "(x < v && v < y+10 && v < z)"
+s6 = "[(v > 0)]"
+s6' = "x"
+s7' = "(x <=> y)"
+s8' = "(x <=> a = b)"
+s9' = "(x <=> (a <= b && b < c))"
+
+s7 = "{ v: Int | [(v > 0)] }"
+s8 = "x:{ v: Int | v > 0 } -> {v : Int | v >= x}"
+s9 = "v = x+y"
+s10 = "{v: Int | v = x + y}"
+
+s11 = "x:{v:Int | true } -> {v:Int | true }"
+s12 = "y : {v:Int | true } -> {v:Int | v = x }"
+s13 = "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}"
+s14 = "x:{v:a | true} -> y:{v:b | true } -> {v:a | (x < v && v < y) }"
+s15 = "x:Int -> Bool"
+s16 = "x:Int -> y:Int -> {v:Int | v = x + y}"
+s17 = "a"
+s18 = "x:a -> Bool"
+s20 = "forall a . x:Int -> Bool"
+
+s21 = "x:{v : GHC.Prim.Int# | true } -> {v : Int | true }"
+
+r0 = (rr s0) :: Pred
+r0' = (rr s0) :: [Refa]
+r1 = (rr s1) :: [Refa]
+
+
+e1, e2 :: Expr
+e1 = rr "(k_1 + k_2)"
+e2 = rr "k_1"
+
+o1, o2, o3 :: FixResult Integer
+o1 = rr "SAT "
+o2 = rr "UNSAT [1, 2, 9,10]"
+o3 = rr "UNSAT []"
+
+-- sol1 = doParse solution1P "solution: k_5 := [0 <= VV_int]"
+-- sol2 = doParse solution1P "solution: k_4 := [(0 <= VV_int)]"
+
+b0, b1, b2, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13 :: BareType
+b0 = rr "Int"
+b1 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}"
+b2 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y}"
+b4 = rr "forall a . x : a -> Bool"
+b5 = rr "Int -> Int -> Int"
+b6 = rr "(Int -> Int) -> Int"
+b7 = rr "({v: Int | v > 10} -> Int) -> Int"
+b8 = rr "(x:Int -> {v: Int | v > x}) -> {v: Int | v > 10}"
+b9 = rr "x:Int -> {v: Int | v > x} -> {v: Int | v > 10}"
+b10 = rr "[Int]"
+b11 = rr "x:[Int] -> {v: Int | v > 10}"
+b12 = rr "[Int] -> String"
+b13 = rr "x:(Int, [Bool]) -> [(String, String)]"
+
+-- b3 :: BareType
+-- b3 = rr "x:Int -> y:Int -> {v:Bool | ((v is True) <=> x = y)}"
+
+m1 = ["len :: [a] -> Int", "len (Nil) = 0", "len (Cons x xs) = 1 + len(xs)"]
+m2 = ["tog :: LL a -> Int", "tog (Nil) = 100", "tog (Cons y ys) = 200"]
+
+me1, me2 :: Measure.Measure BareType Symbol
+me1 = (rr $ intercalate "\n" m1)
+me2 = (rr $ intercalate "\n" m2)
+-}
diff --git a/Language/Haskell/Liquid/PredType.hs b/Language/Haskell/Liquid/PredType.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/PredType.hs
@@ -0,0 +1,431 @@
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances, TupleSections #-}
+module Language.Haskell.Liquid.PredType (
+ PrType
+ , TyConP (..), DataConP (..)
+ , dataConTy, dataConPSpecType, makeTyConInfo
+ , unify, replacePreds, exprType, predType
+ , replacePredsWithRefs, pVartoRConc, toPredType
+ , substParg
+ , pApp
+ , wiredSortedSyms
+ ) where
+
+-- import PprCore (pprCoreExpr)
+import Id (idType)
+import CoreSyn hiding (collectArgs)
+import Type
+import TypeRep
+import qualified TyCon as TC
+import Literal
+import Coercion (coercionType, coercionKind)
+import Pair (pSnd)
+import FastString (sLit)
+import qualified Outputable as O
+import Text.PrettyPrint.HughesPJ
+import DataCon
+
+import qualified Data.HashMap.Strict as M
+import qualified Data.HashSet as S
+import Data.List (partition, foldl')
+import Data.Monoid (mempty)
+
+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.RefType hiding (generalize)
+import Language.Haskell.Liquid.GhcMisc
+
+import Control.Applicative ((<$>))
+import Control.Monad.State
+
+makeTyConInfo = hashMapMapWithKey mkRTyCon . M.fromList
+
+mkRTyCon :: TC.TyCon -> TyConP -> RTyCon
+mkRTyCon tc (TyConP αs' ps cv conv size) = RTyCon tc pvs' (mkTyConInfo tc cv conv size)
+ where τs = [rVar α :: RSort | α <- TC.tyConTyVars tc]
+ pvs' = subts (zip αs' τs) <$> ps
+
+dataConPSpecType :: DataCon -> DataConP -> SpecType
+dataConPSpecType dc (DataConP vs ps yts rt) = mkArrow vs ps (reverse yts') rt'
+ where (xs, ts) = unzip yts
+ ys = mkDSym <$> xs
+ su = F.mkSubst $ [(x, F.EVar y) | (x, y) <- zip xs ys]
+ yts' = zip ys (subst su <$> ts)
+ rt' = subst su rt
+ mkDSym = stringSymbol . (++ ('_':(showPpr dc))) . show
+-- where t1 = foldl' (\t2 (x, t1) -> rFun x t1 t2) rt yts
+-- t2 = foldr RAllP t1 ps
+-- t3 = foldr RAllT t2 vs
+
+
+instance PPrint TyConP where
+ pprint (TyConP vs ps _ _ _)
+ = (parens $ hsep (punctuate comma (map pprint vs))) <+>
+ (parens $ hsep (punctuate comma (map pprint ps)))
+
+instance Show TyConP where
+ show = showpp -- showSDoc . ppr
+
+instance PPrint DataConP where
+ pprint (DataConP vs ps yts t)
+ = (parens $ hsep (punctuate comma (map pprint vs))) <+>
+ (parens $ hsep (punctuate comma (map pprint ps))) <+>
+ (parens $ hsep (punctuate comma (map pprint yts))) <+>
+ pprint t
+
+instance Show DataConP where
+ show = showpp
+
+dataConTy m (TyVarTy v)
+ = M.lookupDefault (rVar v) (RTV v) m
+dataConTy m (FunTy t1 t2)
+ = rFun dummySymbol (dataConTy m t1) (dataConTy m t2)
+dataConTy m (ForAllTy α t)
+ = RAllT (rTyVar α) (dataConTy m t)
+dataConTy _ t
+ | Just t' <- ofPredTree (classifyPredType t)
+ = t'
+dataConTy m (TyConApp c ts)
+ = rApp c (dataConTy m <$> ts) [] mempty
+dataConTy _ _
+ = error "ofTypePAppTy"
+
+---------------------------------------------------------------------------
+-------------- Interfacing Between Predicates and Refinements -------------
+---------------------------------------------------------------------------
+
+---------------------------------------------------------------------------
+--------------Interfacing: Unify PrType with SpecType ---------------------
+---------------------------------------------------------------------------
+
+unify :: Maybe PrType -> SpecType -> SpecType
+unify (Just pt) rt = evalState (unifyS rt pt) S.empty
+unify _ t = t
+
+---------------------------------------------------------------------------
+unifyS :: SpecType -> PrType -> State (S.HashSet UsedPVar) SpecType
+---------------------------------------------------------------------------
+
+unifyS (RAllP p t) pt
+ = do t' <- unifyS t pt
+ s <- get
+ put $ S.delete (uPVar p) s
+ if (uPVar p `S.member` s) then return $ RAllP p t' else return t'
+
+unifyS t (RAllP p pt)
+ = do t' <- unifyS t pt
+ s <- get
+ put $ S.delete (uPVar p) s
+ if (uPVar p `S.member` s) then return $ RAllP p t' else return t'
+
+unifyS (RAllT (v@(RTV α)) t) (RAllT v' pt)
+ = do t' <- unifyS t $ subsTyVar_meet (v', (rVar α) :: RSort, RVar v mempty) pt
+ return $ RAllT v t'
+
+unifyS (RFun x rt1 rt2 _) (RFun x' pt1 pt2 _)
+ = do t1' <- unifyS rt1 pt1
+ t2' <- unifyS rt2 (substParg (x', EVar x) pt2)
+ return $ rFun x t1' t2'
+
+unifyS (RAppTy rt1 rt2 _) (RAppTy pt1 pt2 _)
+ = do t1' <- unifyS rt1 pt1
+ t2' <- unifyS rt2 pt2
+ return $ rAppTy t1' t2'
+
+unifyS t@(RCls _ _) (RCls _ _)
+ = return t
+
+unifyS (RVar v a) (RVar _ p)
+ = do modify $ \s -> s `S.union` (S.fromList $ pvars p) -- (filter (/= PdTrue) [p]))
+ return $ RVar v $ bUnify a p
+
+unifyS (RApp c ts rs r) (RApp _ pts ps p)
+ = do modify $ \s -> s `S.union` fm
+ ts' <- zipWithM unifyS ts pts
+ return $ RApp c ts' rs' (bUnify r p)
+ where fm = S.fromList $ concatMap pvars (fp:fps)
+ fp : fps = p : (getR <$> ps)
+ rs' = zipWithZero unifyRef (RMono [] top {- trueReft -}) mempty rs fps
+ getR (RMono _ r) = r
+ getR (RPoly _ _) = top
+
+unifyS (RAllE x tx t) (RAllE x' tx' t') | x == x'
+ = liftM2 (RAllE x) (unifyS tx tx') (unifyS t t')
+
+unifyS (REx x tx t) (REx x' tx' t') | x == x'
+ = liftM2 (REx x) (unifyS tx tx') (unifyS t t')
+
+unifyS t (REx x' tx' t')
+ = liftM (REx x' (U top <$> tx')) (unifyS t t')
+
+unifyS t@(RVar v a) (RAllE x' tx' t')
+ = liftM (RAllE x' (U top <$> tx')) (unifyS t t')
+
+unifyS t1 t2
+ = error ("unifyS" ++ show t1 ++ " with " ++ show t2)
+
+bUnify a (Pr pvs) = foldl' meet a $ pToReft <$> pvs
+
+unifyRef (RMono s a) (Pr pvs) = RMono s $ foldl' meet a $ pToReft <$> pvs
+unifyRef (RPoly s a) (Pr pvs) = RPoly s $ foldl' strengthen a $ pToReft <$> pvs
+
+zipWithZero _ _ _ [] [] = []
+zipWithZero f xz yz [] (y:ys) = (f xz y):(zipWithZero f xz yz [] ys)
+zipWithZero f xz yz (x:xs) [] = (f x yz):(zipWithZero f xz yz xs [])
+zipWithZero f xz yz (x:xs) (y:ys) = (f x y) :(zipWithZero f xz yz xs ys)
+
+-- pToReft p = Reft (vv, [RPvar p])
+pToReft = U top . pdVar
+
+----------------------------------------------------------------------------
+----- Interface: Replace Predicate With Uninterprented Function Symbol -----
+----------------------------------------------------------------------------
+
+replacePredsWithRefs (p, r) (U (Reft(v, rs)) (Pr ps))
+ = U (Reft (v, rs ++ rs')) (Pr ps2)
+ where rs' = r . (v,) . pargs <$> ps1
+ (ps1, ps2) = partition (==p) ps
+ freeSymbols = snd3 <$> filter (\(_, x, y) -> EVar x == y) pargs1
+ pargs1 = concatMap pargs ps1
+
+pVartoRConc p (v, args)
+ = RConc $ pApp (pname p) $ EVar v:(thd3 <$> args)
+
+toPredType (PV _ ptype args) = rpredType (ty:tys)
+ where ty = uRTypeGen ptype
+ tys = uRTypeGen . fst3 <$> args
+
+
+----------------------------------------------------------------------------
+---------- Interface: Replace Predicate With Type -------------------------
+----------------------------------------------------------------------------
+
+-- | This is the main function used to substitute an (abstract) predicate
+-- with a concrete Ref, of a compound (`RPoly`) 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`.
+-- That is, there are no further `PVar` in the target.
+
+-------------------------------------------------------------------------------
+
+replacePreds :: String -> SpecType -> [(RPVar, Ref RSort RReft SpecType)] -> SpecType
+replacePreds msg = foldl' go
+ where go z (π, t@(RPoly _ _)) = substPred msg (π, t) z
+ go _ (_, RMono _ _) = error "replacePreds on RMono" -- replacePVarReft (π, r) <$> z
+
+
+-- TODO: replace `replacePreds` with
+-- 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
+-- where go z (π, RPoly t) = substPred msg (π, t) z
+-- go z (π, RMono r) = replacePVarReft (π, r) <$> z
+
+-------------------------------------------------------------------------------
+substPred :: String -> (RPVar, Ref RSort RReft SpecType) -> SpecType -> SpecType
+-------------------------------------------------------------------------------
+
+substPred _ (π, RPoly ss (RVar a1 r1)) t@(RVar a2 r2)
+ | isPredInReft && a1 == a2 = RVar a1 $ meetListWithPSubs πs ss r1 r2'
+ | isPredInReft = errorstar ("substPred RVar Var Mismatch" ++ show (a1, a2))
+ | otherwise = t
+ where (r2', πs) = splitRPvar π r2
+ isPredInReft = not $ null πs
+
+substPred msg su@(π, _ ) (RApp c ts rs r)
+ | null πs = t'
+ | otherwise = substRCon msg su t' πs r2'
+ where t' = RApp c (substPred msg su <$> ts) (substPredP su <$> rs) r
+ (r2', πs) = splitRPvar π r
+
+substPred msg (p, tp) (RAllP (q@(PV _ _ _)) t)
+ | p /= q = RAllP q $ substPred msg (p, tp) 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)
+ | 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
+
+substPred msg pt (RCls c ts) = RCls c (substPred msg pt <$> ts)
+
+substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t')
+substPred msg su (REx x t t') = REx x (substPred msg su t) (substPred msg su t')
+
+substPred _ _ t = t
+
+-- | Requires: @not $ null πs@
+-- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType
+
+substRCon msg (_, RPoly ss (RApp c1 ts1 rs1 r1)) (RApp c2 ts2 rs2 _) πs r2'
+ | rTyCon c1 == rTyCon c2 = RApp c1 ts rs $ meetListWithPSubs πs ss r1 r2'
+ where ts = safeZipWith (msg ++ ": substRCon") strSub ts1 ts2
+ rs = safeZipWith (msg ++ ": substRcon2") strSubR rs1 rs2
+ strSub r1 r2 = meetListWithPSubs πs ss r1 r2
+ strSubR r1 r2 = meetListWithPSubsRef πs ss r1 r2
+
+substRCon msg su t _ _ = errorstar $ msg ++ " substRCon " ++ showpp (su, t)
+
+substPredP su@(p, RPoly ss tt) (RPoly s t)
+ = RPoly ss' $ substPred "substPredP" su t
+ where ss' = if isPredInType p t then (ss ++ s) else s
+
+substPredP _ (RMono _ _)
+ = error $ "RMono found in substPredP"
+
+splitRPvar pv (U x (Pr pvs)) = (U x (Pr pvs'), epvs)
+ where (epvs, pvs') = partition (uPVar pv ==) pvs
+
+
+isPredInType p (RVar _ r)
+ = isPredInURef p r
+isPredInType p (RFun _ t1 t2 r)
+ = isPredInURef p r || isPredInType p t1 || isPredInType p t2
+isPredInType p (RAllT _ t)
+ = isPredInType p t
+isPredInType p (RAllP p' t)
+ = not (p == p') && isPredInType p t
+isPredInType p (RApp _ ts _ r)
+ = isPredInURef p r || any (isPredInType p) ts
+isPredInType p (RCls _ ts)
+ = any (isPredInType p) ts
+isPredInType p (RAllE _ t1 t2)
+ = isPredInType p t1 || isPredInType p t2
+isPredInType p (RAppTy t1 t2 r)
+ = isPredInURef p r || isPredInType p t1 || isPredInType p t2
+isPredInType _ (RExprArg _)
+ = False
+isPredInType _ (ROth _)
+ = False
+
+isPredInURef p (U _ (Pr ps)) = any (uPVar p ==) ps
+
+
+meetListWithPSubs πs ss r1 r2 = foldl' (meetListWithPSub ss r1) r2 πs
+meetListWithPSubsRef πs ss r1 r2 = foldl' ((meetListWithPSubRef ss) r1) r2 πs
+
+-- meetListWithPSub :: (Reftable r, PPrint t) => [(Symbol, RSort)]-> r -> r -> PVar t -> r
+meetListWithPSub ss r1 r2 π
+ | all (\(_, x, EVar y) -> x == y) (pargs π)
+ = r2 `meet` r1
+ | all (\(_, x, EVar y) -> x /= y) (pargs π)
+ = r2 `meet` (subst su r1)
+ | otherwise
+ = errorstar $ "PredType.meetListWithPSub partial application to " ++ showpp π
+ where su = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]
+
+meetListWithPSubRef ss (RPoly s1 r1) (RPoly s2 r2) π
+ | all (\(_, x, EVar y) -> x == y) (pargs π)
+ = RPoly s1 $ r2 `meet` r1
+ | all (\(_, x, EVar y) -> x /= y) (pargs π)
+ = RPoly s2 $ r2 `meet` (subst su r1)
+ | otherwise
+ = errorstar $ "PredType.meetListWithPSubRef partial application to " ++ showpp π
+ where su = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> s1) (pargs π)]
+
+
+----------------------------------------------------------------------------
+---------- Interface: Modified CoreSyn.exprType due to predApp -------------
+----------------------------------------------------------------------------
+
+predName :: String
+predName = "Pred"
+
+predType :: Type
+predType = TyVarTy $ stringTyVar predName
+
+rpredType :: Reftable r => [RRType r] -> RRType r
+rpredType ts = RApp tyc ts [] top
+ where
+ tyc = RTyCon (stringTyCon 'x' 42 predName) [] defaultTyConInfo
+
+defaultTyConInfo = TyConInfo [] [] [] [] Nothing
+
+----------------------------------------------------------------------------
+exprType :: CoreExpr -> Type
+----------------------------------------------------------------------------
+
+exprType (App e1 (Var v)) | eqType (idType v) predType = exprType e1
+exprType (Var var) = idType var
+exprType (Lit lit) = literalType lit
+exprType (Coercion co) = coercionType co
+exprType (Let _ body) = exprType body
+exprType (Case _ _ ty _) = ty
+exprType (Cast _ co) = pSnd (coercionKind co)
+exprType (Tick _ e) = exprType e
+exprType (Lam binder expr) = mkPiType binder (exprType expr)
+exprType e@(App _ _)
+ = case collectArgs e of
+ (fun, args) -> applyTypeToArgs e (exprType fun) args
+exprType _ = error "PredType : exprType"
+
+-- | Takes a nested application expression and returns the the function
+-- being applied and the arguments to which it is applied
+collectArgs :: Expr b -> (Expr b, [Arg b])
+collectArgs expr
+ = go expr []
+ where
+ go (App f (Var v)) as | eqType (idType v) predType = go f as
+ go (App f a) as = go f (a:as)
+ go e as = (e, as)
+
+
+-- | A more efficient version of 'applyTypeToArg' when we have several arguments.
+-- The first argument is just for debugging, and gives some context
+-- RJ: This function is UGLY. Two nested levels of where is a BAD idea.
+-- Please fix.
+
+applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
+
+applyTypeToArgs _ op_ty [] = op_ty
+
+applyTypeToArgs e op_ty (Type ty : args)
+ = -- Accumulate type arguments so we can instantiate all at once
+ go [ty] args
+ where
+ go rev_tys (Type ty : args) = go (ty:rev_tys) args
+ go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
+ where
+ op_ty' = applyTysD msg op_ty (reverse rev_tys)
+ msg = O.text ("MYapplyTypeToArgs: " ++ panic_msg e op_ty)
+
+
+applyTypeToArgs e op_ty (_ : args)
+ = case (splitFunTy_maybe op_ty) of
+ Just (_, res_ty) -> applyTypeToArgs e res_ty args
+ Nothing -> errorstar $ "MYapplyTypeToArgs" ++ panic_msg e op_ty
+
+panic_msg :: CoreExpr -> Type -> String
+panic_msg e op_ty = showPpr e ++ " :: " ++ showPpr op_ty
+
+substParg :: Functor f => (Symbol, F.Expr) -> f Predicate -> f Predicate
+substParg (x, y) = fmap fp -- RJ: UNIFY: BUG mapTy fxy
+ where fxy s = if (s == EVar x) then y else s
+ fp = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv })
+
+-------------------------------------------------------------------------------
+----------------------------- Predicate Application --------------------------
+-------------------------------------------------------------------------------
+
+pappArity = 2
+
+pappSym n = S $ "papp" ++ show n
+
+pappSort n = FFunc (2 * n) $ [ptycon] ++ args ++ [bSort]
+ where ptycon = FApp predFTyCon $ FVar <$> [0..n-1]
+ args = FVar <$> [n..(2*n-1)]
+ bSort = FApp boolFTyCon []
+
+wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]
+
+predFTyCon = stringFTycon predName
+
+pApp :: Symbol -> [F.Expr] -> Pred
+pApp p es= PBexp $ EApp (pappSym $ length es) (EVar p:es)
+
diff --git a/Language/Haskell/Liquid/Predicates.hs b/Language/Haskell/Liquid/Predicates.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Predicates.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances, TupleSections, DeriveDataTypeable, BangPatterns #-}
+module Language.Haskell.Liquid.Predicates (
+ generatePredicates
+ ) where
+
+
+import Var
+import OccName (mkTyVarOcc)
+import Name (mkInternalName)
+import Unique (initTyVarUnique)
+import SrcLoc
+import CoreSyn
+import qualified DataCon as TC
+import IdInfo
+
+import Language.Haskell.Liquid.Types
+import Language.Haskell.Liquid.Bare
+import Language.Haskell.Liquid.GhcInterface
+import Language.Haskell.Liquid.PredType hiding (exprType)
+import Language.Haskell.Liquid.RefType hiding (generalize)
+import Language.Fixpoint.Misc
+import qualified Language.Fixpoint.Types as F
+
+import Control.Applicative ((<$>))
+
+----------------------------------------------------------------------
+---- Predicate Environments ------------------------------------------
+----------------------------------------------------------------------
+
+
+generatePredicates :: GhcInfo -> ([CoreSyn.Bind CoreBndr], F.SEnv PrType)
+generatePredicates info = {-trace ("Predicates\n" ++ show γ ++ "PredCBS" ++ show cbs')-} (cbs', nPd)
+ where -- WHAT?! All the predicate constraint stuff is DEAD CODE?!!
+ -- γ = fmap removeExtPreds (penv $ evalState act (initPI $ tconsP $ spec info))
+ -- act = consAct info
+ cbs' = addPredApp nPd <$> cbs info
+ nPd = getNeedPd $ spec info
+
+getNeedPd spec
+ = F.fromListSEnv bs
+ where dcs = concatMap mkDataConIdsTy [(x, dataConPtoPredTy x y) | (x, y) <- dconsP spec]
+ assms = (mapSnd (mapReft ur_pred . val)) <$> tySigs spec
+ bs = mapFst varSymbol <$> (dcs ++ assms)
+
+dataConPtoPredTy :: TC.DataCon -> DataConP -> PrType
+dataConPtoPredTy dc = fmap ur_pred . (dataConPSpecType dc)
+
+
+
+addPredApp γ (NonRec b e) = NonRec b $ thd3 $ pExpr γ e
+addPredApp γ (Rec ls) = Rec $ zip xs es'
+ where es' = (thd3. pExpr γ) <$> es
+ (xs, es) = unzip ls
+
+pExpr γ e
+ = if (a == 0 && p /= 0)
+ then (0, 0, foldl App e' ps)
+ else (0, p, e')
+ where (a, p, e') = pExprN γ e
+ ps = (\n -> stringArg ("p" ++ show n)) <$> [1 .. p]
+
+pExprN γ (App e1 e2) =
+ let (_, _, e2') = pExprN γ e2 in
+ if (a1 == 0)
+ then (0, 0, (App (foldl App e1' ps) e2'))
+ else (a1-1, p1, (App e1' e2'))
+ where ps = (\n -> stringArg ("p" ++ show n)) <$> [1 .. p1]
+ (a1, p1, e1') = pExprN γ e1
+
+pExprN γ (Lam x e) = (0, 0, Lam x e')
+ where (_, _, e') = pExpr γ e
+
+pExprN γ (Var v) | isSpecialId γ v
+ = (a, p, (Var v))
+ where (a, p) = varPredArgs γ v
+
+pExprN _ (Var v) = (0, 0, Var v)
+
+pExprN γ (Let (NonRec x1 e1) e) = (0, 0, Let (NonRec x1 e1') e')
+ where (_, _, e') = pExpr γ e
+ (_, _, e1') = pExpr γ e1
+
+pExprN γ (Let bds e) = (0, 0, Let bds' e')
+ where (_, _, e') = pExpr γ e
+ bds' = addPredApp γ bds
+pExprN γ (Case e b t es) = (0, 0, Case e' b t (map (pExprNAlt γ ) es))
+ where e' = thd3 $ pExpr γ e
+
+pExprN γ (Tick n e) = (a, p, Tick n e')
+ where (a, p, e') = pExprN γ e
+
+pExprN _ e@(Type _) = (0, 0, e)
+pExprN _ e@(Lit _) = (0, 0, e)
+pExprN _ e = (0, 0, e)
+
+pExprNAlt γ (x, y, e) = (x, y, e')
+ where e' = thd3 $ pExpr γ e
+
+stringArg s = Var $ mkGlobalVar idDet name predType idInfo
+ where idDet = coVarDetails
+ name = mkInternalName initTyVarUnique occ noSrcSpan
+ occ = mkTyVarOcc s
+ idInfo = vanillaIdInfo
+
+isSpecialId γ x = pl /= 0
+ where (_, pl) = varPredArgs γ x
+
+varPredArgs γ x = varPredArgs_ (F.lookupSEnv (varSymbol x) γ)
+varPredArgs_ Nothing = (0, 0)
+varPredArgs_ (Just t) = (length vs, length ps)
+ where (vs, ps, _) = bkUniv t
+
diff --git a/Language/Haskell/Liquid/PrettyPrint.hs b/Language/Haskell/Liquid/PrettyPrint.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/PrettyPrint.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+-- | Module with all the printing routines
+
+module Language.Haskell.Liquid.PrettyPrint (
+
+ -- * Printing RType
+ ppr_rtype
+
+ -- * Converting To String
+ , showpp
+
+ -- * Printing an Orderable List
+ , pprManyOrdered
+ ) where
+
+import ErrUtils (ErrMsg)
+import HscTypes (SourceError)
+import SrcLoc (SrcSpan)
+import GHC (Name)
+import TcType (tidyType)
+import VarEnv (emptyTidyEnv)
+import Language.Haskell.Liquid.GhcMisc
+import Text.PrettyPrint.HughesPJ
+import Language.Fixpoint.Types hiding (Predicate)
+import Language.Fixpoint.Misc
+import Language.Haskell.Liquid.Types
+import Language.Fixpoint.Names (dropModuleNames, symSepName, funConName, listConName, tupConName, propConName, boolConName)
+import TypeRep hiding (maybeParen, pprArrowChain)
+import Text.Parsec.Pos (SourcePos)
+import Text.Parsec.Error (ParseError)
+import Var (Var)
+import Control.Applicative ((<$>))
+import Data.Maybe (fromMaybe)
+import Data.List (sort)
+import Data.Function (on)
+
+instance PPrint ErrMsg where
+ pprint = text . show
+
+instance PPrint SourceError where
+ pprint = text . show
+
+instance PPrint ParseError where
+ pprint = text . show
+
+instance PPrint Var where
+ pprint = pprDoc
+
+instance PPrint Name where
+ pprint = pprDoc
+
+instance PPrint Type where
+ pprint = pprDoc . tidyType emptyTidyEnv
+
+instance Show Predicate where
+ show = showpp
+
+
+
+-- | Printing an Ordered List
+
+---------------------------------------------------------------
+pprManyOrdered :: (PPrint a, Ord a) => String -> [a] -> [Doc]
+---------------------------------------------------------------
+pprManyOrdered msg = map ((text msg <+>) . pprint) . sort -- By (compare `on` pos)
+
+
+---------------------------------------------------------------
+-- | Pretty Printing RefType ----------------------------------
+---------------------------------------------------------------
+
+ppr_rtype bb p t@(RAllT _ _)
+ = ppr_forall bb p t
+ppr_rtype bb p t@(RAllP _ _)
+ = 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 (RApp c [t] rs r)
+ | isList c
+ = ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb rs
+ppr_rtype bb p (RApp c ts rs r)
+ | isTuple c
+ = ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb rs
+
+-- BEXPARSER WHY Does this next case kill the parser for BExp? (e.g. LambdaEval.hs)
+-- ppr_rtype bb p (RApp c [] [] r)
+-- = ppTy r $ {- parens $ -} ppTycon c
+
+ppr_rtype bb p (RApp c ts rs r)
+ = ppTy r $ parens $ ppTycon c <+> ppReftPs bb rs <+> hsep (ppr_rtype bb p <$> ts)
+
+ppr_rtype _ _ (RCls c ts)
+ = ppCls c ts
+ppr_rtype bb p t@(REx _ _ _)
+ = ppExists bb p t
+ppr_rtype bb p t@(RAllE _ _ _)
+ = ppAllExpr bb p t
+ppr_rtype _ _ (RExprArg e)
+ = 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 _ _ (ROth s)
+ = text $ "???-" ++ s
+
+-- | 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
+ | otherwise = parens pretty
+
+
+-- ppExists :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc
+ppExists bb p t
+ = text "exists" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t'
+ where (zs, t') = split [] t
+ split zs (REx x t t') = split ((x,t):zs) t'
+ split zs t = (reverse zs, t)
+
+-- ppAllExpr :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc
+ppAllExpr bb p t
+ = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t'
+ where (zs, t') = split [] t
+ split zs (RAllE x t t') = split ((x,t):zs) t'
+ split zs t = (reverse zs, t)
+
+ppReftPs bb rs
+ | all isTauto rs = empty
+ | not (ppPs ppEnv) = empty
+ | otherwise = angleBrackets $ hsep $ punctuate comma $ pprint <$> rs
+
+-- ppr_dbind :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> Symbol -> RType p c tv r -> Doc
+ppr_dbind bb p x t
+ | isNonSymbol x || (x == dummySymbol)
+ = ppr_rtype bb p t
+ | 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_forall :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc
+ppr_forall bb p t
+ = maybeParen p FunPrec $ sep [ ppr_foralls bb αs πs , ppr_cls cls, ppr_rtype bb TopPrec t' ]
+ where
+ (αs, πs, ct') = bkUniv t
+ (cls, t') = bkClass ct'
+
+ ppr_foralls False _ _ = empty
+ ppr_foralls _ [] [] = empty
+ ppr_foralls True αs πs = text "forall" <+> dαs αs <+> dπs bb πs <> dot
+ ppr_cls [] = empty
+ ppr_cls cs = (parens $ hsep $ punctuate comma (uncurry ppCls <$> cs)) <+> text "=>"
+
+ dαs αs = sep $ pprint <$> αs
+
+ dπs _ [] = empty
+ dπs False _ = empty
+ dπs True πs = angleBrackets $ intersperse comma $ ppr_pvar_def pprint <$> πs
+
+ppr_pvar_def pprv (PV s t xts) = pprint s <+> dcolon <+> intersperse arrow dargs
+ where
+ dargs = [pprv t | (t,_,_) <- xts] ++ [pprv t, text boolConName]
+
+
+
+instance PPrint RTyVar where
+ pprint (RTV α)
+ | ppTyVar ppEnv = ppr_tyvar α
+ | otherwise = ppr_tyvar_short α
+
+ppr_tyvar = text . tvId
+ppr_tyvar_short = text . showPpr
+
+instance (Reftable s, PPrint s, PPrint p, Reftable p, PPrint t) => PPrint (Ref t s (RType a b c p)) where
+ pprint (RMono ss s) = ppRefArgs (fst <$> ss) <+> pprint s
+ pprint (RPoly ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe top (stripRTypeBase s))
+
+ppRefArgs [] = empty
+ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [vv Nothing]) <+> text "->"
+
+ppRefSym (S "") = text "_"
+ppRefSym s = pprint s
+
+instance (PPrint r, Reftable r) => PPrint (UReft r) where
+ pprint (U r p)
+ | isTauto r = pprint p
+ | isTauto p = pprint r
+ | otherwise = pprint p <> text " & " <> pprint r
+
+
diff --git a/Language/Haskell/Liquid/Qualifier.hs b/Language/Haskell/Liquid/Qualifier.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Qualifier.hs
@@ -0,0 +1,125 @@
+module Language.Haskell.Liquid.Qualifier (
+ specificationQualifiers
+ ) where
+
+import Language.Haskell.Liquid.Bare
+import Language.Haskell.Liquid.RefType
+import Language.Haskell.Liquid.GhcInterface
+import Language.Haskell.Liquid.PredType
+import Language.Haskell.Liquid.Types
+import Language.Fixpoint.Types
+import Language.Fixpoint.Misc
+
+import Control.Applicative ((<$>))
+import Data.List (delete, nub)
+import Data.Maybe (fromMaybe)
+import qualified Data.HashSet as S
+import Data.Bifunctor (second)
+
+-----------------------------------------------------------------------------------
+specificationQualifiers :: Int -> GhcInfo -> [Qualifier]
+-----------------------------------------------------------------------------------
+
+specificationQualifiers k info
+ = [ q | (x, t) <- tySigs $ spec info
+ , x `S.member` (S.fromList $ defVars info)
+ , q <- refTypeQuals (tcEmbeds $ spec info) (val t)
+ , length (q_params q) <= k + 1
+ ]
+
+
+-- GRAVEYARD: scraping quals from imports kills the system with too much crap
+-- 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]
+-- t2s = [] -- [t | (_, t) <- ctor spc ]
+-- definedVars = S.fromList $ defVars info
+-- spc = spec info
+--
+-- okQual = not . any isPred . map snd . q_params
+-- where
+-- isPred (FApp tc _) = tc == stringFTycon "Pred"
+-- isPred _ = False
+
+
+refTypeQuals tce t
+ = quals ++
+ [ pAppQual tce p args (v, expr)
+ | p <- preds
+ , (s, v, _) <- pargs p
+ , (args, expr) <- concatMap (expressionsOfSort (rTypeSort tce s)) quals
+ ] where quals = refTypeQuals' tce t
+ preds = snd3 $ bkUniv t
+
+expressionsOfSort sort (Q _ pars (PAtom Eq (EVar v) e2)) | (v, sort) `elem` pars
+ = [(filter (/=(v, sort)) pars, e2)]
+expressionsOfSort _ _ = []
+
+pAppQual tce p args (v, expr)
+ = Q "Auto" freeVars pred
+ where freeVars = (vv, tyvv):(predv,typred):args
+ pred = pApp predv $ EVar vv:predArgs
+ vv = S "v"
+ predv = S "~P"
+ tyvv = rTypeSort tce $ ptype p
+ typred = rTypeSort tce (toPredType p :: RRType ())
+ predArgs = mkexpr <$> (snd3 <$> pargs p)
+ mkexpr x | x == v = expr
+ | otherwise = EVar x
+
+-- refTypeQuals :: SpecType -> [Qualifier]
+refTypeQuals' tce t0 = go emptySEnv t0
+ where go γ t@(RVar _ _) = refTopQuals tce t0 γ t
+ go γ (RAllT _ t) = go γ t
+ go γ (RAllP _ t) = go γ t
+ go γ (RFun x t t' _) = (go γ t) ++ (go (insertSEnv x (rTypeSort tce t) γ) t')
+ go γ t@(RApp c ts rs _) = (refTopQuals 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 (insertSEnv x (rTypeSort tce t) γ) t')
+ go _ _ = []
+ goRefs c γ rs = concat $ zipWith (goRef γ) rs (rTyConPs c)
+ goRef γ (RPoly s t) _ = go (insertsSEnv γ s) t
+ goRef _ (RMono _ _) _ = []
+ insertsSEnv = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ)
+
+refTopQuals tce t0 γ t
+ = [ mkQual t0 γ v so pa | let (RR so (Reft (v, ras))) = rTypeSortedReft tce t
+ , RConc p <- ras
+ , pa <- atoms p
+ ] ++
+ [ mkPQual tce t0 γ s e | let (U _ (Pr ps)) = fromMaybe (msg t) $ stripRTypeBase t
+ , p <- (findPVar (snd3 (bkUniv t0))) <$> ps
+ , (s, _, e) <- pargs p
+ ] where msg t = errorstar $ "Qualifier.refTopQuals: no typebase" ++ showpp t
+
+mkPQual tce t0 γ t e = mkQual t0 γ' v so pa
+ where v = S "vv"
+ so = rTypeSort tce t
+ γ' = insertSEnv v so γ
+ pa = PAtom Eq (EVar v) e
+
+mkQual t0 γ v so p = Q "Auto" ((v, so) : yts) p'
+ where yts = [(y, lookupSort t0 x γ) | (x, y) <- xys ]
+ p' = subst (mkSubst (second EVar <$> xys)) p
+ xys = zipWith (\x i -> (x, S ("~A" ++ show i))) xs [0..]
+ xs = delete v $ orderedFreeVars γ p
+
+lookupSort t0 x γ = fromMaybe (errorstar msg) $ lookupSEnv x γ
+ where msg = "Unknown freeVar " ++ show x ++ " in specification " ++ show t0
+
+orderedFreeVars γ = nub . filter (`memberSEnv` γ) . syms
+
+-- orderedFreeVars :: Pred -> [Symbol]
+-- orderedFreeVars p = nub $ everything (++) ([] `mkQ` f) p
+-- where f (EVar x) = [x]
+-- f _ = []
+
+
+-- atoms' ps = traceShow ("atoms: ps = " ++ showPpr ps) $ atoms ps
+atoms (PAnd ps) = concatMap atoms ps
+atoms p = [p]
+
+
diff --git a/Language/Haskell/Liquid/RefType.hs b/Language/Haskell/Liquid/RefType.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/RefType.hs
@@ -0,0 +1,1051 @@
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternGuards #-}
+
+-- | Refinement Types. Mostly mirroring the GHC Type definition, but with
+-- room for refinements of various sorts.
+
+-- TODO: Desperately needs re-organization.
+module Language.Haskell.Liquid.RefType (
+
+ -- * Functions for lifting Reft-values to Spec-values
+ uTop, uReft, uRType, uRType', uRTypeGen, uPVar
+
+ -- * Functions for decreasing arguments
+ , isDecreasing, makeDecrType
+
+ -- * Functions for manipulating `Predicate`s
+ , pdVar
+ , findPVar
+ , freeTyVars, tyClasses, tyConName
+
+ -- TODO: categorize these!
+ , ofType, ofPredTree, toType
+ , rTyVar, rVar, rApp
+ , expandRApp, appRTyCon
+ , typeSort, typeUniqueSymbol
+ , strengthen
+ , generalize, normalizePds
+ , subts, subvPredicate, subvUReft
+ , subsTyVar_meet, subsTyVars_meet, subsTyVar_nomeet, subsTyVars_nomeet
+ , rTypeSortedReft, rTypeSort
+ , varSymbol, dataConSymbol, dataConMsReft, dataConReft
+ , literalFRefType, literalFReft, literalConst
+ , classBinds
+
+
+ , mkDataConIdsTy
+ , mkTyConInfo
+ ) where
+
+import Var
+import Literal
+import GHC
+import DataCon
+import PrelInfo (isNumericClass)
+import qualified TyCon as TC
+import TypeRep hiding (maybeParen, pprArrowChain)
+import Type (splitFunTys, expandTypeSynonyms)
+import Type (isPredTy, substTyWith, classifyPredType, PredTree(..), predTreePredType)
+import TysWiredIn (listTyCon, intDataCon, trueDataCon, falseDataCon)
+
+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.List as L
+import Data.Function (on)
+import Control.Applicative hiding (empty)
+import Control.DeepSeq
+import Control.Monad (liftM, liftM2, liftM3)
+import Control.Exception (Exception (..))
+import qualified Data.Foldable as Fold
+import Text.Printf
+import Text.PrettyPrint.HughesPJ
+import Text.Parsec.Pos (SourcePos)
+
+import Language.Haskell.Liquid.PrettyPrint
+import Language.Fixpoint.Types hiding (Predicate)
+import Language.Haskell.Liquid.Types hiding (DataConP (..))
+
+import Language.Fixpoint.Misc
+import Language.Haskell.Liquid.GhcMisc (pprDoc, sDocDoc, typeUniqueString, tracePpr, tvId, getDataConVarUnique, showSDoc, showPpr, showSDocDump)
+import Language.Fixpoint.Names (dropModuleNames, symSepName, funConName, listConName, tupConName, propConName, boolConName)
+import Data.List (sort, isSuffixOf, foldl')
+
+pdVar v = Pr [uPVar v]
+
+findPVar :: [PVar (RType p c tv ())] -> UsedPVar -> PVar (RType p c tv ())
+findPVar ps p
+ = PV name ty $ zipWith (\(_, _, e) (t, s, _) -> (t, s, e))(pargs p) args
+ where PV name ty 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 p c tv a -> RType p c tv (UReft a)
+uRType = fmap uTop
+
+uRType' :: RType p c tv (UReft a) -> RType p c tv a
+uRType' = fmap ur_reft
+
+uRTypeGen :: Reftable b => RType p c tv a -> RType p c tv b
+uRTypeGen = fmap (\_ -> top)
+
+uPVar :: PVar t -> UsedPVar
+uPVar = fmap (const ())
+
+uReft :: (Symbol, [Refa]) -> UReft Reft
+uReft = uTop . Reft
+
+uTop :: r -> UReft r
+uTop r = U r top
+
+--------------------------------------------------------------------
+-------------- (Class) Predicates for Valid Refinement Types -------
+--------------------------------------------------------------------
+
+-- Monoid Instances ---------------------------------------------------------
+
+
+instance ( SubsTy tv (RType p c tv ()) (RType p c tv ())
+ , SubsTy tv (RType p c tv ()) c
+ , RefTypable p c tv ()
+ , RefTypable p c tv r
+ , PPrint (RType p c tv r)
+ )
+ => Monoid (RType p c tv r) where
+ mempty = error "mempty RefType"
+ mappend = strengthenRefType
+
+-- MOVE TO TYPES
+instance ( SubsTy tv (RType p c tv ()) (RType p c tv ())
+ , SubsTy tv (RType p c tv ()) c
+ , Reftable r
+ , RefTypable p c tv ()
+ , RefTypable p c tv (UReft r))
+ => Monoid (Ref (RType p c tv ()) r (RType p c tv (UReft r))) where
+ mempty = RMono [] mempty
+ mappend (RMono s1 r1) (RMono s2 r2) = RMono (s1 ++ s2) $ r1 `meet` r2
+ mappend (RMono s1 r) (RPoly s2 t) = RPoly (s1 ++ s2) $ t `strengthen` (U r top)
+ mappend (RPoly s1 t) (RMono s2 r) = RPoly (s1 ++ s2) $ t `strengthen` (U r top)
+ mappend (RPoly s1 t1) (RPoly s2 t2) = RPoly (s1 ++ s2) $ t1 `strengthenRefType` t2
+
+instance ( Monoid r, Reftable r
+ , RefTypable a b c r
+ , RefTypable a b c ()
+ ) => Monoid (Ref (RType a b c ()) r (RType a b c r)) where
+ mempty = RMono [] mempty
+ mappend (RMono s1 r1) (RMono s2 r2) = RMono (s1 ++ s2) $ mappend r1 r2
+ mappend (RMono s1 r) (RPoly s2 t) = RPoly (s1 ++ s2) $ t `strengthen` r
+ mappend (RPoly s1 t) (RMono s2 r) = RPoly (s1 ++ s2) $ t `strengthen` r
+ mappend (RPoly s1 t1) (RPoly s2 t2) = RPoly (s1 ++ s2) $ t1 `strengthenRefType_` t2
+
+instance (Reftable r, RefTypable p c tv r, RefTypable p c tv ())
+ => Reftable (Ref (RType p c tv ()) r (RType p c tv r)) where
+ isTauto (RMono _ r) = isTauto r
+ isTauto (RPoly _ t) = isTrivial t
+ ppTy (RMono _ r) d = ppTy r d
+ ppTy (RPoly _ _) _ = errorstar "RefType: Reftable ppTy in RPoly"
+ toReft = errorstar "RefType: Reftable toReft"
+ params = errorstar "RefType: Reftable params for Ref"
+ bot = errorstar "RefType: Reftable bot for Ref"
+
+
+-- Subable Instances ----------------------------------------------
+
+instance Subable (Ref RSort Reft RefType) where
+ syms (RMono ss r) = (fst <$> ss) ++ syms r
+ syms (RPoly ss t) = (fst <$> ss) ++ syms t
+
+ subst su (RMono ss r) = RMono (mapSnd (subst su) <$> ss) $ subst su r
+ subst su (RPoly ss r) = RPoly (mapSnd (subst su) <$> ss) $ subst su r
+
+ substf f (RMono ss r) = RMono (mapSnd (substf f) <$> ss) $ substf f r
+ substf f (RPoly ss r) = RPoly (mapSnd (substf f) <$> ss) $ substf f r
+ substa f (RMono ss r) = RMono (mapSnd (substa f) <$> ss) $ substa f r
+ substa f (RPoly ss r) = RPoly (mapSnd (substa f) <$> ss) $ substa f r
+
+-- Reftable Instances -------------------------------------------------------
+
+instance (PPrint r, Reftable r) => Reftable (RType Class RTyCon RTyVar r) where
+ isTauto = isTrivial
+ ppTy = errorstar "ppTy RPoly Reftable"
+ toReft = errorstar "toReft on RType"
+ params = errorstar "params on RType"
+ bot = errorstar "bot on RType"
+
+-- ppTySReft s r d
+-- = text "\\" <> hsep (toFix <$> s) <+> text "->" <+> ppTy r d
+
+
+
+-- MOVE TO TYPES
+
+-- TyConable Instances -------------------------------------------------------
+
+-- MOVE TO TYPES
+instance TyConable RTyCon where
+ isFun = isFunTyCon . rTyCon
+ isList = (listTyCon ==) . rTyCon
+ isTuple = TC.isTupleTyCon . rTyCon
+ ppTycon = toFix
+
+-- MOVE TO TYPES
+instance TyConable String where
+ isFun = (funConName ==)
+ isList = (listConName ==)
+ isTuple = (tupConName ==)
+ ppTycon = text
+
+
+-- RefTypable Instances -------------------------------------------------------
+
+-- MOVE TO TYPES
+instance Fixpoint String where
+ toFix = text
+
+-- MOVE TO TYPES
+instance Fixpoint Class where
+ toFix = text . showPpr
+
+-- MOVE TO TYPES
+instance (Eq p, PPrint p, TyConable c, Reftable r, PPrint r) => RefTypable p c String r where
+ ppCls = ppClass_String
+ ppRType = ppr_rtype $ ppPs ppEnv
+ -- ppBase = undefined
+
+-- MOVE TO TYPES
+instance (Reftable r, PPrint r) => RefTypable Class RTyCon RTyVar r where
+ ppCls = ppClass_ClassPred
+ ppRType = ppr_rtype $ ppPs ppEnv
+ -- ppBase = undefined
+
+
+-- MOVE TO TYPES
+class FreeVar a v where
+ freeVars :: a -> [v]
+
+-- MOVE TO TYPES
+instance FreeVar RTyCon RTyVar where
+ freeVars = (RTV <$>) . tyConTyVars . rTyCon
+
+-- MOVE TO TYPES
+instance FreeVar String String where
+ freeVars _ = []
+
+ppClass_String c _ = pprint c <+> text "..."
+ppClass_ClassPred c ts = sDocDoc $ pprClassPred c (toType <$> ts)
+
+-- Eq Instances ------------------------------------------------------
+
+-- MOVE TO TYPES
+instance (RefTypable p c tv ()) => Eq (RType p c tv ()) where
+ (==) = eqRSort M.empty
+
+eqRSort m (RAllP _ t) (RAllP _ t')
+ = eqRSort m 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 t1 t1' && eqRSort m t2 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 (RCls c ts) (RCls 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)
+eqRSort _ _ _
+ = False
+
+--------------------------------------------------------------------
+--------- Wrappers for GHC Type Elements ---------------------------
+--------------------------------------------------------------------
+
+instance Eq Predicate where
+ (==) = eqpd
+
+eqpd (Pr vs) (Pr ws)
+ = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']
+ where vs' = sort vs
+ ws' = sort ws
+
+
+instance Eq RTyVar where
+ RTV α == RTV α' = tvId α == tvId α'
+
+instance Ord RTyVar where
+ compare (RTV α) (RTV α') = compare (tvId α) (tvId α')
+
+instance Hashable RTyVar where
+ hashWithSalt i (RTV α) = hashWithSalt i α
+
+
+instance Ord RTyCon where
+ compare x y = compare (rTyCon x) (rTyCon y)
+
+instance Eq RTyCon where
+ x == y = (rTyCon x) == (rTyCon y)
+
+instance Hashable RTyCon where
+ hashWithSalt i = hashWithSalt i . rTyCon
+
+--------------------------------------------------------------------
+---------------------- Helper Functions ----------------------------
+--------------------------------------------------------------------
+
+rVar = (`RVar` top) . RTV
+rTyVar = RTV
+
+normalizePds t = addPds ps t'
+ where (t', ps) = nlzP [] t
+
+rPred p t = RAllP p t
+rApp c = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing))
+
+
+addPds ps (RAllT v t) = RAllT v $ addPds ps t
+addPds ps t = foldl' (flip rPred) t ps
+
+nlzP ps t@(RVar _ _ )
+ = (t, ps)
+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)
+ = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2)
+ where (t1', ps1) = nlzP [] t1
+ (t2', ps2) = nlzP [] t2
+nlzP ps (RAllT v t )
+ = (RAllT v t', ps ++ ps')
+ where (t', ps') = nlzP [] t
+nlzP ps t@(RApp _ _ _ _)
+ = (t, ps)
+nlzP ps t@(RCls _ _)
+ = (t, ps)
+nlzP ps (RAllP p t)
+ = (t', [p] ++ ps ++ ps')
+ where (t', ps') = nlzP [] t
+nlzP ps t@(ROth _)
+ = (t, ps)
+nlzP ps t@(REx _ _ _)
+ = (t, ps)
+nlzP ps t@(RAllE _ _ _)
+ = (t, ps)
+nlzP _ t
+ = errorstar $ "RefType.nlzP: cannot handle " ++ show t
+
+-- 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]"
+-- (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
+ | otherwise
+ = 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]"
+ (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))
+
+unifyShape :: ( RefTypable p c tv r
+ , FreeVar c tv
+ , RefTypable p c tv ()
+ , SubsTy tv (RType p c tv ()) (RType p c tv ())
+ , SubsTy tv (RType p c tv ()) c)
+ => RType p c tv r -> RType p c tv r -> Maybe (RType p c tv r)
+
+unifyShape (RAllT a1 t1) (RAllT a2 t2)
+ | a1 == a2 = RAllT a1 <$> unifyShape t1 t2
+ | otherwise = RAllT a1 <$> unifyShape t1 (sub a2 a1 t2)
+ where sub a b = let bt = RVar b top in subsTyVar_meet (a, toRSort bt, bt)
+
+unifyShape t1 t2
+ | eqt t1 t2 = Just t1
+ | otherwise = Nothing
+ where eqt t1 t2 = showpp (toRSort t1) == showpp (toRSort t2)
+
+-- strengthenRefType_ :: RefTypable p c tv r =>RType p c tv r -> RType p c tv r -> RType p 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_ (RAppTy t1 t1' r1) (RAppTy t2 t2' r2)
+ = RAppTy t t' (r1 `meet` r2)
+ where t = strengthenRefType_ t1 t2
+ t' = strengthenRefType_ 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_ (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)
+ = RApp tid ts rs (r1 `meet` r2)
+ where ts = zipWith strengthenRefType_ t1s t2s
+ rs = {- tracePpr msg $ -} meets rs1 rs2
+ msg = "strengthenRefType_: RApp rs1 = " ++ showpp rs1 ++ " rs2 = " ++ showpp rs2
+
+
+strengthenRefType_ (RVar v1 r1) (RVar _ r2)
+ = RVar v1 ({- tracePpr msg $ -} r1 `meet` r2)
+ where msg = "strengthenRefType_: RVAR r1 = " ++ showpp r1 ++ " r2 = " ++ showpp r2
+
+strengthenRefType_ t1 _
+ = t1
+
+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 p c tv r -> r -> RType p 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 (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
+
+expandRApp tce tyi (RApp rc ts rs r)
+ = RApp rc' ts (appRefts rc' rs) r
+ where rc' = appRTyCon tce tyi rc ts
+
+expandRApp _ _ t
+ = t
+
+appRTyCon tce tyi rc@(RTyCon c _ _) ts = RTyCon c ps' (rTyConInfo rc'')
+ where ps' = map (subts (zip (RTV <$> αs) (toRSort <$> ts))) (rTyConPs rc')
+ rc' = M.lookupDefault rc c tyi
+ αs = TC.tyConTyVars $ rTyCon rc'
+ rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc'
+isNumeric tce c
+ = (fromMaybe (stringFTycon $ tyConName (rTyCon c)))
+ (M.lookup (rTyCon c) tce) == intFTyCon
+
+addNumSizeFun c
+ = c {rTyConInfo=(rTyConInfo c){sizeFunction = Just EVar}}
+
+appRefts rc [] = RPoly [] . ofRSort . ptype <$> (rTyConPs rc)
+appRefts rc rs = safeZipWith ("appRefts" ++ showFix rc) toPoly rs (rTyConPs rc)
+
+toPoly (RPoly ss t) rc
+ | length (pargs rc) == length ss
+ = RPoly ss t
+ | otherwise
+ = RPoly ([(s, t) | (t, s, _) <- pargs rc]) t
+toPoly (RMono ss r) t
+ = RPoly ss $ (ofRSort $ ptype t) `strengthen` r
+
+generalize t = mkUnivs (freeTyVars t) [] t
+
+freeTyVars (RAllP _ t) = freeTyVars t
+freeTyVars (RAllT α t) = freeTyVars t L.\\ [α]
+freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t'
+freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts
+freeTyVars (RCls _ ts) = []
+freeTyVars (RVar α _) = [α]
+freeTyVars (RAllE _ _ t) = freeTyVars t
+freeTyVars (REx _ _ t) = freeTyVars t
+freeTyVars (RExprArg _) = []
+freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t'
+freeTyVars t = errorstar ("RefType.freeTyVars cannot handle" ++ show t)
+
+--getTyVars = everything (++) ([] `mkQ` f)
+-- where f ((RVar α' _) :: SpecType) = [α']
+-- f _ = []
+
+tyClasses (RAllP _ t) = tyClasses t
+tyClasses (RAllT α t) = tyClasses t
+tyClasses (RAllE _ _ t) = tyClasses t
+tyClasses (REx _ _ t) = tyClasses t
+tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t'
+tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t'
+tyClasses (RApp _ ts _ _) = concatMap tyClasses ts
+tyClasses (RCls c ts) = (c, ts) : concatMap tyClasses ts
+tyClasses (RVar α _) = []
+tyClasses t = errorstar ("RefType.tyClasses cannot handle" ++ show t)
+
+
+
+--getTyClasses = everything (++) ([] `mkQ` f)
+-- where f ((RCls c ts) :: SpecType) = [(c, ts)]
+-- f _ = []
+
+
+
+----------------------------------------------------------------
+---------------------- Strictness ------------------------------
+----------------------------------------------------------------
+
+instance (NFData a, NFData b, NFData t) => NFData (Ref t a b) where
+ rnf (RMono s a) = rnf s `seq` rnf a
+ rnf (RPoly s b) = rnf s `seq` rnf b
+
+instance (NFData a, NFData b, NFData c, NFData e) => NFData (RType a b c e) where
+ rnf (RVar α r) = rnf α `seq` rnf r
+ rnf (RAllT α t) = rnf α `seq` rnf t
+ rnf (RAllP π t) = rnf π `seq` rnf t
+ rnf (RFun x t t' r) = rnf x `seq` rnf t `seq` rnf t' `seq` rnf r
+ rnf (RApp _ ts rs r) = rnf ts `seq` rnf rs `seq` rnf r
+ rnf (RCls c ts) = c `seq` rnf ts
+ rnf (RAllE x t t') = rnf x `seq` rnf t `seq` rnf t'
+ rnf (REx x t t') = rnf x `seq` rnf t `seq` rnf t'
+ rnf (ROth s) = rnf s
+ rnf (RExprArg e) = rnf e
+ rnf (RAppTy t t' r) = rnf t `seq` rnf t' `seq` rnf r
+
+----------------------------------------------------------------
+------------------ Printing Refinement Types -------------------
+----------------------------------------------------------------
+
+instance Show RTyVar where
+ show = showpp
+
+instance PPrint (UReft r) => Show (UReft r) where
+ show = showpp
+
+-- instance (Fixpoint a, Fixpoint b, Fixpoint c) => Fixpoint (a, b, c) where
+-- toFix (a, b, c) = hsep ([toFix a ,toFix b, toFix c])
+
+instance (RefTypable p c tv r) => PPrint (RType p c tv r) where
+ pprint = ppRType TopPrec
+
+instance PPrint (RType p c tv r) => Show (RType p c tv r) where
+ show = showpp
+
+instance Fixpoint RTyCon where
+ toFix (RTyCon c _ _) = text $ showPpr c -- <+> text "\n<<" <+> hsep (map toFix ts) <+> text ">>\n"
+
+instance PPrint RTyCon where
+ pprint = toFix
+
+instance Show RTyCon where
+ show = showpp
+
+
+------------------------------------------------------------------------------------------
+-- TODO: Rewrite subsTyvars with Traversable
+------------------------------------------------------------------------------------------
+
+subsTyVars_meet = subsTyVars True
+subsTyVars_nomeet = subsTyVars False
+subsTyVar_nomeet = subsTyVar False
+subsTyVar_meet = subsTyVar True
+subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats
+subsTyVar meet = subsFree meet S.empty
+
+--subsFree :: ( Ord tv
+-- , SubsTy tv ty c
+-- , SubsTy tv ty r
+-- , SubsTy tv ty (PVar (RType p c tv ()))
+-- , RefTypable p c tv r)
+-- => Bool
+-- -> S.Set tv
+-- -> (tv, ty, RType p c tv r)
+-- -> RType p c tv r
+-- -> RType p c tv r
+
+subsFree m s z@(α, τ,_) (RAllP π t)
+ = RAllP (subt (α, τ) π) (subsFree m s z t)
+subsFree m s z (RAllT α t)
+ = RAllT α $ subsFree m (α `S.insert` s) z t
+subsFree m s z@(_, _, _) (RFun x t t' r)
+ = RFun x (subsFree m s z t) (subsFree m s z t') ({- subt (α, τ) -} r)
+subsFree m s z@(α, τ, _) (RApp c ts rs r)
+ = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) ({- subt z' -} r)
+ where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?
+subsFree m s z (RCls c ts)
+ = RCls c (subsFree m s z <$> ts)
+subsFree meet s (α', _, t') t@(RVar α r)
+ | α == α' && not (α `S.member` s)
+ = if meet then t' `strengthen` {- subt (α', τ') -} r else t'
+ | otherwise
+ = t
+subsFree m s z (RAllE x t t')
+ = RAllE x (subsFree m s z t) (subsFree m s z t')
+subsFree m s z (REx x t t')
+ = 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 _)
+ = t
+subsFree _ _ _ t@(ROth _)
+ = t
+
+-- subsFree _ _ _ t
+-- = errorstar $ "subsFree fails on: " ++ showFix t
+
+subsFrees m s zs t = foldl' (flip(subsFree m s)) t zs
+
+-- GHC INVARIANT: RApp is Type Application to something other than TYCon
+subsFreeRAppTy m s (RApp c ts rs r) t' r'
+ = mkRApp m s c (ts++[t']) rs r r'
+subsFreeRAppTy m s t t' r'
+ = RAppTy t t' r'
+
+mkRApp m s c ts rs r r'
+ | isFun c, [t1, t2] <- ts
+ = RFun dummySymbol t1 t2 $ refAppTyToFun r'
+ | otherwise
+ = subsFrees m s zs $ RApp c ts rs $ r `meet` (refAppTyToApp r')
+ where zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts]
+
+refAppTyToFun r
+ | isTauto r = r
+ | otherwise = errorstar "RefType.refAppTyToFun"
+
+refAppTyToApp r
+ | isTauto r = r
+ | otherwise = errorstar "RefType.refAppTyToApp"
+
+-- subsFreeRef :: (Ord tv, SubsTy tv ty r, SubsTy tv ty (PVar ty), SubsTy tv ty c, Reftable r, Monoid r, Subable r, RefTypable p c tv (PVar ty) r) => Bool -> S.Set tv -> (tv, ty, RType p c tv (PVar ty) r) -> Ref r (RType p c tv (PVar ty) r) -> Ref r (RType p c tv (PVar ty) r)
+
+subsFreeRef m s (α', τ', t') (RPoly ss t)
+ = RPoly (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap (\_ -> top) t') t
+subsFreeRef _ _ (α', τ', _) (RMono ss r)
+ = RMono (mapSnd (subt (α', τ')) <$> ss) $ {- subt (α', τ') -} r
+
+-------------------------------------------------------------------
+------------------- Type Substitutions ----------------------------
+-------------------------------------------------------------------
+
+subts = flip (foldr subt)
+
+instance SubsTy tv ty () where
+ subt _ = id
+
+instance SubsTy tv ty Reft where
+ subt _ = id
+
+instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where
+ subt su (PV n t xts) = PV n (subt su t) [(subt su t, x, y) | (t,x,y) <- xts]
+
+instance SubsTy RTyVar RSort RTyCon where
+ subt z c = c {rTyConPs = subt z <$> rTyConPs c}
+
+-- NOTE: This DOES NOT substitute at the binders
+instance SubsTy RTyVar RSort PrType where
+ subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
+
+instance SubsTy RTyVar RSort SpecType where
+ subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
+
+instance SubsTy RTyVar RTyVar SpecType where
+ subt (α, a) = subt (α, RVar a () :: RSort)
+
+
+instance SubsTy RTyVar RSort RSort where
+ subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
+
+-- Here the "String" is a Bare-TyCon. TODO: wrap in newtype
+instance SubsTy String BSort String where
+ subt _ t = t
+
+instance SubsTy String BSort BSort where
+ subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
+
+instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType p c tv ())) => SubsTy tv ty (Ref (RType p c tv ()) (UReft r) (RType p c tv (UReft r))) where
+ subt m (RMono ss p) = RMono ((mapSnd (subt m)) <$> ss) $ subt m p
+ subt m (RPoly ss t) = RPoly ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t
+
+subvUReft :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft
+subvUReft f (U r p) = U r (subvPredicate f p)
+
+subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate
+subvPredicate f (Pr pvs) = Pr (f <$> pvs)
+
+---------------------------------------------------------------
+
+
+-- ofType :: Reftable r => Type -> RRType r
+ofType = ofType_ . expandTypeSynonyms
+
+ofType_ (TyVarTy α)
+ = rVar α
+ofType_ (FunTy τ τ')
+ = rFun dummySymbol (ofType_ τ) (ofType_ τ')
+ofType_ (ForAllTy α τ)
+ = RAllT (rTyVar α) $ ofType_ τ
+-- ofType_ τ
+-- | isPredTy τ
+-- = ofPredTree (classifyPredType τ)
+ofType_ τ
+ | Just t <- ofPredTree (classifyPredType τ)
+ = t
+ofType_ (TyConApp c τs)
+ | TC.isSynTyCon c
+ = ofType_ $ substTyWith αs τs τ
+ | otherwise
+ = rApp c (ofType_ <$> τs) [] top
+ where (αs, τ) = TC.synTyConDefn c
+ofType_ (AppTy t1 t2)
+ = RAppTy (ofType_ t1) (ofType t2) top
+-- ofType_ τ
+-- = errorstar ("ofType cannot handle: " ++ showPpr τ)
+
+ofPredTree (ClassPred c τs)
+ = Just $ RCls c (ofType_ <$> τs)
+ofPredTree _
+ = Nothing
+
+----------------------------------------------------------------
+------------------- Converting to Fixpoint ---------------------
+----------------------------------------------------------------
+
+
+varSymbol :: Var -> Symbol
+varSymbol v
+ | us `isSuffixOf` vs = stringSymbol vs
+ | otherwise = stringSymbol $ vs ++ [symSepName] ++ us
+ where us = showPpr $ getDataConVarUnique v
+ vs = showPpr v
+
+pprShort = dropModuleNames . showPpr
+
+dataConSymbol :: DataCon -> Symbol
+dataConSymbol = varSymbol . dataConWorkId
+
+-- TODO: turn this into a map lookup?
+dataConReft :: DataCon -> [Symbol] -> Reft
+dataConReft c []
+ | c == trueDataCon
+ = Reft (vv_, [RConc $ 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 _
+ | not $ isBaseDataCon c
+ = top
+dataConReft c xs
+ = Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])
+ where dcValue | null xs && null (dataConUnivTyVars c)
+ = EVar $ dataConSymbol c
+ | otherwise
+ = EApp (dataConSymbol c) (EVar <$> xs)
+
+isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c
+
+isBaseTy (TyVarTy _) = True
+isBaseTy (AppTy t1 t2) = False
+isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts
+isBaseTy (FunTy _ _) = False
+isBaseTy (ForAllTy _ _) = False
+
+-- mkProp x = PBexp (EApp (S propConName) [EVar x])
+
+vv_ = vv Nothing
+
+dataConMsReft ty ys = subst su (rTypeReft t)
+ where (xs, ts, t) = bkArrow $ thd3 $ bkUniv ty
+ su = mkSubst [(x, EVar y) | ((x,_), y) <- zip (zip xs ts) ys]
+
+---------------------------------------------------------------
+---------------------- Embedding RefTypes ---------------------
+---------------------------------------------------------------
+-- TODO: remove toType, generalize typeSort
+toType :: (Reftable r, PPrint r) => RRType r -> Type
+toType (RFun _ t t' _)
+ = FunTy (toType t) (toType t')
+toType (RAllT (RTV α) t)
+ = ForAllTy α (toType t)
+toType (RAllP _ t)
+ = toType t
+toType (RVar (RTV α) _)
+ = TyVarTy α
+toType (RApp (RTyCon {rTyCon = c}) ts _ _)
+ = TyConApp c (toType <$> ts)
+toType (RCls c ts)
+ = predTreePredType $ ClassPred c (toType <$> ts)
+toType (RAllE _ _ t)
+ = toType t
+toType (REx _ _ t)
+ = toType t
+toType (RAppTy t t' _)
+ = AppTy (toType t) (toType t')
+toType t@(RExprArg _)
+ = errorstar $ "RefType.toType cannot handle: " ++ show t
+toType t@(ROth _)
+ = errorstar $ "RefType.toType cannot handle: " ++ show t
+
+
+---------------------------------------------------------------
+----------------------- Typing Literals -----------------------
+---------------------------------------------------------------
+
+-- makeRTypeBase :: Type -> Reft -> RefType
+makeRTypeBase (TyVarTy α) x
+ = RVar (rTyVar α) x
+makeRTypeBase (TyConApp c _) x
+ = rApp c [] [] x
+makeRTypeBase _ _
+ = error "RefType : makeRTypeBase"
+
+literalFRefType tce l
+ = makeRTypeBase (literalType l) (literalFReft tce l)
+
+literalFReft tce = maybe top exprReft . snd . literalConst tce
+
+ -- exprReft . snd . literalConst tce
+
+-- | `literalConst` returns `Nothing` for unhandled lits because
+-- otherwise string-literals show up as global int-constants
+-- which blow up qualifier instantiation.
+
+literalConst tce l = (sort, mkLit l)
+ where
+ sort = typeSort tce $ literalType l
+ sym = stringSymbol $ "$$" ++ showPpr l
+ mkLit (MachInt n) = mkI n
+ mkLit (MachInt64 n) = mkI n
+ mkLit (MachWord n) = mkI n
+ mkLit (MachWord64 n) = mkI n
+ mkLit (LitInteger n _) = mkI n
+ mkLit _ = Nothing -- ELit sym sort
+ mkI = Just . ECon . I
+
+---------------------------------------------------------------
+---------------- Annotations and Solutions --------------------
+---------------------------------------------------------------
+
+rTypeSortedReft :: (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> SortedReft
+rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t)
+
+rTypeSort :: (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> Sort
+rTypeSort tce = typeSort tce . toType
+
+
+------------------------------------------------------------------------
+---------------- Auxiliary Stuff Used Elsewhere ------------------------
+------------------------------------------------------------------------
+
+-- 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" n
+ (L.intercalate " " (show <$> as))
+ (L.intercalate " " (show <$> xs))
+ (show t) (show p)
+
+----------------------------------------------------------------
+------------ From Old Fixpoint ---------------------------------
+----------------------------------------------------------------
+
+typeUniqueSymbol :: Type -> Symbol
+typeUniqueSymbol = stringSymbol . typeUniqueString
+
+
+fApp c ts
+ | c == intFTyCon = FInt
+ | otherwise = FApp c ts
+
+typeSort :: TCEmb TyCon -> Type -> Sort
+typeSort tce τ@(ForAllTy _ _)
+ = typeSortForAll tce τ
+typeSort tce (FunTy τ1 τ2)
+ = typeSortFun tce τ1 τ2
+typeSort tce (TyConApp c τs)
+ = fApp ftc (typeSort tce <$> τs)
+ where ftc = fromMaybe (stringFTycon $ tyConName c) (M.lookup c tce)
+typeSort _ τ
+ = FObj $ typeUniqueSymbol τ
+
+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 τ
+ su = M.fromList $ zip sas (FVar <$> [0..])
+ sas = (typeUniqueSymbol . TyVarTy) <$> as
+ n = length as
+
+-- sortSubst su t@(FObj x) = fromMaybe t (M.lookup x su)
+-- sortSubst su (FFunc n ts) = FFunc n (sortSubst su <$> ts)
+-- sortSubst su (FApp c ts) = FApp c (sortSubst su <$> ts)
+-- sortSubst _ t = t
+
+tyConName c
+ | listTyCon == c = listConName
+ | TC.isTupleTyCon c = tupConName
+ | otherwise = showPpr c
+
+typeSortFun tce τ1 τ2
+ = FFunc 0 sos
+ where sos = typeSort tce <$> τs
+ τs = τ1 : grabArgs [] τ2
+grabArgs τs (FunTy τ1 τ2 ) = grabArgs (τ1:τs) τ2
+grabArgs τs τ = reverse (τ:τs)
+
+mkDataConIdsTy (dc, t) = [expandProductType id t | id <- dataConImplicitIds dc]
+
+expandProductType x t
+ | ofType (varType x) == toRSort t = (x, t)
+ | otherwise = (x, t')
+ where t' = mkArrow as ps xts' tr
+ τs = fst $ splitFunTys $ toType t
+ (as, ps, t0) = bkUniv t
+ (xs, ts, tr) = bkArrow t0
+ xts' = concatMap mkProductTy $ zip3 τs xs ts
+
+mkProductTy (τ, x, t) = maybe [(x, t)] f $ deepSplitProductType_maybe τ
+ where f = ((<$>) ((,) dummySymbol . ofType)) . forth4
+
+-- Move to misc
+forth4 (_, _, _, x) = x
+
+-----------------------------------------------------------------------------------------
+-- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum)
+-----------------------------------------------------------------------------------------
+
+classBinds (RCls c ts)
+ | isNumericClass c = [(rTyVarSymbol a, trueSortedReft FNum) | (RVar a _) <- ts]
+classBinds _ = []
+
+rTyVarSymbol (RTV α) = typeUniqueSymbol $ TyVarTy α
+
+-----------------------------------------------------------------------------------------
+--------------------------- Termination Predicates --------------------------------------
+-----------------------------------------------------------------------------------------
+
+isDecreasing (RApp c _ _ _)
+ = isJust (sizeFunction (rTyConInfo c))
+isDecreasing _
+ = False
+
+makeDecrType = mkDType [] []
+
+mkDType xvs acc [(v, (x, t@(RApp c _ _ _)))]
+ = (x, ) $ t `strengthen` tr
+ where tr = uTop $ Reft (vv, [RConc $ pOr (r:acc)])
+ r = cmpLexRef xvs (v', vv, f)
+ v' = varSymbol v
+ Just f = sizeFunction $ rTyConInfo c
+ vv = stringSymbol "vvRec"
+
+mkDType xvs acc ((v, (x, t@(RApp c _ _ _))):vxts)
+ = mkDType ((v', x, f):xvs) (r:acc) vxts
+ where r = cmpLexRef xvs (v', x, f)
+ v' = varSymbol v
+ Just f = sizeFunction $ rTyConInfo c
+
+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
+
+------------------------------------------------------------------------
+-- | Pretty Printing Error Messages ------------------------------------
+------------------------------------------------------------------------
+
+-- Need to put this here intead of in Types, because it depends on the
+-- printer for SpecTypes, which lives in this module.
+
+instance PPrint Error where
+ pprint = ppError
+
+instance PPrint SrcSpan where
+ pprint = pprDoc
+
+instance Show Error where
+ show = showpp
+
+instance Exception Error
+instance Exception [Error]
+
+------------------------------------------------------------------------
+ppError :: Error -> Doc
+------------------------------------------------------------------------
+ppError (ErrSubType l s tA tE)
+ = text "Liquid Type Error:" <+> pprint l
+-- DO NOT DELETE
+-- $+$ (nest 4 $ text "Required Type:" <+> pprint tE)
+-- $+$ (nest 4 $ text "Actual Type:" <+> pprint tA)
+
+ppError (ErrParse l _ e)
+ = text "Error Parsing Specification:" <+> pprint l
+ $+$ (nest 4 $ pprint e)
+
+ppError (ErrTySpec l v t s)
+ = text "Error in Type Specification:" <+> pprint l
+ $+$ (v <+> dcolon <+> pprint t)
+ $+$ (nest 4 s)
+
+ppError (ErrInvt l t s)
+ = text "Error in Invariant Specification:" <+> pprint l
+ $+$ (nest 4 $ text "invariant " <+> pprint t $+$ s)
+
+ppError (ErrMeas l t s)
+ = text "Error in Measure Defiition:" <+> pprint l
+ $+$ (nest 4 $ text "measure " <+> pprint t $+$ s)
+
+
+ppError (ErrDupSpecs l v ls)
+ = text "Multiple Specifications for" <+> v <> colon <+> pprint l
+ $+$ (nest 4 $ vcat $ pprint <$> ls)
+
+ppError (ErrGhc l s)
+ = text "GHC Error:" <+> pprint l
+ $+$ (nest 4 s)
+
+ppError (ErrMismatch l x τ t)
+ = text "Specified Type Does Not Refine Haskell Type for" <+> x <> colon <+> pprint l
+ $+$ text "Haskell:" <+> pprint τ
+ $+$ text "Liquid :" <+> pprint t
+
+ppError (ErrOther s)
+ = text "Unexpected Error: "
+ $+$ (nest 4 s)
+
+
+-------------------------------------------------------------------------------
+
+mkTyConInfo :: TyCon -> [Int] -> [Int] -> (Maybe (Symbol -> Expr)) -> TyConInfo
+mkTyConInfo c = TyConInfo pos neg
+ where pos = neutral ++ [i | (i, b) <- varsigns, b, i /= dindex]
+ neg = neutral ++ [i | (i, b) <- varsigns, not b, i /= dindex]
+ varsigns = L.nub $ concatMap goDCon $ TC.tyConDataCons c
+ initmap = zip (showPpr <$> tyvars) [0..n]
+ mkmap vs = zip (showPpr <$> vs) (repeat (dindex)) ++ initmap
+ goDCon dc = concatMap (go (mkmap (DataCon.dataConExTyVars dc)) True)
+ (DataCon.dataConOrigArgTys dc)
+ go m pos (ForAllTy v t) = go ((showPpr v, dindex):m) pos t
+ go m pos (TyVarTy v) = [(varLookup (showPpr v) m, pos)]
+ go m pos (AppTy t1 t2) = go m pos t1 ++ go m pos t2
+ go m pos (TyConApp _ ts) = concatMap (go m pos) ts
+ go m pos (FunTy t1 t2) = go m (not pos) t1 ++ go m pos t2
+
+ varLookup v m = fromMaybe (errmsg v) $ L.lookup v m
+ tyvars = TC.tyConTyVars c
+ n = (TC.tyConArity c) - 1
+ errmsg v = error $ "GhcMisc.getTyConInfo: var not found" ++ showPpr v
+ dindex = -1
+ neutral = [0..n] L.\\ (fst <$> varsigns)
+
+
+
+
diff --git a/Language/Haskell/Liquid/Tidy.hs b/Language/Haskell/Liquid/Tidy.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Tidy.hs
@@ -0,0 +1,101 @@
+module Language.Haskell.Liquid.Tidy (tidySpecType) where
+
+import Outputable (showPpr) -- hiding (empty)
+import Control.Applicative
+import qualified Data.HashMap.Strict as M
+import qualified Data.HashSet as S
+import qualified Data.List as L
+
+import Language.Fixpoint.Misc
+import Language.Fixpoint.Names (symSepName)
+import Language.Fixpoint.Types
+import Language.Haskell.Liquid.GhcMisc (stringTyVar)
+import Language.Haskell.Liquid.Types
+import Language.Haskell.Liquid.RefType
+---------------------------------------------------------------------
+---------- SYB Magic: Cleaning Reftypes Up Before Rendering ---------
+---------------------------------------------------------------------
+
+tidySpecType :: SpecType -> SpecType
+tidySpecType = tidyDSymbols
+ . tidySymbols
+ . tidyLocalRefas
+ . tidyFunBinds
+ . tidyTyVars
+
+tidySymbols :: SpecType -> SpecType
+tidySymbols t = substa dropSuffix $ mapBind dropBind t
+ where
+ xs = S.fromList (syms t)
+ dropBind x = if x `S.member` xs then dropSuffix x else nonSymbol
+ dropSuffix = S . takeWhile (/= symSepName) . symbolString
+
+tidyLocalRefas :: SpecType -> SpecType
+tidyLocalRefas = mapReft (txReft)
+ where
+ txReft (U (Reft (v,ras)) p) = U (Reft (v, dropLocals ras)) p
+ dropLocals = filter (not . any isTmp . syms) . flattenRefas
+ isTmp x = any (`L.isPrefixOf` (symbolString x)) [anfPrefix, "ds_"]
+
+isTmpSymbol x = any (`L.isPrefixOf` str) [anfPrefix, tempPrefix, "ds_"]
+ where str = symbolString x
+
+
+tidyDSymbols :: SpecType -> SpecType
+tidyDSymbols t = mapBind tx $ substa tx t
+ where
+ tx = bindersTx [x | x <- syms t, isTmp x]
+ isTmp = (tempPrefix `L.isPrefixOf`) . symbolString
+
+tidyFunBinds :: SpecType -> SpecType
+tidyFunBinds t = mapBind tx $ substa tx t
+ where
+ tx = bindersTx $ filter isTmpSymbol $ funBinds t
+
+tidyTyVars :: SpecType -> SpecType
+tidyTyVars t = subsTyVarsAll αβs t
+ where
+ -- zz = [(a, b) | (a, _, (RVar b _)) <- αβs]
+ αβ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
+ m = M.fromList $ zip ds $ var <$> [1..]
+ var = stringSymbol . ('x' :) . show
+
+
+tyVars (RAllP _ 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 (RApp _ ts _ _) = concatMap tyVars ts
+tyVars (RCls _ ts) = concatMap tyVars ts
+tyVars (RVar α _) = [α]
+tyVars (RAllE _ _ t) = tyVars t
+tyVars (REx _ _ t) = tyVars t
+tyVars (RExprArg _) = []
+tyVars (ROth _) = []
+
+subsTyVarsAll ats = go
+ 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
+
+
+funBinds (RAllT _ t) = funBinds t
+funBinds (RAllP _ t) = funBinds t
+funBinds (RFun b t1 t2 _) = b : funBinds t1 ++ funBinds t2
+funBinds (RApp _ ts _ _) = concatMap funBinds ts
+funBinds (RCls _ 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 (ROth _) = []
+funBinds (RAppTy t1 t2 r) = funBinds t1 ++ funBinds t2
+funBinds (RExprArg e) = []
+
diff --git a/Language/Haskell/Liquid/TransformRec.hs b/Language/Haskell/Liquid/TransformRec.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/TransformRec.hs
@@ -0,0 +1,255 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Language.Haskell.Liquid.TransformRec (
+ transformRecExpr
+ ) where
+
+import Bag
+import Coercion
+import Control.Arrow (second, (***))
+import Control.Monad.State
+import CoreLint
+import CoreSyn
+import qualified Data.HashMap.Strict as M
+import ErrUtils
+import Id (idOccInfo, setIdInfo)
+import IdInfo
+import MkCore (mkCoreLams)
+import SrcLoc
+import Type (mkForAllTys)
+import TypeRep
+import Unique hiding (deriveUnique)
+import Var
+import Language.Haskell.Liquid.GhcMisc
+import Language.Haskell.Liquid.Misc (mapSndM)
+
+import Data.List (foldl', isInfixOf)
+import Control.Applicative ((<$>))
+
+transformRecExpr :: CoreProgram -> CoreProgram
+transformRecExpr cbs
+ | isEmptyBag $ filterBag isTypeError e
+ = {-trace "new cbs"-} pg
+ | otherwise
+ = error (showPpr pg ++ "Type-check" ++ showSDoc (pprMessageBag e))
+ where pg = scopeTr $ evalState (transPg cbs) initEnv
+ (_, e) = lintCoreBindings pg
+
+isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False
+isTypeError _ = True
+
+scopeTr = outerScTr . innerScTr
+
+outerScTr = mapNonRec (go [])
+ where
+ go ack x (xe : xes) | isCaseArg x xe = go (xe:ack) x xes
+ go ack _ xes = ack ++ xes
+
+isCaseArg x (NonRec _ (Case (Var z) _ _ _)) = z == x
+isCaseArg _ _ = False
+
+innerScTr = (mapBnd scTrans <$>)
+
+scTrans x e = mapExpr scTrans $ foldr Let e0 bs
+ where (bs, e0) = go [] x e
+ go bs x (Let b e) | isCaseArg x b = go (b:bs) x e
+ go bs x (Tick t e) = second (Tick t) $ go bs x e
+ go bs x e = (bs, e)
+
+type TE = State TrEnv
+
+data TrEnv = Tr { freshIndex :: !Int
+ , loc :: SrcSpan
+ }
+
+initEnv = Tr 0 noSrcSpan
+
+transPg = mapM transBd
+
+transBd (NonRec x e) = liftM (NonRec x) (transExpr =<< mapBdM transBd e)
+transBd (Rec xes) = liftM Rec $ mapM (mapSndM (mapBdM transBd)) xes
+
+transExpr :: CoreExpr -> TE CoreExpr
+transExpr e
+ | (isNonPolyRec e') && (not (null tvs))
+ = trans tvs ids bs e'
+ | otherwise
+ = return e
+ where (tvs, ids, e'') = collectTyAndValBinders e
+ (bs, e') = collectNonRecLets e''
+
+isNonPolyRec (Let (Rec xes) _) = any nonPoly (snd <$> xes)
+isNonPolyRec _ = False
+
+nonPoly = null . fst . collectTyBinders
+
+collectNonRecLets = go []
+ where go bs (Let b@(NonRec _ _) e') = go (b:bs) e'
+ go bs e' = (reverse bs, e')
+
+appTysAndIds tvs ids x = mkApps (mkTyApps (Var x) (map TyVarTy tvs)) (map Var ids)
+
+trans vs ids bs (Let (Rec xes) e)
+ = liftM (mkLam . mkLet) (makeTrans vs liveIds e')
+ where liveIds = mkAlive <$> ids
+ mkLet e = foldr Let e bs
+ mkLam e = foldr Lam e $ vs ++ liveIds
+ e' = Let (Rec xes') e
+ xes' = (second mkLet) <$> xes
+
+makeTrans vs ids (Let (Rec xes) e)
+ = do fids <- mapM (mkFreshIds vs ids) xs
+ let (ids', ys) = unzip fids
+ let yes = appTysAndIds vs ids <$> ys
+ ys' <- mapM fresh xs
+ let su = M.fromList $ zip xs (Var <$> ys')
+ let rs = zip ys' yes
+ let es' = zipWith (mkE ys) ids' es
+ let xes' = zip ys es'
+ return $ mkRecBinds rs (Rec xes') (sub su e)
+ where
+ (xs, es) = unzip xes
+ mkSu ys ids' = mkSubs ids vs ids' (zip xs ys)
+ mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e')
+
+mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b
+mkRecBinds xes rs e = Let rs (foldl' f e xes)
+ where f e (x, xe) = Let (NonRec x xe) e
+
+mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2
+ where s1 = (second (appTysAndIds tvs xs)) <$> ys
+ s2 = zip ids (Var <$> xs)
+
+mkFreshIds tvs ids x
+ = do ids' <- mapM fresh ids
+ let t = mkForAllTys tvs $ mkType (reverse ids') $ varType x
+ let x' = setVarType x t
+ return (ids', x')
+ where
+ mkType ids ty = foldl (\t x -> FunTy (varType x) t) ty ids
+
+class Freshable a where
+ fresh :: a -> TE a
+
+instance Freshable Int where
+ fresh _ = freshInt
+
+instance Freshable Unique where
+ fresh _ = freshUnique
+
+instance Freshable Var where
+ fresh v = liftM (setVarUnique v) freshUnique
+
+freshInt
+ = do s <- get
+ let n = freshIndex s
+ put s{freshIndex = n+1}
+ return n
+
+freshUnique = liftM (mkUnique 'X') freshInt
+
+mkAlive x
+ | isId x && isDeadOcc (idOccInfo x)
+ = setIdInfo x (setOccInfo (idInfo x) NoOccInfo)
+ | otherwise
+ = x
+
+class Subable a where
+ sub :: M.HashMap CoreBndr CoreExpr -> a -> a
+ subTy :: M.HashMap TyVar Type -> a -> a
+
+instance Subable CoreExpr where
+ sub s (Var v) = M.lookupDefault (Var v) v s
+ sub _ (Lit l) = Lit l
+ sub s (App e1 e2) = App (sub s e1) (sub s e2)
+ sub s (Lam b e) = Lam b (sub s e)
+ sub s (Let b e) = Let (sub s b) (sub s e)
+ sub s (Case e b t a) = Case (sub s e) (sub s b) t (map (sub s) a)
+ sub s (Cast e c) = Cast (sub s e) c
+ sub s (Tick t e) = Tick t (sub s e)
+ sub _ (Type t) = Type t
+ sub _ (Coercion c) = Coercion c
+
+ subTy s (Var v) = Var (subTy s v)
+ subTy _ (Lit l) = Lit l
+ subTy s (App e1 e2) = App (subTy s e1) (subTy s e2)
+ subTy s (Lam b e) | isTyVar b = Lam v' (subTy s e)
+ where v' = case M.lookup b s of
+ Nothing -> b
+ Just (TyVarTy v) -> v
+
+ subTy s (Lam b e) = Lam (subTy s b) (subTy s e)
+ subTy s (Let b e) = Let (subTy s b) (subTy s e)
+ subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a)
+ subTy s (Cast e c) = Cast (subTy s e) (subTy s c)
+ subTy s (Tick t e) = Tick t (subTy s e)
+ subTy s (Type t) = Type (subTy s t)
+ subTy s (Coercion c) = Coercion (subTy s c)
+
+instance Subable Coercion where
+ sub _ c = c
+ subTy _ _ = error "subTy Coercion"
+
+instance Subable (Alt Var) where
+ sub s (a, b, e) = (a, map (sub s) b, sub s e)
+ subTy s (a, b, e) = (a, map (subTy s) b, subTy s e)
+
+instance Subable Var where
+ sub s v | M.member v s = subVar $ s M.! v
+ | otherwise = v
+ subTy s v = setVarType v (subTy s (varType v))
+
+subVar (Var x) = x
+subVar _ = error "sub Var"
+
+instance Subable (Bind Var) where
+ sub s (NonRec x e) = NonRec (sub s x) (sub s e)
+ sub s (Rec xes) = Rec ((sub s *** sub s) <$> xes)
+
+ subTy s (NonRec x e) = NonRec (subTy s x) (subTy s e)
+ subTy s (Rec xes) = Rec ((subTy s *** subTy s) <$> xes)
+
+instance Subable Type where
+ sub _ e = e
+ subTy = substTysWith
+
+substTysWith s tv@(TyVarTy v) = M.lookupDefault tv v s
+substTysWith s (FunTy t1 t2) = FunTy (substTysWith s t1) (substTysWith s t2)
+substTysWith s (ForAllTy v t) = ForAllTy v (substTysWith (M.delete v s) t)
+substTysWith s (TyConApp c ts) = TyConApp c (map (substTysWith s) ts)
+substTysWith s (AppTy t1 t2) = AppTy (substTysWith s t1) (substTysWith s t2)
+
+mapNonRec f (NonRec x xe:xes) = NonRec x xe : f x (mapNonRec f xes)
+mapNonRec f (xe:xes) = xe : mapNonRec f xes
+mapNonRec _ [] = []
+
+mapBnd f (NonRec b e) = NonRec b (mapExpr f e)
+mapBnd f (Rec bs) = Rec (map (second (mapExpr f)) bs)
+
+mapExpr f (Let b@(NonRec x _) e) = Let b (f x e)
+mapExpr f (App e1 e2) = App (mapExpr f e1) (mapExpr f e2)
+mapExpr f (Lam b e) = Lam b (mapExpr f e)
+mapExpr f (Let bs e) = Let (mapBnd f bs) (mapExpr f e)
+mapExpr f (Case e b t alt) = Case e b t (map (mapAlt f) alt)
+mapExpr f (Tick t e) = Tick t (mapExpr f e)
+mapExpr _ e = e
+
+mapAlt f (d, bs, e) = (d, bs, mapExpr f e)
+
+-- Do not apply transformations to inner code
+
+mapBdM _ = return
+
+-- mapBdM f (Let b e) = liftM2 Let (f b) (mapBdM f e)
+-- mapBdM f (App e1 e2) = liftM2 App (mapBdM f e1) (mapBdM f e2)
+-- mapBdM f (Lam b e) = liftM (Lam b) (mapBdM f e)
+-- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt)
+-- mapBdM f (Tick t e) = liftM (Tick t) (mapBdM f e)
+-- mapBdM _ e = return e
+--
+-- mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e)
diff --git a/Language/Haskell/Liquid/Types.hs b/Language/Haskell/Liquid/Types.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/Liquid/Types.hs
@@ -0,0 +1,1069 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+-- | This module (should) contain all the global type definitions and basic
+-- instances. Need to gradually pull things into here, especially from @RefType@
+
+module Language.Haskell.Liquid.Types (
+
+ -- * Options
+ Config (..)
+
+ -- * Ghc Information
+ , GhcInfo (..)
+ , GhcSpec (..)
+ , TargetVars (..)
+
+ -- * Located Things
+ , Located (..)
+
+ -- * Symbols
+ , LocSymbol
+ , LocString
+
+ -- * Data Constructors
+ , BDataCon (..)
+
+ -- * Constructors and Destructors
+ , mkArrow, bkArrowDeep, bkArrow, safeBkArrow
+ , mkUnivs, bkUniv, bkClass
+ , rFun, rAppTy
+
+ -- * Manipulating Predicate
+ , pvars
+
+ -- * All these should be MOVE TO TYPES
+ , RTyVar (..), RType (..), RRType, BRType, RTyCon(..)
+ , TyConable (..), RefTypable (..), SubsTy (..), Ref(..)
+ , RTAlias (..), mapRTAVars
+ , BSort, BPVar, BareType, RSort, UsedPVar, RPVar, RReft, RefType
+ , PrType, SpecType
+ , PVar (..) , Predicate (..), UReft(..), DataDecl (..), TyConInfo(..)
+ , TyConP (..), DataConP (..)
+
+ -- * Default unknown name
+ , dummyName, isDummy
+
+ -- * Traversing `RType`
+ , efoldReft, foldReft
+ , mapReft, mapReftM
+ , mapBot, mapBind
+
+ , isTrivial
+
+ -- * Converting To and From Sort
+ , ofRSort, toRSort
+ , rTypeValueVar
+ , rTypeReft
+ , stripRTypeBase
+
+ -- * Class for values that can be pretty printed
+ , PPrint (..)
+ , showpp
+
+ -- * Printer Configuration
+ , PPEnv (..), ppEnv
+
+ -- * Import handling
+ , ModName (..), ModType (..), isSrcImport, isSpecImport
+ , getModName, getModString
+
+ -- * Refinement Type Aliases
+ , RTEnv (..), mapRT, mapRP, RTBareOrSpec
+
+ -- * Final Result
+ , Result (..)
+
+ -- * Different kinds of errors
+ , Error (..)
+ , ErrorResult
+
+ -- * Source information associated with each constraint
+ , Cinfo (..)
+ )
+ where
+
+import FastString (fsLit)
+import SrcLoc (mkGeneralSrcSpan, SrcSpan)
+import TyCon
+import DataCon
+import TypeRep hiding (maybeParen, pprArrowChain)
+import Var
+import Unique
+import Literal
+import Text.Printf
+import GHC (Class, HscEnv, ModuleName, Name, moduleNameString)
+import GHC (Class, HscEnv)
+import Language.Haskell.Liquid.GhcMisc
+
+import Control.Monad (liftM, liftM2, liftM3)
+import Control.DeepSeq
+import Control.Applicative ((<$>))
+import Data.Typeable (Typeable)
+import Data.Generics (Data)
+import Data.Monoid hiding ((<>))
+import qualified Data.Foldable as F
+import Data.Hashable
+import qualified Data.HashMap.Strict as M
+import qualified Data.HashSet as S
+import Data.Function (on)
+import Data.Maybe (maybeToList, fromMaybe)
+import Data.Traversable hiding (mapM)
+import Data.List (nub, union, unionBy)
+import Text.Parsec.Pos (SourcePos, newPos)
+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)
+-- import qualified Language.Fixpoint.Types as F
+
+import CoreSyn (CoreBind)
+import Var
+-----------------------------------------------------------------------------
+-- | Command Line Config Options --------------------------------------------
+-----------------------------------------------------------------------------
+
+-- NOTE: adding strictness annotations breaks the help message
+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
+ , binders :: [String] -- ^ set of binders to check
+ , noCheckUnknown :: Bool -- ^ whether to complain about specifications for unexported and unused values
+ , nofalse :: Bool -- ^ remove false predicates from the refinements
+ , notermination :: Bool -- ^ disable termination check
+ , totality :: Bool -- ^ check totality in definitions
+ , noPrune :: Bool -- ^ disable prunning unsorted Refinements
+ , maxParams :: Int -- ^ the maximum number of parameters to accept when mining qualifiers
+ , smtsolver :: SMTSolver -- ^ name of smtsolver to use [default: z3-API]
+ } deriving (Data, Typeable, Show, Eq)
+
+-----------------------------------------------------------------------------
+-- | Printer ----------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+class PPrint a where
+ pprint :: a -> Doc
+
+showpp :: (PPrint a) => a -> String
+showpp = render . pprint
+
+-- pshow :: PPrint a => a -> String
+-- pshow = render . pprint
+
+instance PPrint a => PPrint (Maybe a) where
+ pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint)
+
+instance PPrint a => PPrint [a] where
+ pprint = brackets . intersperse comma . map pprint
+
+
+
+instance (PPrint a, PPrint b) => PPrint (a,b) where
+ pprint (x, y) = (pprint x) <+> text ":" <+> (pprint y)
+
+data PPEnv
+ = PP { ppPs :: Bool
+ , ppTyVar :: Bool
+ }
+
+ppEnv = ppEnvPrintPreds
+ppEnvCurrent = PP False False
+ppEnvPrintPreds = PP True False
+
+
+-----------------------------------------------------------------------------
+-- | Located Values ---------------------------------------------------------
+-----------------------------------------------------------------------------
+
+data Located a = Loc { loc :: !SourcePos
+ , val :: a
+ }
+
+type LocSymbol = Located Symbol
+type LocString = Located String
+
+dummyName = "dummy"
+
+isDummy :: (Show a) => a -> Bool
+isDummy a = show a == dummyName
+
+
+instance Fixpoint SourcePos where
+ toFix = text . show
+
+instance Fixpoint a => Fixpoint (Located a) where
+ toFix = toFix . val
+
+instance Symbolic a => Symbolic (Located a) where
+ symbol = symbol . val
+
+instance Expression a => Expression (Located a) where
+ expr = expr . val
+
+instance Functor Located where
+ fmap f (Loc l x) = Loc l (f x)
+
+instance F.Foldable Located where
+ foldMap f (Loc _ x) = f x
+
+instance Traversable Located where
+ traverse f (Loc l x) = Loc l <$> f x
+
+instance Show a => Show (Located a) where
+ show (Loc l x) = show x ++ " defined at " ++ show l
+
+instance Eq a => Eq (Located a) where
+ (Loc _ x) == (Loc _ y) = x == y
+
+instance Ord a => Ord (Located a) where
+ compare x y = compare (val x) (val y)
+
+instance Subable a => Subable (Located a) where
+ syms (Loc _ x) = syms x
+ substa f (Loc l x) = Loc l (substa f x)
+ substf f (Loc l x) = Loc l (substf f x)
+ subst su (Loc l x) = Loc l (subst su x)
+
+instance Hashable a => Hashable (Located a) where
+ hashWithSalt i = hashWithSalt i . val
+
+
+
+------------------------------------------------------------------
+-- | GHC Information : Code & Spec ------------------------------
+------------------------------------------------------------------
+
+data GhcInfo = GI {
+ env :: !HscEnv
+ , cbs :: ![CoreBind]
+ , impVars :: ![Var]
+ , defVars :: ![Var]
+ , useVars :: ![Var]
+ , hqFiles :: ![FilePath]
+ , imports :: ![String]
+ , includes :: ![FilePath]
+ , spec :: !GhcSpec
+ }
+
+-- | The following is the overall type for /specifications/ obtained from
+-- parsing the target source and dependent libraries
+
+data GhcSpec = SP {
+ tySigs :: ![(Var, Located SpecType)] -- ^ Asserted/Assumed Reftypes
+ -- eg. see include/Prelude.spec
+ , ctor :: ![(Var, Located SpecType)] -- ^ Data Constructor Measure Sigs
+ -- eg. (:) :: a -> xs:[a] -> {v: Int | v = 1 + len(xs) }
+ , meas :: ![(Symbol, Located RefType)] -- ^ Measure Types
+ -- eg. len :: [a] -> Int
+ , invariants :: ![Located SpecType] -- ^ Data Type Invariants
+ -- eg. forall a. {v: [a] | len(v) >= 0}
+ , 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
+ -- 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
+ , qualifiers :: ![Qualifier] -- ^ Qualifiers in Source/Spec files
+ -- e.g tests/pos/qualTest.hs
+ , tgtVars :: ![Var] -- ^ Top-level Binders To Verify (empty means ALL binders)
+ , decr :: ![(Var, [Int])] -- ^ Lexicographically ordered size witnesses for termination
+ , lvars :: !(S.HashSet Var) -- ^ Variables that should be checked in the environment they are used
+ , lazy :: !(S.HashSet Var) -- ^ Binders to IGNORE during termination checking
+ , config :: !Config -- ^ Configuration Options
+ }
+
+
+data TyConP = TyConP { freeTyVarsTy :: ![RTyVar]
+ , freePredTy :: ![(PVar RSort)]
+ , covPs :: ![Int] -- indexes of covariant predicate arguments
+ , contravPs :: ![Int] -- indexes of contravariant predicate arguments
+ , sizeFun :: !(Maybe (Symbol -> Expr))
+ }
+
+data DataConP = DataConP { freeTyVars :: ![RTyVar]
+ , freePred :: ![(PVar RSort)]
+ , tyArgs :: ![(Symbol, SpecType)]
+ , tyRes :: !SpecType
+ }
+
+
+-- | Which Top-Level Binders Should be Verified
+data TargetVars = AllVars | Only ![Var]
+
+
+--------------------------------------------------------------------
+-- | Predicate Variables -------------------------------------------
+--------------------------------------------------------------------
+
+-- MOVE TO TYPES
+data PVar t
+ = PV { pname :: !Symbol
+ , ptype :: !t
+ , pargs :: ![(t, Symbol, Expr)]
+ }
+ deriving (Show)
+
+instance Eq (PVar t) where
+ pv == pv' = (pname pv == pname pv') {- UNIFY: What about: && eqArgs pv pv' -}
+
+instance Ord (PVar t) where
+ compare (PV n _ _) (PV n' _ _) = compare n n'
+
+instance Functor PVar where
+ fmap f (PV x t txys) = PV x (f t) (mapFst3 f <$> txys)
+
+instance (NFData a) => NFData (PVar a) where
+ rnf (PV n t txys) = rnf n `seq` rnf t `seq` rnf txys
+
+instance Hashable (PVar a) where
+ hashWithSalt i (PV n _ xys) = hashWithSalt i n -- : (thd3 <$> xys)
+
+--------------------------------------------------------------------
+------------------ Predicates --------------------------------------
+--------------------------------------------------------------------
+
+type UsedPVar = PVar ()
+newtype Predicate = Pr [UsedPVar] -- deriving (Data, Typeable)
+
+instance NFData Predicate where
+ rnf _ = ()
+
+instance Monoid Predicate where
+ mempty = pdTrue
+ mappend p p' = pdAnd [p, p']
+
+instance (Monoid a) => Monoid (UReft a) where
+ mempty = U mempty mempty
+ mappend (U x y) (U x' y') = U (mappend x x') (mappend y y')
+
+
+pdTrue = Pr []
+pdAnd ps = Pr (nub $ concatMap pvars ps)
+pvars (Pr pvs) = pvs
+
+-- MOVE TO TYPES
+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 }
+
+
+-- MOVE TO TYPES
+instance Subable Predicate where
+ 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)
+
+
+
+instance NFData r => NFData (UReft r) where
+ rnf (U r p) = rnf r `seq` rnf p
+
+instance NFData PrType where
+ rnf _ = ()
+
+instance NFData RTyVar where
+ rnf _ = ()
+
+
+-- MOVE TO TYPES
+newtype RTyVar = RTV TyVar
+
+data RTyCon = RTyCon
+ { rTyCon :: !TyCon -- GHC Type Constructor
+ , rTyConPs :: ![RPVar] -- Predicate Parameters
+ , rTyConInfo :: !TyConInfo -- TyConInfo
+ }
+ -- deriving (Data, Typeable)
+
+-----------------------------------------------------------------------
+----------- TyCon get CoVariance - ContraVariance Info ----------------
+-----------------------------------------------------------------------
+
+-- indexes start from 0 and type or predicate arguments can be both
+-- covariant and contravaariant
+-- eg, for the below Foo dataType
+-- data Foo a b c d Prop, q :: Int -> Prop, r :: a -> Prop>
+-- = F (a -> b) | Q (c -> a) | G (Int -> a)
+-- there will be
+-- covariantTyArgs = [0, 1, 3], for type arguments a, b and d
+-- contravariantTyArgs = [0, 2, 3], for type arguments a, c and d
+-- covariantPsArgs = [0, 2], for predicate arguments p and r
+-- contravariantPsArgs = [1, 2], for predicate arguments q and r
+--
+-- Note, d does not appear in the data definition, we enforce BOTH
+-- con - contra variance
+
+data TyConInfo = TyConInfo
+ { covariantTyArgs :: ![Int] -- indexes of covariant type arguments
+ , contravariantTyArgs :: ![Int] -- indexes of contravariant type arguments
+ , covariantPsArgs :: ![Int] -- indexes of covariant predicate arguments
+ , contravariantPsArgs :: ![Int] -- indexes of contravariant predicate arguments
+ , sizeFunction :: !(Maybe (Symbol -> Expr))
+ }
+
+
+--------------------------------------------------------------------
+---- Unified Representation of Refinement Types --------------------
+--------------------------------------------------------------------
+
+-- MOVE TO TYPES
+data RType p c tv r
+ = RVar {
+ rt_var :: !tv
+ , rt_reft :: !r
+ }
+
+ | RFun {
+ rt_bind :: !Symbol
+ , rt_in :: !(RType p c tv r)
+ , rt_out :: !(RType p c tv r)
+ , rt_reft :: !r
+ }
+
+ | RAllT {
+ rt_tvbind :: !tv
+ , rt_ty :: !(RType p c tv r)
+ }
+
+ | RAllP {
+ rt_pvbind :: !(PVar (RType p c tv ()))
+ , rt_ty :: !(RType p c tv r)
+ }
+
+ | RApp {
+ rt_tycon :: !c
+ , rt_args :: ![(RType p c tv r)]
+ , rt_pargs :: ![Ref (RType p c tv ()) r (RType p c tv r)]
+ , rt_reft :: !r
+ }
+
+ | RCls {
+ rt_class :: !p
+ , rt_args :: ![(RType p c tv r)]
+ }
+
+ | RAllE {
+ rt_bind :: !Symbol
+ , rt_allarg :: !(RType p c tv r)
+ , rt_ty :: !(RType p c tv r)
+ }
+
+ | REx {
+ rt_bind :: !Symbol
+ , rt_exarg :: !(RType p c tv r)
+ , rt_ty :: !(RType p c tv r)
+ }
+
+ | RExprArg Expr -- ^ For expression arguments to type aliases
+ -- see tests/pos/vector2.hs
+ | RAppTy{
+ rt_arg :: !(RType p c tv r)
+ , rt_res :: !(RType p c tv r)
+ , rt_reft :: !r
+ }
+
+ | ROth !String
+
+-- MOVE TO TYPES
+
+data Ref t s m
+ = RMono [(Symbol, t)] s
+ | RPoly [(Symbol, t)] m
+
+-- MOVE TO TYPES
+data UReft r
+ = U { ur_reft :: !r, ur_pred :: !Predicate }
+
+-- MOVE TO TYPES
+type BRType = RType String String String
+type RRType = RType Class RTyCon RTyVar
+
+type BSort = BRType ()
+type RSort = RRType ()
+
+type BPVar = PVar BSort
+type RPVar = PVar RSort
+
+type RReft = UReft Reft
+type PrType = RRType Predicate
+type BareType = BRType RReft
+type SpecType = RRType RReft
+type RefType = RRType Reft
+
+
+class SubsTy tv ty a where
+ subt :: (tv, ty) -> a -> a
+
+
+-- MOVE TO TYPES
+class (Eq c) => TyConable c where
+ isFun :: c -> Bool
+ isList :: c -> Bool
+ isTuple :: c -> Bool
+ ppTycon :: c -> Doc
+
+-- MOVE TO TYPES
+class ( TyConable c
+ , Eq p, Eq c, Eq tv
+ , Hashable tv
+ , Reftable r
+ , PPrint r
+ ) => RefTypable p c tv r
+ where
+ ppCls :: p -> [RType p c tv r] -> Doc
+ ppRType :: Prec -> RType p c tv r -> Doc
+ -- ppRType = ppr_rtype True -- False
+ -- ppBase :: r -> Doc -> Doc
+
+--------------------------------------------------------------------------
+-- | Values Related to Specifications ------------------------------------
+--------------------------------------------------------------------------
+
+-- | Data type refinements
+data DataDecl = D { tycName :: String -- ^ Type Constructor Name
+ , tycTyVars :: [String] -- ^ Tyvar Parameters
+ , tycPVars :: [PVar BSort] -- ^ PVar Parameters
+ , tycDCons :: [(String, [(String, BareType)])] -- ^ [DataCon, [(fieldName, fieldType)]]
+ , tycSrcPos :: !SourcePos -- ^ Source Position
+ , tycSFun :: (Maybe (Symbol -> Expr)) -- ^ Measure that should decrease in recursive calls
+ }
+ -- deriving (Show)
+
+-- | Refinement Type Aliases
+
+data RTAlias tv ty
+ = RTA { rtName :: String
+ , rtTArgs :: [tv]
+ , rtVArgs :: [tv]
+ , rtBody :: ty
+ , srcPos :: SourcePos
+ }
+
+mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt
+ , rtVArgs = f <$> rtVArgs rt
+ }
+
+-- | Datacons
+
+data BDataCon a
+ = BDc a -- ^ Raw named data constructor
+ | BTup Int -- ^ Tuple constructor + arity
+ deriving (Eq, Ord, Show)
+
+instance Functor BDataCon where
+ fmap f (BDc x) = BDc (f x)
+ fmap f (BTup i) = BTup i
+
+instance Hashable a => Hashable (BDataCon a) where
+ hashWithSalt i (BDc x) = hashWithSalt i x
+ hashWithSalt i (BTup j) = hashWithSalt i j
+
+------------------------------------------------------------------------
+-- | Constructor and Destructors for RTypes ----------------------------
+------------------------------------------------------------------------
+
+mkArrow αs πs xts = mkUnivs αs πs . mkArrs xts
+ where
+ mkArrs xts t = foldr (uncurry rFun) t xts
+
+bkArrowDeep (RAllT _ t) = bkArrowDeep t
+bkArrowDeep (RAllP _ t) = bkArrowDeep t
+bkArrowDeep (RFun x t t' _) = let (xs, ts, t'') = bkArrowDeep t' in (x:xs, t:ts, t'')
+bkArrowDeep t = ([], [], t)
+
+bkArrow (RFun x t t' _) = let (xs, ts, t'') = bkArrow t' in (x:xs, t:ts, t'')
+bkArrow t = ([], [], t)
+
+safeBkArrow (RAllT _ _) = errorstar "safeBkArrow on RAllT"
+safeBkArrow (RAllP _ _) = errorstar "safeBkArrow on RAllT"
+safeBkArrow t = bkArrow t
+
+mkUnivs αs πs t = foldr RAllT (foldr RAllP t πs) αs
+
+bkUniv :: RType t t1 a t2 -> ([a], [PVar (RType t t1 a ())], RType t t1 a t2)
+bkUniv (RAllT α t) = let (αs, πs, t') = bkUniv t in (α:αs, πs, t')
+bkUniv (RAllP π t) = let (αs, πs, t') = bkUniv t in (αs, π:πs, t')
+bkUniv t = ([], [], t)
+
+bkClass (RFun _ (RCls c t) t' _) = let (cs, t'') = bkClass t' in ((c, t):cs, t'')
+bkClass t = ([], t)
+
+rFun b t t' = RFun b t t' top
+rAppTy t t' = RAppTy t t' top
+
+
+--------------------------------------------
+
+instance (PPrint r, Reftable r) => Reftable (UReft r) where
+ isTauto = isTauto_ureft
+ -- ppTy (U r p) d = ppTy r (ppTy p d)
+ ppTy = ppTy_ureft
+ toReft (U r _) = toReft r
+ params (U r _) = params r
+ bot (U r _) = U (bot r) (Pr [])
+
+isTauto_ureft u = isTauto (ur_reft u) && isTauto (ur_pred u)
+
+ppTy_ureft u@(U r p) d
+ | isTauto_ureft u = d
+ | otherwise = ppr_reft r (ppTy p d)
+
+ppr_reft r d = braces (toFix v <+> colon <+> d <+> text "|" <+> pprint r')
+ where
+ r'@(Reft (v, _)) = toReft r
+
+
+instance Subable r => Subable (UReft r) where
+ syms (U r p) = syms r ++ syms p
+ subst s (U r z) = U (subst s r) (subst s z)
+ substf f (U r z) = U (substf f r) (substf f z)
+ substa f (U r z) = U (substa f r) (substa f z)
+
+instance (Reftable r, RefTypable p c tv r) => Subable (Ref (RType p c tv ()) r (RType p c tv r)) where
+ syms (RMono ss r) = (fst <$> ss) ++ syms r
+ syms (RPoly ss r) = (fst <$> ss) ++ syms r
+
+ subst su (RMono ss r) = RMono ss (subst su r)
+ subst su (RPoly ss t) = RPoly ss (subst su <$> t)
+
+ substf f (RMono ss r) = RMono ss (substf f r)
+ substf f (RPoly ss t) = RPoly ss (substf f <$> t)
+ substa f (RMono ss r) = RMono ss (substa f r)
+ substa f (RPoly ss t) = RPoly ss (substa f <$> t)
+
+instance (Subable r, RefTypable p c tv r) => Subable (RType p c tv r) where
+ 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
+
+
+
+
+instance Reftable Predicate where
+ isTauto (Pr ps) = null ps
+
+ bot (Pr _) = errorstar "No BOT instance for Predicate"
+ -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX.
+ ppTy r d | isTauto r = d
+ | not (ppPs ppEnv) = d
+ | otherwise = d <> (angleBrackets $ pprint r)
+
+ toReft = errorstar "TODO: instance of toReft for Predicate"
+ params = errorstar "TODO: instance of params for Predicate"
+
+
+---------------------------------------------------------------
+--------------------------- Visitors --------------------------
+---------------------------------------------------------------
+
+isTrivial t = foldReft (\r b -> isTauto r && b) True t
+
+instance Functor UReft where
+ fmap f (U r p) = U (f r) p
+
+instance Functor (RType a b c) where
+ fmap = mapReft
+
+-- instance Fold.Foldable (RType a b c) where
+-- foldr = foldReft
+
+mapReft :: (r1 -> r2) -> RType p c tv r1 -> RType p c tv r2
+mapReft f = emapReft (\_ -> f) []
+
+emapReft :: ([Symbol] -> r1 -> r2) -> [Symbol] -> RType p c tv r1 -> RType p c tv r2
+
+emapReft f γ (RVar α r) = RVar α (f γ r)
+emapReft f γ (RAllT α t) = RAllT α (emapReft f γ t)
+emapReft f γ (RAllP π t) = RAllP π (emapReft f γ t)
+emapReft f γ (RFun x t t' r) = RFun x (emapReft f γ t) (emapReft f (x:γ) t') (f γ r)
+emapReft f γ (RApp c ts rs r) = RApp c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r)
+emapReft f γ (RCls c ts) = RCls c (emapReft f γ <$> ts)
+emapReft f γ (RAllE z t t') = RAllE z (emapReft f γ t) (emapReft f γ t')
+emapReft f γ (REx z t t') = REx z (emapReft f γ t) (emapReft f γ t')
+emapReft _ _ (RExprArg e) = RExprArg e
+emapReft f γ (RAppTy t t' r) = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)
+emapReft _ _ (ROth s) = ROth s
+
+emapRef :: ([Symbol] -> t -> s) -> [Symbol] -> Ref (RType p c tv ()) t (RType p c tv t) -> Ref (RType p c tv ()) s (RType p c tv s)
+emapRef f γ (RMono s r) = RMono s $ f γ r
+emapRef f γ (RPoly s t) = RPoly s $ emapReft f γ t
+
+------------------------------------------------------------------------------------------------------
+
+
+mapReftM :: (Monad m) => (r1 -> m r2) -> RType p c tv r1 -> m (RType p c tv r2)
+mapReftM f (RVar α r) = liftM (RVar α) (f r)
+mapReftM f (RAllT α t) = liftM (RAllT α) (mapReftM f t)
+mapReftM f (RAllP π t) = liftM (RAllP π) (mapReftM f t)
+mapReftM f (RFun x t t' r) = liftM3 (RFun x) (mapReftM f t) (mapReftM f t') (f r)
+mapReftM f (RApp c ts rs r) = liftM3 (RApp c) (mapM (mapReftM f) ts) (mapM (mapRefM f) rs) (f r)
+mapReftM f (RCls c ts) = liftM (RCls c) (mapM (mapReftM f) ts)
+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 f (RAppTy t t' r) = liftM3 (RAppTy) (mapReftM f t) (mapReftM f t') (f r)
+mapReftM _ (ROth s) = return $ ROth s
+
+mapRefM :: (Monad m) => (t -> m s) -> Ref (RType p c tv ()) t (RType p c tv t) -> m (Ref (RType p c tv ()) s (RType p c tv s))
+mapRefM f (RMono s r) = liftM (RMono s) (f r)
+mapRefM f (RPoly s t) = liftM (RPoly s) (mapReftM f t)
+
+-- foldReft :: (r -> a -> a) -> a -> RType p c tv r -> a
+foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) emptySEnv
+
+-- efoldReft :: Reftable r =>(p -> [RType p c tv r] -> [(Symbol, a)])-> (RType p c tv r -> a)-> (SEnv a -> Maybe (RType p c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType p c tv r-> c1
+efoldReft cb g f = go
+ where
+ -- folding over RType
+ go γ z me@(RVar _ r) = f γ (Just me) r z
+ go γ z (RAllT _ t) = go γ z t
+ go γ z (RAllP _ t) = go γ z t
+ go γ z me@(RFun _ (RCls c ts) t' r) = 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 (RCls c ts) = go' γ z ts
+ 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 (ROth _) = z
+ go γ z me@(RAppTy t t' r) = f γ (Just me) r (go γ (go γ z t) t')
+ go _ z (RExprArg _) = z
+
+ -- folding over Ref
+ ho γ z (RMono ss r) = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z
+ ho γ z (RPoly ss t) = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t
+
+ -- folding over [RType]
+ go' γ z ts = foldr (flip $ go γ) z ts
+
+ -- folding over [Ref]
+ ho' γ z rs = foldr (flip $ ho γ) z rs
+
+-- ORIG delete after regrtest-ing specerror
+-- -- efoldReft :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> RType p c tv r -> a
+-- efoldReft g f γ z me@(RVar _ r) = f γ (Just me) r z
+-- efoldReft g f γ z (RAllT _ t) = efoldReft g f γ z t
+-- efoldReft g f γ z (RAllP _ t) = efoldReft g f γ z t
+-- efoldReft g f γ z me@(RFun x t t' r) = f γ (Just me) r (efoldReft g f (insertSEnv x (g t) γ) (efoldReft g f γ z t) t')
+-- efoldReft g f γ z me@(RApp _ ts rs r) = f γ (Just me) r (efoldRefs g f γ (efoldRefts g f (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs)
+-- efoldReft g f γ z (RCls _ ts) = efoldRefts g f γ z ts
+-- efoldReft g f γ z (RAllE x t t') = efoldReft g f (insertSEnv x (g t) γ) (efoldReft g f γ z t) t'
+-- efoldReft g f γ z (REx x t t') = efoldReft g f (insertSEnv x (g t) γ) (efoldReft g f γ z t) t'
+-- efoldReft _ _ _ z (ROth _) = z
+-- efoldReft g f γ z me@(RAppTy t t' r) = f γ (Just me) r (efoldReft g f γ (efoldReft g f γ z t) t')
+-- efoldReft _ _ _ z (RExprArg _) = z
+--
+-- -- efoldRefts :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> [RType p c tv r] -> a
+-- efoldRefts g f γ z ts = foldr (flip $ efoldReft g f γ) z ts
+--
+-- -- efoldRefs :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> [Ref r (RType p c tv r)] -> a
+-- efoldRefs g f γ z rs = foldr (flip $ efoldRef g f γ) z rs
+--
+-- -- efoldRef :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> Ref r (RType p c tv r) -> a
+-- efoldRef g f γ z (RMono ss r) = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z
+-- efoldRef g f γ z (RPoly ss t) = efoldReft g f (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t
+
+mapBot f (RAllT α t) = RAllT α (mapBot f t)
+mapBot f (RAllP π t) = RAllP π (mapBot f t)
+mapBot f (RFun x t t' r) = RFun x (mapBot f t) (mapBot f t') r
+mapBot f (RAppTy t t' r) = RAppTy (mapBot f t) (mapBot f t') r
+mapBot f (RApp c ts rs r) = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r
+mapBot f (RCls c ts) = RCls c (mapBot f <$> ts)
+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 t' = f t'
+mapBotRef _ (RMono s r) = RMono s $ r
+mapBotRef f (RPoly s t) = RPoly s $ mapBot f t
+
+mapBind f (RAllT α t) = RAllT α (mapBind f t)
+mapBind f (RAllP π t) = RAllP π (mapBind f t)
+mapBind f (RFun b t1 t2 r) = RFun (f b) (mapBind f t1) (mapBind f t2) r
+mapBind f (RApp c ts rs r) = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r
+mapBind f (RCls c ts) = RCls c (mapBind f <$> ts)
+mapBind f (RAllE b t1 t2) = RAllE (f b) (mapBind f t1) (mapBind f t2)
+mapBind f (REx b t1 t2) = REx (f b) (mapBind f t1) (mapBind f t2)
+mapBind _ (RVar α r) = RVar α r
+mapBind _ (ROth s) = ROth s
+mapBind f (RAppTy t1 t2 r) = RAppTy (mapBind f t1) (mapBind f t2) r
+mapBind _ (RExprArg e) = RExprArg e
+
+mapBindRef f (RMono s r) = RMono (mapFst f <$> s) r
+mapBindRef f (RPoly s t) = RPoly (mapFst f <$> s) $ mapBind f t
+
+
+--------------------------------------------------
+ofRSort :: Reftable r => RType p c tv () -> RType p c tv r
+ofRSort = fmap (\_ -> top)
+
+toRSort :: RType p c tv r -> RType p c tv ()
+toRSort = stripQuantifiers . mapBind (const dummySymbol) . fmap (const ())
+
+stripQuantifiers (RAllT α t) = RAllT α (stripQuantifiers t)
+stripQuantifiers (RAllP _ t) = stripQuantifiers t
+stripQuantifiers (RAllE _ _ t) = stripQuantifiers t
+stripQuantifiers (REx _ _ t) = stripQuantifiers t
+stripQuantifiers (RFun x t t' r) = RFun x (stripQuantifiers t) (stripQuantifiers t') r
+stripQuantifiers (RAppTy t t' r) = RAppTy (stripQuantifiers t) (stripQuantifiers t') r
+stripQuantifiers (RApp c ts rs r) = RApp c (stripQuantifiers <$> ts) (stripQuantifiersRef <$> rs) r
+stripQuantifiers (RCls c ts) = RCls c (stripQuantifiers <$> ts)
+stripQuantifiers t = t
+stripQuantifiersRef (RPoly s t) = RPoly s $ stripQuantifiers t
+stripQuantifiersRef r = r
+
+
+insertsSEnv = foldr (\(x, t) γ -> insertSEnv x t γ)
+
+rTypeValueVar :: (Reftable r) => RType p c tv r -> Symbol
+rTypeValueVar t = vv where Reft (vv,_) = rTypeReft t
+rTypeReft :: (Reftable r) => RType p c tv r -> Reft
+rTypeReft = fromMaybe top . fmap toReft . stripRTypeBase
+
+-- stripRTypeBase :: RType a -> Maybe a
+stripRTypeBase (RApp _ _ _ x)
+ = Just x
+stripRTypeBase (RVar _ x)
+ = Just x
+stripRTypeBase (RFun _ _ _ x)
+ = Just x
+stripRTypeBase _
+ = Nothing
+
+-----------------------------------------------------------------------------
+-- | PPrint -----------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+instance PPrint SourcePos where
+ pprint = text . show
+
+instance PPrint () where
+ pprint = text . show
+
+instance PPrint String where
+ pprint = text
+
+instance PPrint a => PPrint (Located a) where
+ pprint = pprint . val
+
+instance PPrint Int where
+ pprint = toFix
+
+instance PPrint Integer where
+ pprint = toFix
+
+instance PPrint Constant where
+ pprint = toFix
+
+instance PPrint Brel where
+ pprint Eq = text "=="
+ pprint Ne = text "/="
+ pprint r = toFix r
+
+instance PPrint Bop where
+ pprint = toFix
+
+instance PPrint Sort where
+ pprint = toFix
+
+instance PPrint Symbol where
+ pprint = toFix
+
+instance PPrint Expr where
+ pprint (EApp f es) = parens $ intersperse empty $ (pprint f) : (pprint <$> es)
+ pprint (ECon c) = pprint c
+ pprint (EVar s) = pprint s
+ pprint (ELit s _) = pprint s
+ pprint (EBin o e1 e2) = parens $ pprint e1 <+> pprint o <+> pprint e2
+ pprint (EIte p e1 e2) = parens $ text "if" <+> pprint p <+> text "then" <+> pprint e1 <+> text "else" <+> pprint e2
+ pprint (ECst e so) = parens $ pprint e <+> text " : " <+> pprint so
+ pprint (EBot) = text "_|_"
+
+instance PPrint Pred where
+ pprint PTop = text "???"
+ pprint PTrue = trueD
+ pprint PFalse = falseD
+ pprint (PBexp e) = parens $ pprint e
+ pprint (PNot p) = parens $ text "not" <+> parens (pprint p)
+ pprint (PImp p1 p2) = parens $ (pprint p1) <+> text "=>" <+> (pprint p2)
+ pprint (PIff p1 p2) = parens $ (pprint p1) <+> text "<=>" <+> (pprint p2)
+ pprint (PAnd ps) = parens $ pprintBin trueD andD ps
+ pprint (POr ps) = parens $ pprintBin falseD orD ps
+ pprint (PAtom r e1 e2) = parens $ pprint e1 <+> pprint r <+> pprint e2
+ pprint (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> pprint p
+
+trueD = text "true"
+falseD = text "false"
+andD = text " &&"
+orD = text " ||"
+
+pprintBin b _ [] = b
+pprintBin _ o xs = intersperse o $ pprint <$> xs
+
+-- pprintBin b o [] = b
+-- pprintBin b o [x] = pprint x
+-- pprintBin b o (x:xs) = pprint x <+> o <+> pprintBin b o xs
+
+instance PPrint a => PPrint (PVar a) where
+ pprint (PV s _ xts) = pprint s <+> hsep (pprint <$> dargs xts)
+ where
+ dargs = map thd3 . takeWhile (\(_, x, y) -> EVar x /= nexpr y)
+ nexpr (EVar (S ss)) = EVar $ stringSymbol ss
+ nexpr e = e
+
+instance PPrint Predicate where
+ pprint (Pr []) = text "True"
+ pprint (Pr pvs) = hsep $ punctuate (text "&") (map pprint pvs)
+
+instance PPrint Refa where
+ pprint (RConc p) = pprint p
+ pprint k = toFix k
+
+instance PPrint Reft where
+ pprint r@(Reft (_,ras))
+ | isTauto r = text "true"
+ | otherwise = {- intersperse comma -} pprintBin trueD andD $ flattenRefas ras
+
+instance PPrint SortedReft where
+ pprint (RR so (Reft (v, ras)))
+ = braces
+ $ (pprint v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> pprint ras
+
+------------------------------------------------------------------------
+-- | Error Data Type ---------------------------------------------------
+------------------------------------------------------------------------
+
+type ErrorResult = FixResult Error
+
+data Error =
+ ErrSubType { pos :: !SrcSpan
+ , msg :: !Doc
+ , act :: !SpecType
+ , exp :: !SpecType
+ } -- ^ liquid type error
+
+ | ErrParse { pos :: !SrcSpan
+ , msg :: !Doc
+ , err :: !ParseError
+ } -- ^ specification parse error
+ | ErrTySpec { pos :: !SrcSpan
+ , var :: !Doc
+ , typ :: !SpecType
+ , msg :: !Doc
+ } -- ^ sort error in specification
+ | ErrDupSpecs { pos :: !SrcSpan
+ , var :: !Doc
+ , locs:: ![SrcSpan]
+ } -- ^ multiple specs for same binder error
+ | ErrInvt { pos :: !SrcSpan
+ , inv :: !SpecType
+ , msg :: !Doc
+ } -- ^ Invariant sort error
+ | ErrMeas { pos :: !SrcSpan
+ , ms :: !Symbol
+ , msg :: !Doc
+ } -- ^ Measure sort error
+ | ErrGhc { pos :: !SrcSpan
+ , msg :: !Doc
+ } -- ^ GHC error: parsing or type checking
+ | ErrMismatch { pos :: !SrcSpan
+ , var :: !Doc
+ , hs :: !Type
+ , exp :: !SpecType
+ } -- ^ Mismatch between Liquid and Haskell types
+ | ErrOther { msg :: !Doc
+ } -- ^ Unexpected PANIC
+ deriving (Typeable)
+
+instance Eq Error where
+ e1 == e2 = pos e1 == pos e2
+
+instance Ord Error where
+ e1 <= e2 = pos e1 <= pos e2
+
+------------------------------------------------------------------------
+-- | Source Information Associated With Constraints --------------------
+------------------------------------------------------------------------
+
+data Cinfo = Ci { ci_loc :: !SrcSpan
+ , ci_err :: !(Maybe Error)
+ }
+ deriving (Eq, Ord)
+
+instance NFData Cinfo
+
+
+------------------------------------------------------------------------
+-- | Converting Results To Answers -------------------------------------
+------------------------------------------------------------------------
+
+class Result a where
+ result :: a -> FixResult Error
+
+instance Result [Error] where
+ result es = Crash es ""
+
+instance Result Error where
+ result (ErrOther d) = UnknownError d
+ result e = result [e]
+
+instance Result (FixResult Cinfo) where
+ result = fmap cinfoError
+
+--------------------------------------------------------------------------------
+--- Module Names
+--------------------------------------------------------------------------------
+
+data ModName = ModName !ModType !ModuleName deriving (Eq,Ord)
+
+instance Show ModName where
+ show = getModString
+
+data ModType = Target | SrcImport | SpecImport deriving (Eq,Ord)
+
+isSrcImport (ModName SrcImport _) = True
+isSrcImport _ = False
+
+isSpecImport (ModName SpecImport _) = True
+isSpecImport _ = False
+
+getModName (ModName _ m) = m
+
+getModString = moduleNameString . getModName
+
+
+-------------------------------------------------------------------------------
+----------- Refinement Type Aliases -------------------------------------------
+-------------------------------------------------------------------------------
+
+type RTBareOrSpec = Either (ModName, (RTAlias String BareType))
+ (RTAlias RTyVar SpecType)
+
+type RTPredAlias = Either (ModName, RTAlias Symbol Pred)
+ (RTAlias Symbol Pred)
+
+data RTEnv = RTE { typeAliases :: M.HashMap String RTBareOrSpec
+ , predAliases :: M.HashMap String RTPredAlias
+ }
+
+instance Monoid RTEnv where
+ (RTE ta1 pa1) `mappend` (RTE ta2 pa2) = RTE (ta1 `M.union` ta2) (pa1 `M.union` pa2)
+ mempty = RTE M.empty M.empty
+
+mapRT f e = e { typeAliases = f $ typeAliases e }
+mapRP f e = e { predAliases = f $ predAliases e }
+
+cinfoError (Ci _ (Just e)) = e
+cinfoError (Ci l _) = ErrOther $ text $ "Cinfo:" ++ (showPpr l)
+
diff --git a/Liquid.hs b/Liquid.hs
new file mode 100644
--- /dev/null
+++ b/Liquid.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE BangPatterns, TupleSections #-}
+
+import qualified Data.HashMap.Strict as M
+-- import qualified Control.Exception as Ex
+-- import Data.Maybe (catMaybes)
+import Data.Monoid (mconcat)
+import System.Exit
+import Control.Applicative ((<$>))
+import Control.DeepSeq
+import Control.Monad (when)
+
+import CoreSyn
+-- import FastString
+-- import GHC
+-- import HscMain
+-- import RdrName
+import Var
+
+import System.Console.CmdArgs.Verbosity (whenLoud)
+import System.Console.CmdArgs.Default
+import Language.Fixpoint.Config (Config (..))
+import Language.Fixpoint.Files
+-- import Language.Fixpoint.Names
+import Language.Fixpoint.Misc
+-- import Language.Fixpoint.Names (dropModuleNames)
+import Language.Fixpoint.Interface
+import Language.Fixpoint.Types (sinfo, showFix, isFalse)
+
+import qualified Language.Haskell.Liquid.DiffCheck as DC
+import Language.Haskell.Liquid.Misc
+import Language.Haskell.Liquid.Types
+import Language.Haskell.Liquid.CmdLine
+import Language.Haskell.Liquid.GhcInterface
+import Language.Haskell.Liquid.Constraint
+import Language.Haskell.Liquid.TransformRec
+
+main :: IO b
+main = do cfg0 <- getOpts
+ res <- mconcat <$> mapM (checkOne cfg0) (files cfg0)
+ exitWith $ resultExit res
+
+checkOne cfg0 t = getGhcInfo cfg0 t >>= either (exitWithResult t Nothing) (liquidOne t)
+
+
+liquidOne target info =
+ do donePhase Loud "Extracted Core From GHC"
+ let cfg = config $ spec info
+ whenLoud $ do putStrLn $ showpp info
+ putStrLn "*************** Original CoreBinds ***************************"
+ putStrLn $ showpp (cbs info)
+ let cbs' = transformRecExpr (cbs info)
+ whenLoud $ do donePhase Loud "transformRecExpr"
+ putStrLn "*************** Transform Rec Expr CoreBinds *****************"
+ putStrLn $ showpp cbs'
+ putStrLn "*************** Slicing Out Unchanged CoreBinds *****************"
+ (pruned, cbs'') <- prune cfg cbs' target info
+ let cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info {cbs = cbs''}
+ cgi `deepseq` donePhase Loud "generateConstraints"
+ -- whenLoud $ do donePhase Loud "START: Write CGI (can be slow!)"
+ -- {-# SCC "writeCGI" #-} writeCGI target cgi
+ -- donePhase Loud "FINISH: Write CGI"
+ (r, sol) <- solveCs cfg target cgi info
+ _ <- when (diffcheck cfg) $ DC.save target
+ donePhase Loud "solve"
+ let out = Just $ O (checkedNames pruned cbs'') (logWarn cgi) sol (annotMap cgi)
+ exitWithResult target out (result $ sinfo <$> r)
+
+checkedNames False _ = Nothing
+checkedNames True cbs = Just $ concatMap names cbs
+ where
+ names (NonRec v _ ) = [varName v]
+ names (Rec bs) = map (varName . fst) bs
+
+prune cfg cbs target info
+ | not (null vs) = return (True, DC.thin cbs vs)
+ | diffcheck cfg = (True,) <$> DC.slice target cbs
+ | otherwise = return (False, cbs)
+ where
+ vs = tgtVars $ spec info
+
+solveCs cfg target cgi info
+ | nofalse cfg
+ = do hqBot <- getHqBotPath
+ (_, solBot) <- solve fx target [hqBot] (cgInfoFInfoBot cgi)
+ let falseKvars = M.keys (M.filterWithKey (const isFalse) solBot)
+ putStrLn $ "False KVars" ++ show falseKvars
+ solve fx target (hqFiles info) (cgInfoFInfoKvars cgi falseKvars)
+
+ | otherwise
+ = solve fx target (hqFiles info) (cgInfoFInfo cgi)
+ where
+ fx = def { solver = smtsolver cfg }
+
+writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str
+ where
+ str = {-# SCC "PPcgi" #-} showFix cgi
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,9 @@
+import Distribution.Simple
+
+main = defaultMain
+
+-- main = defaultMainWithHooks fixpointHooks
+--
+-- fixpointHooks = defaultUserHooks { postInst = cpFix }
+-- where
+-- cpFix _ _ _ lbi = putStrLn $ "CPFIXSAYS: " ++ show lbi
diff --git a/include/Bot.hquals b/include/Bot.hquals
new file mode 100644
--- /dev/null
+++ b/include/Bot.hquals
@@ -0,0 +1,8 @@
+//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
+
diff --git a/include/Control/Exception.spec b/include/Control/Exception.spec
new file mode 100644
--- /dev/null
+++ b/include/Control/Exception.spec
@@ -0,0 +1,7 @@
+module spec Control.Exception where
+
+-- Useless as compiled into GHC primitive, which is ignored
+assume assert :: {v:Bool | (? (Prop v))} -> a -> a
+
+-- Hack into wiredIn
+-- assume GHC.IO.Exception.assertError :: {v:Bool | (? v)} -> GHC.Prim.Addr# -> a -> a
diff --git a/include/Control/Monad.spec b/include/Control/Monad.spec
new file mode 100644
--- /dev/null
+++ b/include/Control/Monad.spec
@@ -0,0 +1,3 @@
+module spec Control.Monad where
+
+sequence :: GHC.Base.Monad m => xs:[m a] -> m {v:[a] | (len v) = (len xs)}
diff --git a/include/Data/Int.spec b/include/Data/Int.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Int.spec
@@ -0,0 +1,2 @@
+module spec Data.Int where
+
diff --git a/include/Data/List.spec b/include/Data/List.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/List.spec
@@ -0,0 +1,18 @@
+module spec Data.List where
+
+import GHC.List
+
+assume groupBy :: (a -> a -> GHC.Types.Bool) -> [a] -> [{v:[a] | len(v) > 0}]
+
+assume transpose :: [[a]] -> [{v:[a] | (len v) > 0}]
+
+assume GHC.List.splitAt :: n:Nat -> x:[a] -> ({v:[a] | (Min (len v) (len x) n)},[a])<{\x1 x2 -> (len x2) = (len x) - (len x1)}>
+
+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)
+
+qualif SumLensEq(v:List List a, x:List a): (sumLens v) = (len x)
+
diff --git a/include/Data/Maybe.spec b/include/Data/Maybe.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Maybe.spec
@@ -0,0 +1,8 @@
+module spec Data.Maybe where
+
+measure isJust :: forall a. Data.Maybe.Maybe a -> Prop
+isJust (Data.Maybe.Just x) = true
+isJust (Data.Maybe.Nothing) = false
+
+measure fromJust :: forall a. Data.Maybe.Maybe a -> a
+fromJust (Data.Maybe.Just x) = x
diff --git a/include/Data/Set.spec b/include/Data/Set.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Set.spec
@@ -0,0 +1,53 @@
+module spec Data.Set where
+
+embed Data.Set.Set as Set_Set
+
+----------------------------------------------------------------------------------------------
+-- | Logical Set Operators: Interpreted "natively" by the SMT solver -------------------------
+----------------------------------------------------------------------------------------------
+
+-- | union
+measure Set_cup :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)
+
+-- | intersection
+measure Set_cap :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)
+
+-- | difference
+measure Set_dif :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)
+
+-- | singleton
+measure Set_sng :: a -> (Data.Set.Set a)
+
+-- | emptiness test
+measure Set_emp :: (Data.Set.Set a) -> Prop
+
+-- | 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
+
+---------------------------------------------------------------------------------------------
+-- | 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))}
+
+empty :: {v:(Data.Set.Set a) | (Set_emp v)}
+singleton :: x:a -> {v:(Data.Set.Set a) | v = (Set_sng x)}
+insert :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_cup xs (Set_sng x))}
+delete :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_dif xs (Set_sng x))}
+
+union :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_cup xs ys)}
+intersection :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_cap xs ys)}
+difference :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_dif xs ys)}
+
+
+---------------------------------------------------------------------------------------------
+-- | The set of elements in a list ----------------------------------------------------------
+---------------------------------------------------------------------------------------------
+
+measure listElts :: [a] -> (Data.Set.Set a)
+listElts([]) = {v | (? Set_emp(v))}
+listElts(x:xs) = {v | v = (Set_cup (Set_sng x) (listElts xs)) }
diff --git a/include/Data/Text/Fusion.spec b/include/Data/Text/Fusion.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Text/Fusion.spec
@@ -0,0 +1,25 @@
+module spec Data.Text.Fusion where
+
+import Data.Text.Fusion.Common
+
+stream :: t:Data.Text.Internal.Text
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (tlength t)}
+reverseStream :: t:Data.Text.Internal.Text
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (tlength t)}
+unstream :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Internal.Text | (tlength v) = (slen s)}
+
+findIndex :: (GHC.Types.Char -> GHC.Types.Bool)
+ -> s:Data.Text.Fusion.Internal.Stream Char
+ -> (Data.Maybe.Maybe {v:Nat | v < (slen s)})
+
+mapAccumL :: (a -> GHC.Types.Char -> (a,GHC.Types.Char))
+ -> a
+ -> s:Data.Text.Fusion.Internal.Stream Char
+ -> (a, {v:Data.Text.Internal.Text | (tlength v) = (slen s)})
+
+
+length :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:GHC.Types.Int | v = (slen s)}
+reverse :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Internal.Text | (tlength v) = (slen s)}
diff --git a/include/Data/Text/Fusion/Common.spec b/include/Data/Text/Fusion/Common.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Text/Fusion/Common.spec
@@ -0,0 +1,47 @@
+module spec Data.Text.Fusion.Common where
+
+measure slen :: Data.Text.Fusion.Internal.Stream a
+ -> GHC.Types.Int
+
+cons :: GHC.Types.Char
+ -> s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (1 + (slen s))}
+snoc :: s:Data.Text.Fusion.Internal.Stream Char
+ -> GHC.Types.Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (1 + (slen s))}
+
+compareLengthI :: s:Data.Text.Fusion.Internal.Stream Char
+ -> l:GHC.Types.Int
+ -> {v:GHC.Types.Ordering | ((v = GHC.Types.EQ) <=> ((slen s) = l))}
+
+isSingleton :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:GHC.Types.Bool | ((Prop v) <=> ((slen s) = 1))}
+singleton :: GHC.Types.Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = 1}
+
+streamList :: l:[a]
+ -> {v:Data.Text.Fusion.Internal.Stream a | (slen v) = (len l)}
+unstreamList :: s:Data.Text.Fusion.Internal.Stream a
+ -> {v:[a] | (len v) = (slen s)}
+
+map :: (GHC.Types.Char -> GHC.Types.Char)
+ -> s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (slen s)}
+filter :: (GHC.Types.Char -> GHC.Types.Bool)
+ -> s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) <= (slen s)}
+
+intersperse :: GHC.Types.Char
+ -> s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) > (slen s)}
+
+replicateCharI :: l:GHC.Types.Int
+ -> GHC.Types.Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = l}
+
+toCaseFold :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}
+toUpper :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}
+toLower :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}
diff --git a/include/Data/Text/Lazy/Fusion.spec b/include/Data/Text/Lazy/Fusion.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Text/Lazy/Fusion.spec
@@ -0,0 +1,8 @@
+module spec Data.Text.Lazy.Fusion where
+
+stream :: t:Data.Text.Lazy.Internal.Text
+ -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (ltlength t)}
+unstream :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:Data.Text.Lazy.Internal.Text | (ltlength v) = (slen s)}
+length :: s:Data.Text.Fusion.Internal.Stream Char
+ -> {v:GHC.Int.Int64 | v = (slen s)}
diff --git a/include/Data/Vector.hquals b/include/Data/Vector.hquals
new file mode 100644
--- /dev/null
+++ b/include/Data/Vector.hquals
@@ -0,0 +1,3 @@
+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])
diff --git a/include/Data/Vector.spec b/include/Data/Vector.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Vector.spec
@@ -0,0 +1,13 @@
+module spec Data.Vector where
+
+import GHC.Base
+
+measure vlen :: forall a. (Vector a) -> Int
+
+invariant {v: Vector a | (vlen v) >= 0 }
+
+assume ! :: forall a. x:(Vector a) -> vec:{v: Int | ((0 <= v) && (v < (vlen x))) } -> a
+
+assume fromList :: forall a. x:[a] -> {v: Vector a | (vlen v) = (len x) }
+
+assume length :: forall a. x:(Vector a) -> {v: Int | (v = (vlen x) && v >= 0) }
diff --git a/include/Data/Word.spec b/include/Data/Word.spec
new file mode 100644
--- /dev/null
+++ b/include/Data/Word.spec
@@ -0,0 +1,3 @@
+module spec Data.Word where
+
+import GHC.Word
diff --git a/include/Foreign/C/String.spec b/include/Foreign/C/String.spec
new file mode 100644
--- /dev/null
+++ b/include/Foreign/C/String.spec
@@ -0,0 +1,9 @@
+module spec Foreign.C.String where
+
+import Foreign.Ptr
+
+type CStringLen = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), Nat)<{\p v -> (v <= (plen p))}>
+type CStringLenN N = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), {v:Nat | v = N})<{\p v -> (v <= (plen p))}>
+
+measure cStringLen :: Foreign.C.String.CStringLen -> Int
+cStringLen (c, n) = n
diff --git a/include/Foreign/C/Types.spec b/include/Foreign/C/Types.spec
new file mode 100644
--- /dev/null
+++ b/include/Foreign/C/Types.spec
@@ -0,0 +1,8 @@
+module spec Foreign.C.Types where
+
+-- measure cSizeInt :: CSize -> GHC.Types.Int
+-- invariant {v: CSize | (cSizeInt v) >= 0}
+
+embed Foreign.C.Types.CInt as int
+embed Foreign.C.Types.CSize as int
+embed Foreign.C.Types.CULong as int
diff --git a/include/Foreign/ForeignPtr.spec b/include/Foreign/ForeignPtr.spec
new file mode 100644
--- /dev/null
+++ b/include/Foreign/ForeignPtr.spec
@@ -0,0 +1,20 @@
+module spec Foreign.ForeignPtr where
+
+import GHC.ForeignPtr
+import Foreign.Ptr
+
+measure fplen :: GHC.ForeignPtr.ForeignPtr a -> GHC.Types.Int
+
+type ForeignPtrV a = {v: (GHC.ForeignPtr.ForeignPtr a) | 0 <= (fplen v)}
+
+type ForeignPtrN a N = {v: (ForeignPtrV a) | (fplen v) = N }
+
+
+Foreign.ForeignPtr.withForeignPtr :: fp:(GHC.ForeignPtr.ForeignPtr a) -> ((PtrN a (fplen fp)) -> GHC.Types.IO b) -> (GHC.Types.IO b)
+GHC.ForeignPtr.newForeignPtr_ :: p:(GHC.Ptr.Ptr a) -> (GHC.Types.IO (ForeignPtrN a (plen p)))
+Foreign.Concurrent.newForeignPtr :: p:(PtrV a) -> GHC.Types.IO () -> (GHC.Types.IO (ForeignPtrN a (plen p)))
+
+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)
diff --git a/include/Foreign/Marshal/Alloc.spec b/include/Foreign/Marshal/Alloc.spec
new file mode 100644
--- /dev/null
+++ b/include/Foreign/Marshal/Alloc.spec
@@ -0,0 +1,3 @@
+module spec Foreign.Marshal.Alloc where
+
+Foreign.Marshal.Alloc.allocaBytes :: n:Nat -> (PtrN a n -> IO b) -> IO b
diff --git a/include/Foreign/Marshal/Array.spec b/include/Foreign/Marshal/Array.spec
new file mode 100644
--- /dev/null
+++ b/include/Foreign/Marshal/Array.spec
@@ -0,0 +1,3 @@
+module spec Foreign.Marshal.Array where
+
+Foreign.Marshal.Array.allocaArray :: Foreign.Storable.Storable a => n:Int -> ((PtrN a n) -> IO b) -> IO b
diff --git a/include/Foreign/Ptr.spec b/include/Foreign/Ptr.spec
new file mode 100644
--- /dev/null
+++ b/include/Foreign/Ptr.spec
@@ -0,0 +1,10 @@
+module spec Foreign.Ptr where
+
+import GHC.Ptr
+
+measure pbase :: Foreign.Ptr.Ptr a -> GHC.Types.Int
+measure plen :: Foreign.Ptr.Ptr a -> GHC.Types.Int
+measure isNullPtr :: Foreign.Ptr.Ptr a -> Prop
+
+type PtrN a N = {v: (PtrV a) | (plen v) = N }
+type PtrV a = {v: (GHC.Ptr.Ptr a) | 0 <= (plen v) }
diff --git a/include/Foreign/Storable.spec b/include/Foreign/Storable.spec
new file mode 100644
--- /dev/null
+++ b/include/Foreign/Storable.spec
@@ -0,0 +1,25 @@
+module spec Foreign.Storable where
+
+predicate PValid P N = ((0 <= N) && (N < (plen P)))
+
+Foreign.Storable.poke :: (Foreign.Storable.Storable a)
+ => {v: (GHC.Ptr.Ptr a) | 0 <= (plen v)}
+ -> a
+ -> (GHC.Types.IO ())
+
+Foreign.Storable.peek :: (Foreign.Storable.Storable a)
+ => p:{v: (GHC.Ptr.Ptr a) | 0 <= (plen v)}
+ -> (GHC.Types.IO {v:a | v = (deref p)})
+
+Foreign.Storable.peekByteOff :: (Foreign.Storable.Storable a)
+ => forall b. p:(GHC.Ptr.Ptr b)
+ -> {v:GHC.Types.Int | (PValid p v)}
+ -> (GHC.Types.IO a)
+
+Foreign.Storable.pokeByteOff :: (Foreign.Storable.Storable a)
+ => forall b. p:(GHC.Ptr.Ptr b)
+ -> {v:GHC.Types.Int | (PValid p v)}
+ -> a
+ -> GHC.Types.IO ()
+
+
diff --git a/include/GHC/Base.hquals b/include/GHC/Base.hquals
new file mode 100644
--- /dev/null
+++ b/include/GHC/Base.hquals
@@ -0,0 +1,11 @@
+//qualif NonNull(v: [a]) : (? (nonnull([v])))
+//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)
diff --git a/include/GHC/Base.spec b/include/GHC/Base.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Base.spec
@@ -0,0 +1,33 @@
+module spec GHC.Base where
+
+import GHC.Prim
+import GHC.Classes
+import GHC.Types
+import GHC.Err
+
+embed GHC.Types.Int as int
+embed Prop as bool
+
+measure Prop :: GHC.Types.Bool -> Prop
+
+measure len :: forall a. [a] -> GHC.Types.Int
+len ([]) = 0
+len (y:ys) = 1 + (len ys)
+
+measure null :: forall a. [a] -> Prop
+null ([]) = true
+null (x:xs) = false
+
+measure fst :: (a,b) -> a
+fst (a,b) = a
+
+measure snd :: (a,b) -> b
+snd (a,b) = b
+
+invariant {v: [a] | len(v) >= 0 }
+assume map :: (x:a -> b) -> xs:[a] -> {v: [b] | len(v) = len(xs)}
+
+assume $ :: (x:a -> b) -> a -> b
+assume id :: x:a -> {v:a | v = x}
+
+
diff --git a/include/GHC/Classes.spec b/include/GHC/Classes.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Classes.spec
@@ -0,0 +1,29 @@
+module spec GHC.Classes where
+
+import GHC.Types
+
+not :: x:GHC.Types.Bool -> {v:GHC.Types.Bool | (Prop(v) <=> ~Prop(x))}
+(&&) :: x:GHC.Types.Bool -> y:GHC.Types.Bool
+ -> {v:GHC.Types.Bool | (Prop(v) <=> (Prop(x) && Prop(y)))}
+(||) :: x:GHC.Types.Bool -> y:GHC.Types.Bool
+ -> {v:GHC.Types.Bool | (Prop(v) <=> (Prop(x) || Prop(y)))}
+(==) :: (GHC.Classes.Eq a) => x:a -> y:a
+ -> {v:GHC.Types.Bool | (Prop(v) <=> x = y)}
+(/=) :: (GHC.Classes.Eq a) => x:a -> y:a
+ -> {v:GHC.Types.Bool | (Prop(v) <=> x != y)}
+(>) :: (GHC.Classes.Ord a) => x:a -> y:a
+ -> {v:GHC.Types.Bool | (Prop(v) <=> x > y)}
+(>=) :: (GHC.Classes.Ord a) => x:a -> y:a
+ -> {v:GHC.Types.Bool | (Prop(v) <=> x >= y)}
+(<) :: (GHC.Classes.Ord a) => x:a -> y:a
+ -> {v:GHC.Types.Bool | (Prop(v) <=> x < y)}
+(<=) :: (GHC.Classes.Ord a) => x:a -> y:a
+ -> {v:GHC.Types.Bool | (Prop(v) <=> x <= y)}
+
+compare :: (GHC.Classes.Ord a) => x:a -> y:a
+ -> {v:GHC.Types.Ordering | (((v = GHC.Types.EQ) <=> (x = y)) &&
+ ((v = GHC.Types.LT) <=> (x < y)) &&
+ ((v = GHC.Types.GT) <=> (x > y))) }
+
+max :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = ((x > y) ? x : y) }
+min :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = ((x < y) ? x : y) }
diff --git a/include/GHC/ForeignPtr.spec b/include/GHC/ForeignPtr.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/ForeignPtr.spec
@@ -0,0 +1,4 @@
+module spec GHC.ForeignPtr where
+
+mallocPlainForeignPtrBytes :: n:{v:GHC.Types.Int | v >= 0 } -> (GHC.Types.IO (ForeignPtrN a n))
+
diff --git a/include/GHC/IO/Handle.spec b/include/GHC/IO/Handle.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/IO/Handle.spec
@@ -0,0 +1,10 @@
+module spec GHC.IO.Handle where
+
+hGetBuf :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat
+ -> (GHC.Types.IO {v:Nat | v <= n})
+
+hGetBufNonBlocking :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat
+ -> (GHC.Types.IO {v:Nat | v <= n})
+
+hFileSize :: GHC.IO.Handle.Handle
+ -> (GHC.Types.IO {v:GHC.Integer.Type.Integer | v >= 0})
diff --git a/include/GHC/Int.spec b/include/GHC/Int.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Int.spec
@@ -0,0 +1,6 @@
+module spec GHC.Int where
+
+embed GHC.Int.Int32 as int
+embed GHC.Int.Int64 as int
+
+type Nat64 = {v:GHC.Int.Int64 | v >= 0}
diff --git a/include/GHC/List.lhs b/include/GHC/List.lhs
new file mode 100644
--- /dev/null
+++ b/include/GHC/List.lhs
@@ -0,0 +1,790 @@
+\begin{code}
+
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.List
+-- Copyright : (c) The University of Glasgow 1994-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- The List data type and its operations
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC.List (
+ -- [] (..), -- Not Haskell 98; built in syntax
+
+ map, (++), filter, concat,
+ head, last, tail, init, null, length, (!!),
+ foldl, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+ iterate, repeat, replicate, cycle,
+ take, drop, splitAt, takeWhile, dropWhile, span, break,
+ reverse, and, or,
+ any, all, elem, notElem, lookup,
+ concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3,
+ errorEmptyList,
+
+#ifndef USE_REPORT_PRELUDE
+ -- non-standard, but hidden when creating the Prelude
+ -- export list.
+ takeUInt_append
+#endif
+
+ ) where
+
+import Data.Maybe
+import GHC.Base
+import Language.Haskell.Liquid.Prelude (liquidAssert, liquidError)
+
+infixl 9 !!
+infix 4 `elem`, `notElem`
+
+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{List-manipulation functions}
+%* *
+%*********************************************************
+
+\begin{code}
+-- | Extract the first element of a list, which must be non-empty.
+{-@ assert head :: xs:{v: [a] | len(v) > 0} -> a @-}
+head :: [a] -> a
+head (x:_) = x
+head [] = errorEmptyList "head"
+
+badHead :: a
+badHead = error "errorEmptyList head" -- errorEmptyList "head"
+
+-- This rule is useful in cases like
+-- head [y | (x,y) <- ps, x==t]
+{-# RULES
+"head/build" forall (g::forall b.(a->b->b)->b->b) .
+ head (build g) = g (\x _ -> x) badHead
+"head/augment" forall xs (g::forall b. (a->b->b) -> b -> b) .
+ head (augment g xs) = g (\x _ -> x) (head xs)
+ #-}
+
+-- | Extract the elements after the head of a list, which must be non-empty.
+{-@ assert tail :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = (len(xs) - 1)} @-}
+tail :: [a] -> [a]
+tail (_:xs) = xs
+tail [] = liquidError "tail" -- errorEmptyList "tail"
+
+-- | Extract the last element of a list, which must be finite and non-empty.
+{-@ assert last :: xs:{v: [a] | len(v) > 0} -> a @-}
+last :: [a] -> a
+#ifdef USE_REPORT_PRELUDE
+last [x] = x
+last (_:xs) = last xs
+last [] = liquidError "last" -- errorEmptyList "last"
+#else
+-- eliminate repeated cases
+last [] = liquidError "last" -- errorEmptyList "last"
+last (x:xs) = last' x xs
+ where last' y [] = y
+ last' _ (y:ys) = last' y ys
+#endif
+
+-- | Return all the elements of a list except the last one.
+-- The list must be non-empty.
+{-@ assert init :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) - 1} @-}
+init :: [a] -> [a]
+#ifdef USE_REPORT_PRELUDE
+init [x] = []
+init (x:xs) = x : init xs
+init [] = liquidError "init" -- errorEmptyList "init"
+#else
+-- eliminate repeated cases
+init [] = liquidError "init" --errorEmptyList "init"
+init (x:xs) = init' x xs
+ where init' _ [] = []
+ init' y (z:zs) = y : init' z zs
+#endif
+
+-- | Test whether a list is empty.
+{-@ assert null :: xs:[a] -> {v: Bool | (Prop(v) <=> len(xs) = 0) } @-}
+null :: [a] -> Bool
+null [] = True
+null (_:_) = False
+
+-- | /O(n)/. 'length' returns the length of a finite list as an 'Int'.
+-- It is an instance of the more general 'Data.List.genericLength',
+-- the result type of which may be any kind of number.
+{-@ assert length :: xs:[a] -> {v: GHC.Types.Int | v = len(xs)} @-}
+length :: [a] -> Int
+length l = len l 0#
+ where
+ --LIQUID FIXME: leaving the type signature causes this to compile to very strange core
+ --LIQUID len :: [a] -> Int# -> Int
+ len [] a# = I# a#
+ len (_:xs) a# = len xs (a# +# 1#)
+
+-- | 'filter', applied to a predicate and a list, returns the list of
+-- those elements that satisfy the predicate; i.e.,
+--
+-- > filter p xs = [ x | x <- xs, p x]
+
+{-@ assert filter :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} @-}
+filter :: (a -> Bool) -> [a] -> [a]
+filter _pred [] = []
+filter pred (x:xs)
+ | pred x = x : filter pred xs
+ | otherwise = filter pred xs
+
+{-# NOINLINE [0] filterFB #-}
+filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b
+filterFB c p x r | p x = x `c` r
+ | otherwise = r
+
+{-# RULES
+"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs)
+"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p
+"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
+ #-}
+
+-- Note the filterFB rule, which has p and q the "wrong way round" in the RHS.
+-- filterFB (filterFB c p) q a b
+-- = if q a then filterFB c p a b else b
+-- = if q a then (if p a then c a b else b) else b
+-- = if q a && p a then c a b else b
+-- = filterFB c (\x -> q x && p x) a b
+-- I originally wrote (\x -> p x && q x), which is wrong, and actually
+-- gave rise to a live bug report. SLPJ.
+
+
+-- | 'foldl', applied to a binary operator, a starting value (typically
+-- the left-identity of the operator), and a list, reduces the list
+-- using the binary operator, from left to right:
+--
+-- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
+--
+-- The list must be finite.
+
+-- We write foldl as a non-recursive thing, so that it
+-- can be inlined, and then (often) strictness-analysed,
+-- and hence the classic space leak on foldl (+) 0 xs
+
+foldl :: (a -> b -> a) -> a -> [b] -> a
+foldl f z0 xs0 = lgo z0 xs0
+ where
+ --LIQUID FIXME: lgo takes 5 parameters once compiled to core
+ {-@ Decrease lgo 5 @-}
+ lgo z [] = z
+ lgo z (x:xs) = lgo (f z x) xs
+
+-- | 'scanl' is similar to 'foldl', but returns a list of successive
+-- reduced values from the left:
+--
+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
+--
+-- Note that
+--
+-- > last (scanl f z xs) == foldl f z xs.
+{-@ assert scanl :: (a -> b -> a) -> a -> xs:[b] -> {v: [a] | len(v) = 1 + len(xs) } @-}
+scanl :: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q ls = q : (case ls of
+ [] -> []
+ x:xs -> scanl f (f q x) xs)
+
+-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
+--
+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+
+{-@ assert scanl1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) } @-}
+scanl1 :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs) = scanl f x xs
+scanl1 _ [] = []
+
+-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
+-- above functions.
+
+-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
+-- and thus must be applied to non-empty lists.
+
+{-@ assert foldr1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> a @-}
+foldr1 :: (a -> a -> a) -> [a] -> a
+foldr1 _ [x] = x
+foldr1 f (x:xs@(_:_)) = f x (foldr1 f xs)
+foldr1 _ [] = liquidError "foldr1" -- errorEmptyList "foldr1"
+
+-- | 'scanr' is the right-to-left dual of 'scanl'.
+-- Note that
+--
+-- > head (scanr f z xs) == foldr f z xs.
+
+{-@ assert scanr :: (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len(v) = 1 + len(xs) } @-}
+scanr :: (a -> b -> b) -> b -> [a] -> [b]
+scanr _ q0 [] = [q0]
+scanr f q0 (x:xs) = f x q : qs
+ where qs@(q:_) = scanr f q0 xs
+
+-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
+
+{-@ assert scanr1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) } @-}
+scanr1 :: (a -> a -> a) -> [a] -> [a]
+scanr1 _ [] = []
+scanr1 _ [x] = [x]
+scanr1 f (x:xs@(_:_)) = f x q : qs
+ where qs@(q:_) = scanr1 f xs
+
+-- | 'iterate' @f x@ returns an infinite list of repeated applications
+-- of @f@ to @x@:
+--
+-- > iterate f x == [x, f x, f (f x), ...]
+
+{-@ Strict GHC.List.iterate @-}
+iterate :: (a -> a) -> a -> [a]
+iterate f x = x : iterate f (f x)
+
+{-@ Strict GHC.List.iterateFB @-}
+iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b
+iterateFB c f x = x `c` iterateFB c f (f x)
+
+
+{-# RULES
+"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+"iterateFB" [1] iterateFB (:) = iterate
+ #-}
+
+
+-- | 'repeat' @x@ is an infinite list, with @x@ the value of every element.
+{-@ Strict GHC.List.repeat @-}
+repeat :: a -> [a]
+{-# INLINE [0] repeat #-}
+-- The pragma just gives the rules more chance to fire
+repeat x = xs where xs = x : xs
+
+{-# INLINE [0] repeatFB #-} -- ditto
+{-@ Strict GHC.List.repeatFB @-}
+repeatFB :: (a -> b -> b) -> a -> b
+repeatFB c x = xs where xs = x `c` xs
+
+
+{-# RULES
+"repeat" [~1] forall x. repeat x = build (\c _n -> repeatFB c x)
+"repeatFB" [1] repeatFB (:) = repeat
+ #-}
+
+-- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of
+-- every element.
+-- It is an instance of the more general 'Data.List.genericReplicate',
+-- in which @n@ may be of any integral type.
+{-# INLINE replicate #-}
+{-@ assert replicate :: n:GHC.Types.Int -> x:a -> {v: [{v:a | v = x}] | len(v) = n} @-}
+replicate :: Int -> a -> [a]
+replicate n x = take n (repeat x)
+
+-- | 'cycle' ties a finite list into a circular one, or equivalently,
+-- the infinite repetition of the original list. It is the identity
+-- on infinite lists.
+
+{-@ assert cycle :: {v: [a] | len(v) > 0 } -> [a] @-}
+{-@ Strict GHC.List.cycle @-}
+cycle :: [a] -> [a]
+cycle [] = liquidError {- error -} "Prelude.cycle: empty list"
+cycle xs = xs' where xs' = xs ++ xs'
+
+-- | 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the
+-- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@:
+--
+-- > takeWhile (< 3) [1,2,3,4,1,2,3,4] == [1,2]
+-- > takeWhile (< 9) [1,2,3] == [1,2,3]
+-- > takeWhile (< 0) [1,2,3] == []
+--
+
+{-@ assert takeWhile :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} @-}
+takeWhile :: (a -> Bool) -> [a] -> [a]
+takeWhile _ [] = []
+takeWhile p (x:xs)
+ | p x = x : takeWhile p xs
+ | otherwise = []
+
+-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@:
+--
+-- > dropWhile (< 3) [1,2,3,4,5,1,2,3] == [3,4,5,1,2,3]
+-- > dropWhile (< 9) [1,2,3] == []
+-- > dropWhile (< 0) [1,2,3] == [1,2,3]
+--
+
+{-@ assert dropWhile :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} @-}
+dropWhile :: (a -> Bool) -> [a] -> [a]
+dropWhile _ [] = []
+dropWhile p xs@(x:xs')
+ | p x = dropWhile p xs'
+ | otherwise = xs
+
+-- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@
+-- of length @n@, or @xs@ itself if @n > 'length' xs@:
+--
+-- > take 5 "Hello World!" == "Hello"
+-- > take 3 [1,2,3,4,5] == [1,2,3]
+-- > take 3 [1,2] == [1,2]
+-- > take 3 [] == []
+-- > take (-1) [1,2] == []
+-- > take 0 [1,2] == []
+--
+-- It is an instance of the more general 'Data.List.genericTake',
+-- in which @n@ may be of any integral type.
+
+
+{-@ assert take :: n: {v: Int | v >= 0 } -> xs:[a] -> {v:[a] | len(v) = ((len(xs) < n) ? len(xs) : n) } @-}
+take :: Int -> [a] -> [a]
+
+-- | 'drop' @n xs@ returns the suffix of @xs@
+-- after the first @n@ elements, or @[]@ if @n > 'length' xs@:
+--
+-- > drop 6 "Hello World!" == "World!"
+-- > drop 3 [1,2,3,4,5] == [4,5]
+-- > drop 3 [1,2] == []
+-- > drop 3 [] == []
+-- > drop (-1) [1,2] == [1,2]
+-- > drop 0 [1,2] == [1,2]
+--
+-- It is an instance of the more general 'Data.List.genericDrop',
+-- in which @n@ may be of any integral type.
+{-@ assert drop :: n: {v: Int | v >= 0 } -> xs:[a] -> {v:[a] | len(v) = ((len(xs) < n) ? 0 : len(xs) - n) } @-}
+drop :: Int -> [a] -> [a]
+
+-- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of
+-- length @n@ and second element is the remainder of the list:
+--
+-- > splitAt 6 "Hello World!" == ("Hello ","World!")
+-- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5])
+-- > splitAt 1 [1,2,3] == ([1],[2,3])
+-- > splitAt 3 [1,2,3] == ([1,2,3],[])
+-- > splitAt 4 [1,2,3] == ([1,2,3],[])
+-- > splitAt 0 [1,2,3] == ([],[1,2,3])
+-- > splitAt (-1) [1,2,3] == ([],[1,2,3])
+--
+-- It is equivalent to @('take' n xs, 'drop' n xs)@ when @n@ is not @_|_@
+-- (@splitAt _|_ xs = _|_@).
+-- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt',
+-- in which @n@ may be of any integral type.
+-- Liquid: TODO
+splitAt :: Int -> [a] -> ([a],[a])
+
+#ifdef USE_REPORT_PRELUDE
+take n _ | n <= 0 = []
+take _ [] = []
+take n (x:xs) = x : take (n-1) xs
+
+drop n xs | n <= 0 = xs
+drop _ [] = []
+drop n (_:xs) = drop (n-1) xs
+
+splitAt n xs = (take n xs, drop n xs)
+
+#else /* hack away */
+{-# RULES
+"take" [~1] forall n xs . take n xs = takeFoldr n xs
+"takeList" [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs
+ #-}
+
+{-# INLINE takeFoldr #-}
+takeFoldr :: Int -> [a] -> [a]
+takeFoldr (I# n#) xs
+ = build (\c nil -> if n# <=# 0# then nil else
+ foldr (takeFB c nil) (takeConst nil) xs n#)
+
+{-# NOINLINE [0] takeConst #-}
+-- just a version of const that doesn't get inlined too early, so we
+-- can spot it in rules. Also we need a type sig due to the unboxed Int#.
+takeConst :: a -> Int# -> a
+takeConst x _ = x
+
+{-# NOINLINE [0] takeFB #-}
+takeFB :: (a -> b -> b) -> b -> a -> (Int# -> b) -> Int# -> b
+takeFB c n x xs m | m <=# 1# = x `c` n
+ | otherwise = x `c` xs (m -# 1#)
+
+{-- INLINE [0] take #-}
+take (I# n#) xs = takeUInt n# xs
+
+-- The general code for take, below, checks n <= maxInt
+-- No need to check for maxInt overflow when specialised
+-- at type Int or Int# since the Int must be <= maxInt
+
+takeUInt :: Int# -> [b] -> [b]
+takeUInt n xs
+ | n >=# 0# = take_unsafe_UInt n xs
+ | otherwise = liquidAssert False []
+
+take_unsafe_UInt :: Int# -> [b] -> [b]
+take_unsafe_UInt 0# _ = []
+take_unsafe_UInt m ls =
+ case ls of
+ [] -> []
+ (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs
+
+takeUInt_append :: Int# -> [b] -> [b] -> [b]
+takeUInt_append n xs rs
+ | n >=# 0# = take_unsafe_UInt_append n xs rs
+ | otherwise = []
+
+take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b]
+take_unsafe_UInt_append 0# _ rs = rs
+take_unsafe_UInt_append m ls rs =
+ case ls of
+ [] -> rs
+ (x:xs) -> x : take_unsafe_UInt_append (m -# 1#) xs rs
+
+drop (I# n#) ls
+ | n# <# 0# = ls
+ | otherwise = drop# n# ls
+ where
+ drop# :: Int# -> [a] -> [a]
+ drop# 0# xs = xs
+ drop# _ xs@[] = xs
+ drop# m# (_:xs) = drop# (m# -# 1#) xs
+
+splitAt (I# n#) ls
+ | n# <# 0# = ([], ls)
+ | otherwise = splitAt# n# ls
+ where
+ splitAt# :: Int# -> [a] -> ([a], [a])
+ splitAt# 0# xs = ([], xs)
+ splitAt# _ xs@[] = (xs, xs)
+ splitAt# m# (x:xs) = (x:xs', xs'')
+ where
+ (xs', xs'') = splitAt# (m# -# 1#) xs
+
+#endif /* USE_REPORT_PRELUDE */
+
+-- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where
+-- first element is longest prefix (possibly empty) of @xs@ of elements that
+-- satisfy @p@ and second element is the remainder of the list:
+--
+-- > span (< 3) [1,2,3,4,1,2,3,4] == ([1,2],[3,4,1,2,3,4])
+-- > span (< 9) [1,2,3] == ([1,2,3],[])
+-- > span (< 0) [1,2,3] == ([],[1,2,3])
+--
+-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@
+-- Liquid: TODO
+{-@
+span :: (a -> Bool)
+ -> xs:[a]
+ -> ({v:[a]|((len v)<=(len xs))}, {v:[a]|((len v)<=(len xs))})
+@-}
+span :: (a -> Bool) -> [a] -> ([a], [a])
+span _ xs@[] = (xs, xs)
+span p xs@(x:xs')
+ | p x = let (ys,zs) = span p xs' in (x:ys,zs)
+ | otherwise = ([],xs)
+
+-- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where
+-- first element is longest prefix (possibly empty) of @xs@ of elements that
+-- /do not satisfy/ @p@ and second element is the remainder of the list:
+--
+-- > break (> 3) [1,2,3,4,1,2,3,4] == ([1,2,3],[4,1,2,3,4])
+-- > break (< 9) [1,2,3] == ([],[1,2,3])
+-- > break (> 9) [1,2,3] == ([1,2,3],[])
+--
+-- 'break' @p@ is equivalent to @'span' ('not' . p)@.
+-- liquid:TODO
+break :: (a -> Bool) -> [a] -> ([a],[a])
+#ifdef USE_REPORT_PRELUDE
+break p = span (not . p)
+#else
+-- HBC version (stolen)
+break _ xs@[] = (xs, xs)
+break p xs@(x:xs')
+ | p x = ([],xs)
+ | otherwise = let (ys,zs) = break p xs' in (x:ys,zs)
+#endif
+
+-- | 'reverse' @xs@ returns the elements of @xs@ in reverse order.
+-- @xs@ must be finite.
+{-@ assert reverse :: xs:[a] -> {v: [a] | len(v) = len(xs)} @-}
+{-@ include @-}
+reverse :: [a] -> [a]
+#ifdef USE_REPORT_PRELUDE
+reverse = foldl (flip (:)) []
+#else
+reverse l = rev l []
+ where
+ rev [] a = a
+ rev (x:xs) a = rev xs (x:a)
+#endif
+
+-- | 'and' returns the conjunction of a Boolean list. For the result to be
+-- 'True', the list must be finite; 'False', however, results from a 'False'
+-- value at a finite index of a finite or infinite list.
+and :: [Bool] -> Bool
+
+-- | 'or' returns the disjunction of a Boolean list. For the result to be
+-- 'False', the list must be finite; 'True', however, results from a 'True'
+-- value at a finite index of a finite or infinite list.
+or :: [Bool] -> Bool
+#ifdef USE_REPORT_PRELUDE
+and = foldr (&&) True
+or = foldr (||) False
+#else
+and [] = True
+and (x:xs) = x && and xs
+or [] = False
+or (x:xs) = x || or xs
+
+{-# RULES
+"and/build" forall (g::forall b.(Bool->b->b)->b->b) .
+ and (build g) = g (&&) True
+"or/build" forall (g::forall b.(Bool->b->b)->b->b) .
+ or (build g) = g (||) False
+ #-}
+#endif
+
+-- | Applied to a predicate and a list, 'any' determines if any element
+-- of the list satisfies the predicate. For the result to be
+-- 'False', the list must be finite; 'True', however, results from a 'True'
+-- value for the predicate applied to an element at a finite index of a finite or infinite list.
+any :: (a -> Bool) -> [a] -> Bool
+
+-- | Applied to a predicate and a list, 'all' determines if all elements
+-- of the list satisfy the predicate. For the result to be
+-- 'True', the list must be finite; 'False', however, results from a 'False'
+-- value for the predicate applied to an element at a finite index of a finite or infinite list.
+all :: (a -> Bool) -> [a] -> Bool
+#ifdef USE_REPORT_PRELUDE
+any p = or . map p
+all p = and . map p
+#else
+any _ [] = False
+any p (x:xs) = p x || any p xs
+
+all _ [] = True
+all p (x:xs) = p x && all p xs
+{-# RULES
+"any/build" forall p (g::forall b.(a->b->b)->b->b) .
+ any p (build g) = g ((||) . p) False
+"all/build" forall p (g::forall b.(a->b->b)->b->b) .
+ all p (build g) = g ((&&) . p) True
+ #-}
+#endif
+
+-- | 'elem' is the list membership predicate, usually written in infix form,
+-- e.g., @x \`elem\` xs@. For the result to be
+-- 'False', the list must be finite; 'True', however, results from an element equal to @x@ found at a finite index of a finite or infinite list.
+elem :: (Eq a) => a -> [a] -> Bool
+
+-- | 'notElem' is the negation of 'elem'.
+notElem :: (Eq a) => a -> [a] -> Bool
+#ifdef USE_REPORT_PRELUDE
+elem x = any (== x)
+notElem x = all (/= x)
+#else
+elem _ [] = False
+elem x (y:ys) = x==y || elem x ys
+
+notElem _ [] = True
+notElem x (y:ys)= x /= y && notElem x ys
+#endif
+
+-- | 'lookup' @key assocs@ looks up a key in an association list.
+lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
+lookup _key [] = Nothing
+lookup key ((x,y):xys)
+ | key == x = Just y
+ | otherwise = lookup key xys
+
+-- | Map a function over a list and concatenate the results.
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = foldr ((++) . f) []
+
+-- | Concatenate a list of lists.
+concat :: [[a]] -> [a]
+concat = foldr (++) []
+
+{-# RULES
+ "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs)
+-- We don't bother to turn non-fusible applications of concat back into concat
+ #-}
+
+\end{code}
+
+
+\begin{code}
+-- | List index (subscript) operator, starting from 0.
+-- It is an instance of the more general 'Data.List.genericIndex',
+-- which takes an index of any integral type.
+
+{-@ assert GHC.List.!! :: xs:[a] -> {v: Int | ((0 <= v) && (v < len(xs)))} -> a @-}
+(!!) :: [a] -> Int -> a
+#ifdef USE_REPORT_PRELUDE
+xs !! n | n < 0 = liquidError {- error -} "Prelude.!!: negative index"
+[] !! _ = liquidError {- error -} "Prelude.!!: index too large"
+(x:_) !! 0 = x
+(_:xs) !! n = xs !! (n-1)
+#else
+-- HBC version (stolen), then unboxified
+-- The semantics is not quite the same for error conditions
+-- in the more efficient version.
+--
+xs !! (I# n0) | n0 <# 0# = liquidError {- error -} "Prelude.(!!): negative index\n"
+ | otherwise = sub xs n0
+ where
+ sub :: [a] -> Int# -> a
+ sub [] _ = liquidError {- error -} "Prelude.(!!): index too large\n"
+ sub (y:ys) n = if n ==# 0#
+ then y
+ else sub ys (n -# 1#)
+#endif
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The zip family}
+%* *
+%*********************************************************
+
+\begin{code}
+foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c
+foldr2 _k z [] _ys = z
+foldr2 _k z _xs [] = z
+foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys)
+
+foldr2_left :: (a -> b -> c -> d) -> d -> a -> ([b] -> c) -> [b] -> d
+foldr2_left _k z _x _r [] = z
+foldr2_left k _z x r (y:ys) = k x y (r ys)
+
+foldr2_right :: (a -> b -> c -> d) -> d -> b -> ([a] -> c) -> [a] -> d
+foldr2_right _k z _y _r [] = z
+foldr2_right k _z y r (x:xs) = k x y (r xs)
+
+-- foldr2 k z xs ys = foldr (foldr2_left k z) (\_ -> z) xs ys
+-- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs
+{-# RULES
+"foldr2/left" forall k z ys (g::forall b.(a->b->b)->b->b) .
+ foldr2 k z (build g) ys = g (foldr2_left k z) (\_ -> z) ys
+
+"foldr2/right" forall k z xs (g::forall b.(a->b->b)->b->b) .
+ foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs
+ #-}
+\end{code}
+
+The foldr2/right rule isn't exactly right, because it changes
+the strictness of foldr2 (and thereby zip)
+
+E.g. main = print (null (zip nonobviousNil (build undefined)))
+ where nonobviousNil = f 3
+ f n = if n == 0 then [] else f (n-1)
+
+I'm going to leave it though.
+
+
+Zips for larger tuples are in the List module.
+
+\begin{code}
+----------------------------------------------
+-- | 'zip' takes two lists and returns a list of corresponding pairs.
+-- If one input list is short, excess elements of the longer list are
+-- discarded.
+zip :: [a] -> [b] -> [(a,b)]
+zip (a:as) (b:bs) = (a,b) : zip as bs
+zip _ _ = []
+
+{-# INLINE [0] zipFB #-}
+zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d
+zipFB c = \x y r -> (x,y) `c` r
+
+{-# RULES
+"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
+"zipList" [1] foldr2 (zipFB (:)) [] = zip
+ #-}
+\end{code}
+
+\begin{code}
+----------------------------------------------
+-- | 'zip3' takes three lists and returns a list of triples, analogous to
+-- 'zip'.
+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
+-- Specification
+-- zip3 = zipWith3 (,,)
+zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs
+zip3 _ _ _ = []
+\end{code}
+
+
+-- The zipWith family generalises the zip family by zipping with the
+-- function given as the first argument, instead of a tupling function.
+
+\begin{code}
+----------------------------------------------
+-- | 'zipWith' generalises 'zip' by zipping with the function given
+-- as the first argument, instead of a tupling function.
+-- For example, @'zipWith' (+)@ is applied to two lists to produce the
+-- list of corresponding sums.
+
+
+{-@ zipWith :: (a -> b -> c)
+ -> xs : [a] -> ys:[b]
+ -> {v : [c] | (((len v) <= (len xs)) && ((len v) <= (len ys)))} @-}
+zipWith :: (a->b->c) -> [a]->[b]->[c]
+zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
+zipWith _ _ _ = []
+
+-- zipWithFB must have arity 2 since it gets two arguments in the "zipWith"
+-- rule; it might not get inlined otherwise
+{-# INLINE [0] zipWithFB #-}
+zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c
+zipWithFB c f = \x y r -> (x `f` y) `c` r
+
+{-# RULES
+"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
+"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f
+ #-}
+\end{code}
+
+\begin{code}
+-- | The 'zipWith3' function takes a function which combines three
+-- elements, as well as three lists and returns a list of their point-wise
+-- combination, analogous to 'zipWith'.
+zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith3 z (a:as) (b:bs) (c:cs)
+ = z a b c : zipWith3 z as bs cs
+zipWith3 _ _ _ _ = []
+
+-- | 'unzip' transforms a list of pairs into a list of first components
+-- and a list of second components.
+unzip :: [(a,b)] -> ([a],[b])
+{-# INLINE unzip #-}
+unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
+
+-- | The 'unzip3' function takes a list of triples and returns three
+-- lists, analogous to 'unzip'.
+unzip3 :: [(a,b,c)] -> ([a],[b],[c])
+{-# INLINE unzip3 #-}
+unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
+ ([],[],[])
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Error code}
+%* *
+%*********************************************************
+
+Common up near identical calls to `error' to reduce the number
+constant strings created when compiled:
+
+\begin{code}
+{-@ assert errorEmptyList :: {v: String | (0 = 1)} -> a @-}
+errorEmptyList :: String -> a
+errorEmptyList fun =
+ liquidError {- error -} (prel_list_str ++ fun ++ ": empty list")
+
+prel_list_str :: String
+prel_list_str = "Prelude."
+\end{code}
diff --git a/include/GHC/Num.spec b/include/GHC/Num.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Num.spec
@@ -0,0 +1,9 @@
+module spec GHC.Num where
+
+GHC.Num.fromInteger :: (GHC.Num.Num a)
+ => x:GHC.Integer.Type.Integer
+ -> {v:a | v = x }
+
+-- GHC.Num.negate :: (GHC.Num.Num a)
+-- => x:a
+-- -> {v:a | v = (0-x)}
diff --git a/include/GHC/Prim.spec b/include/GHC/Prim.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Prim.spec
@@ -0,0 +1,16 @@
+module spec GHC.Prim where
+
+embed GHC.Prim.Int# as int
+embed GHC.Prim.Addr# as int
+
+measure addrLen :: GHC.Prim.Addr# -> GHC.Types.Int
+
+assume GHC.Types.I# :: x:GHC.Prim.Int# -> {v: GHC.Types.Int | v = (x :: int) }
+assume GHC.Prim.+# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}
+assume GHC.Prim.-# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x - y}
+assume GHC.Prim.==# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x = y)}
+assume GHC.Prim.>=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x >= y)}
+assume GHC.Prim.<=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x <= y)}
+assume GHC.Prim.<# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x < y)}
+assume GHC.Prim.># :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x > y)}
+
diff --git a/include/GHC/Ptr.spec b/include/GHC/Ptr.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Ptr.spec
@@ -0,0 +1,14 @@
+module spec GHC.Ptr where
+
+GHC.Ptr.castPtr :: p:(PtrV a) -> (PtrN b (plen p))
+
+GHC.Ptr.plusPtr :: base:(PtrV a)
+ -> off:{v:GHC.Types.Int | v <= (plen base) }
+ -> {v:(PtrV b) | (((pbase v) = (pbase base)) && ((plen v) = (plen base) - off))}
+
+GHC.Ptr.minusPtr :: q:(PtrV a)
+ -> p:{v:(PtrV b) | (((pbase v) = (pbase q)) && ((plen v) >= (plen q)))}
+ -> {v:Nat | v = (plen p) - (plen q)}
+
+measure deref :: GHC.Ptr.Ptr a -> a
+
diff --git a/include/GHC/Real.spec b/include/GHC/Real.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Real.spec
@@ -0,0 +1,13 @@
+module spec GHC.Real where
+
+GHC.Real.div :: (GHC.Real.Integral a) => x:a -> y:a -> {v:a | ((v = (x / y)) && (((x>=0) && (y>=0)) => (v>=0)) && (((x>=0) && (y>=1)) => (v<=x))) }
+GHC.Real.quotRem :: (GHC.Real.Integral a) => x:a -> y:a -> ({v:a | ((v = (x / y)) && (((x>=0) && (y>=0)) => (v>=0)) && (((x>=0) && (y>=1)) => (v<=x)))}
+ ,{v:a | ((v >= 0) && (v < y))})
+
+-- fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here
+-- GHC.Real.mod :: (Integral a) => x:a -> y:a -> {v:a | v = (x mod y) }
+GHC.Real./ :: (GHC.Real.Fractional a) => x:a -> y:{v:a | v != 0} -> {v: a | v = (x / y) }
+
+GHC.Real.toInteger :: (GHC.Real.Integral a) => x:a -> {v:GHC.Integer.Type.Integer | v = x}
+GHC.Real.fromIntegral :: (GHC.Real.Integral a, GHC.Num.Num b) => x:a -> {v:b|v=x}
+
diff --git a/include/GHC/Types.spec b/include/GHC/Types.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Types.spec
@@ -0,0 +1,23 @@
+module spec GHC.Types where
+
+-- 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) }
+
+measure cmp :: GHC.Types.Ordering -> GHC.Types.Ordering
+cmp (GHC.Types.EQ) = { v | v = GHC.Types.EQ }
+cmp (GHC.Types.LT) = { v | v = GHC.Types.LT }
+cmp (GHC.Types.GT) = { v | v = GHC.Types.GT }
+
+
+GHC.Types.True :: {v:GHC.Types.Bool | (Prop(v))}
+GHC.Types.False :: {v:GHC.Types.Bool | (~ (Prop(v)))}
+
+embed GHC.Types.Double as int
+
+
+
+
+
+
diff --git a/include/GHC/Word.spec b/include/GHC/Word.spec
new file mode 100644
--- /dev/null
+++ b/include/GHC/Word.spec
@@ -0,0 +1,7 @@
+module spec GHC.Word where
+
+embed GHC.Word.Word as int
+embed GHC.Word.Word8 as int
+embed GHC.Word.Word16 as int
+embed GHC.Word.Word32 as int
+embed GHC.Word.Word64 as int
diff --git a/include/KMeansHelper.hs b/include/KMeansHelper.hs
new file mode 100644
--- /dev/null
+++ b/include/KMeansHelper.hs
@@ -0,0 +1,78 @@
+module KMeansHelper where
+
+import Prelude hiding (zipWith)
+import Data.List (sort, span, minimumBy)
+import Data.Function (on)
+import Data.Ord (comparing)
+import Language.Haskell.Liquid.Prelude (liquidAssert, liquidError)
+
+
+-- | Fixed-Length Lists
+
+{-@ type List a N = {v : [a] | (len v) = N} @-}
+
+
+-- | N Dimensional Points
+
+{-@ type Point N = List Double N @-}
+
+{-@ type NonEmptyList a = {v : [a] | (len v) > 0} @-}
+
+-- | Clustering
+
+{-@ type Clustering a = [(NonEmptyList a)] @-}
+
+------------------------------------------------------------------
+-- | Grouping By a Predicate -------------------------------------
+------------------------------------------------------------------
+
+{-@ groupBy :: (a -> a -> Bool) -> [a] -> (Clustering a) @-}
+groupBy _ [] = []
+groupBy eq (x:xs) = (x:ys) : groupBy eq zs
+ where (ys,zs) = span (eq x) xs
+
+------------------------------------------------------------------
+-- | Partitioning By a Size --------------------------------------
+------------------------------------------------------------------
+
+{-@ type PosInt = {v: Int | v > 0 } @-}
+
+{-@ partition :: size:PosInt -> [a] -> (Clustering a) @-}
+
+partition size [] = []
+partition size ys@(_:_) = zs : partition size zs'
+ where
+ zs = take size ys
+ zs' = drop size ys
+
+-----------------------------------------------------------------------
+-- | Safe Zipping -----------------------------------------------------
+-----------------------------------------------------------------------
+
+{-@ zipWith :: (a -> b -> c) -> xs:[a] -> (List b (len xs)) -> (List c (len xs)) @-}
+zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
+zipWith _ [] [] = []
+
+-- Other cases only for exposition
+zipWith _ (_:_) [] = liquidError "Dead Code"
+zipWith _ [] (_:_) = liquidError "Dead Code"
+
+-----------------------------------------------------------------------
+-- | "Matrix" Transposition -------------------------------------------
+-----------------------------------------------------------------------
+
+{-@ type Matrix a Rows Cols = (List (List a Cols) Rows) @-}
+
+{-@ transpose :: c:Int -> r:PosInt -> Matrix a r c -> Matrix a c r @-}
+
+transpose :: Int -> Int -> [[a]] -> [[a]]
+transpose 0 _ _ = []
+transpose c r ((x:xs) : xss) = (x : map head xss) : transpose (c-1) r (xs : map tail xss)
+
+-- Or, with comprehensions
+-- transpose c r ((x:xs):xss) = (x : [ xs' | (x':_) <- xss ]) : transpose (c-1) r (xs : [xs' | (_ : xs') <- xss])
+
+-- Not needed, just for exposition
+transpose c r ([] : _) = liquidError "dead code"
+transpose c r [] = liquidError "dead code"
+
diff --git a/include/Language/Haskell/Liquid/List.hs b/include/Language/Haskell/Liquid/List.hs
new file mode 100644
--- /dev/null
+++ b/include/Language/Haskell/Liquid/List.hs
@@ -0,0 +1,11 @@
+module Language.Haskell.Liquid.List (transpose) where
+
+import Data.List hiding (transpose)
+
+{-# ANN transpose "forall a. n:Int -> xs:[{v:[a]|len(v) = n}] -> {v:[[a]] | len(v) = n}" #-}
+transpose :: Int -> [[a]] -> [[a]]
+transpose n [] = []
+transpose n ([] : xss) = transpose n xss
+transpose n ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n - 1) (xs : [ t | (_:t) <- xss])
+
+
diff --git a/include/Language/Haskell/Liquid/Prelude.hs b/include/Language/Haskell/Liquid/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/include/Language/Haskell/Liquid/Prelude.hs
@@ -0,0 +1,165 @@
+{-# LANGUAGE MagicHash #-}
+
+{- OPTIONS_GHC -cpp #-}
+{- OPTIONS_GHC -cpp -fglasgow-exts -}
+
+module Language.Haskell.Liquid.Prelude where
+
+import Foreign.C.Types (CSize(..))
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import GHC.Base
+
+-------------------------------------------------------------------
+--------------------------- Arithmetic ----------------------------
+-------------------------------------------------------------------
+
+{-@ assume plus :: x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y} @-}
+{-@ assume minus :: x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y} @-}
+{-@ assume times :: x:Int -> y:Int -> Int @-}
+{-@ assume eq :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x = y)} @-}
+{-@ assume neq :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x != y)} @-}
+{-@ assume leq :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x <= y)} @-}
+{-@ assume geq :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x >= y)} @-}
+{-@ assume lt :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x < y)} @-}
+{-@ assume gt :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x > y)} @-}
+
+{-# NOINLINE plus #-}
+plus :: Int -> Int -> Int
+plus x y = x + y
+
+{-# NOINLINE minus #-}
+minus :: Int -> Int -> Int
+minus x y = x - y
+
+{-# NOINLINE times #-}
+times :: Int -> Int -> Int
+times x y = x * y
+
+-------------------------------------------------------------------
+--------------------------- Comparisons ---------------------------
+-------------------------------------------------------------------
+
+{-# NOINLINE eq #-}
+eq :: Int -> Int -> Bool
+eq x y = x == y
+
+{-# NOINLINE neq #-}
+neq :: Int -> Int -> Bool
+neq x y = not (x == y)
+
+{-# NOINLINE leq #-}
+leq :: Int -> Int -> Bool
+leq x y = x <= y
+
+{-# NOINLINE geq #-}
+geq :: Int -> Int -> Bool
+geq x y = x >= y
+
+{-# NOINLINE lt #-}
+lt :: Int -> Int -> Bool
+lt x y = x < y
+
+{-# NOINLINE gt #-}
+gt :: Int -> Int -> Bool
+gt x y = x > y
+
+-------------------------------------------------------------------
+------------------------ Specifications ---------------------------
+-------------------------------------------------------------------
+
+{-@ assume liquidAssertB :: x:{v:Bool | (Prop v)} -> {v: Bool | (Prop v)} @-}
+{-# NOINLINE liquidAssertB #-}
+liquidAssertB :: Bool -> Bool
+liquidAssertB b = b
+
+{-@ assume liquidAssert :: {v:Bool | (Prop v)} -> a -> a @-}
+{-# NOINLINE liquidAssert #-}
+liquidAssert :: Bool -> a -> a
+liquidAssert b x = x
+
+{-@ assume liquidAssume :: b:Bool -> a -> {v: a | (Prop b)} @-}
+{-# NOINLINE liquidAssume #-}
+liquidAssume :: Bool -> a -> a
+liquidAssume b x = x
+
+
+
+{-@ assume liquidError :: {v: String | 0 = 1} -> a @-}
+{-# NOINLINE liquidError #-}
+liquidError :: String -> a
+liquidError = error
+
+{-@ assume crash :: forall a . x:{v:Bool | (Prop v)} -> a @-}
+{-# NOINLINE crash #-}
+crash :: Bool -> a
+crash b = undefined
+
+{-# NOINLINE force #-}
+force x = True
+
+{-# NOINLINE choose #-}
+choose :: Int -> Int
+choose x = undefined
+
+-------------------------------------------------------------------
+----------- Modular Arithmetic Wrappers ---------------------------
+-------------------------------------------------------------------
+
+-- tedium because fixpoint doesnt want to deal with (x mod y) only (x mod c)
+{-@ assume isEven :: x:Int -> {v:Bool | ((Prop v) <=> ((x mod 2) = 0))} @-}
+{-# NOINLINE isEven #-}
+isEven :: Int -> Bool
+isEven x = x `mod` 2 == 0
+
+{-@ assume isOdd :: x:Int -> {v:Bool | ((Prop v) <=> ((x mod 2) = 1))} @-}
+{-# NOINLINE isOdd #-}
+isOdd :: Int -> Bool
+isOdd x = x `mod` 2 == 1
+
+-----------------------------------------------------------------------------------------------
+
+{-# NOINLINE intCSize #-}
+{-@ assume intCSize :: x:Int -> {v: CSize | v = x } @-}
+intCSize :: Int -> CSize
+intCSize = fromIntegral
+
+{-# NOINLINE cSizeInt #-}
+{-@ assume cSizeInt :: x:CSize -> {v: Int | v = x } @-}
+cSizeInt :: CSize -> Int
+cSizeInt = fromIntegral
+
+
+{-@ assume mkPtr :: x:GHC.Prim.Addr# -> {v: (Ptr b) | ((plen v) = (addrLen x) && ((plen v) >= 0)) } @-}
+mkPtr :: Addr# -> Ptr b
+mkPtr x = undefined -- Ptr x
+
+
+{-@ isNullPtr :: p:(Ptr a) -> {v:Bool | ((Prop v) <=> (isNullPtr p)) } @-}
+isNullPtr :: Ptr a -> Bool
+isNullPtr p = (p == nullPtr)
+{-# INLINE isNullPtr #-}
+
+{-@ fpLen :: p:(ForeignPtr a) -> {v:Int | v = (fplen p) } @-}
+fpLen :: ForeignPtr a -> Int
+fpLen p = undefined
+
+{-@ pLen :: p:(Ptr a) -> {v:Int | v = (plen p) } @-}
+pLen :: Ptr a -> Int
+pLen p = undefined
+
+{-@ deref :: p:Ptr a -> {v:a | v = (deref p)} @-}
+deref :: Ptr a -> a
+deref = undefined
+
+{-@ eqPtr :: p:PtrV a
+ -> q:{v:PtrV a | (((pbase v) = (pbase p)) && ((plen v) <= (plen p)))}
+ -> {v:Bool | ((Prop v) <=> ((plen p) = (plen q)))}
+ @-}
+eqPtr :: Ptr a -> Ptr a -> Bool
+eqPtr = undefined
+
+{-@ assert safeZipWith :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len(v) = len(xs)} -> {v : [c] | len(v) = len(xs)} @-}
+safeZipWith :: (a->b->c) -> [a]->[b]->[c]
+safeZipWith f (a:as) (b:bs) = f a b : safeZipWith f as bs
+
diff --git a/include/Language/Haskell/Liquid/Prelude.pred b/include/Language/Haskell/Liquid/Prelude.pred
new file mode 100644
--- /dev/null
+++ b/include/Language/Haskell/Liquid/Prelude.pred
@@ -0,0 +1,22 @@
+assume (>) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
+assume (<) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
+assume (>=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
+assume (<=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
+assume (==) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
+assume (+) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True
+assume (*) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True
+assume (-) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True
+assume ($) :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> a^q1 -> b^q2
+assume (.) :: forall b c a. forAll q1:a q2:b q3:c. (b^q2 -> c^q3) -> (a^q1 -> b^q2) -> a^q1 -> c^q3
+assume filter :: forall a. forAll p1:a. (a^p1 -> Bool) -> [a^p1]-> [a^p1]
+assume snd :: forall a b. forAll p1:a p2:b. (a^p1, b^p2)-> b^p2
+assume map :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> [a^q1]-> [b^q2]
+assume (++) :: forall a. forAll q:a. [a^q]-> [a^q]-> [a^q]
+assume concat :: forall a. forAll q:a. [[a^q]]-> [a^q]
+assume foldl :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> a^q1) -> a^q1 -> [b^q2]-> a^q1
+assume foldr :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> b^q2) -> b^q2 -> [a^q1]-> b^q2
+assume (,) :: forall a b. forAll q1:a q2:b. a^q1 -> b^q2 ->(a^q1, b^q2)
+assume Prelude.error :: forall a. forAll q2:a. [Char]-> a^q2
+assume Prelude.head :: forall a. forAll q:a. [a^q]-> a^q
+assume Prelude.tail :: forall a. forAll q:a. [a^q]-> [a^q]
+assume Prelude.enumFromTo :: forall a. forAll q:a. (Enum a^ True) => a^q -> a^q -> [a^q]
diff --git a/include/PatErr.spec b/include/PatErr.spec
new file mode 100644
--- /dev/null
+++ b/include/PatErr.spec
@@ -0,0 +1,7 @@
+module spec Prelude where
+
+assume Control.Exception.Base.patError :: {v:GHC.Prim.Addr# | false } -> a
+assume Control.Exception.Base.irrefutPatError :: {v:GHC.Prim.Addr# | false} -> a
+assume Control.Exception.Base.recSelError :: {v:GHC.Prim.Addr# | false} -> a
+assume Control.Exception.Base.nonExhaustiveGuardsError :: {v:GHC.Prim.Addr# | false} -> a
+assume Control.Exception.Base.noMethodBindingError :: {v:GHC.Prim.Addr# | false} -> a
diff --git a/include/Prelude.hquals b/include/Prelude.hquals
new file mode 100644
--- /dev/null
+++ b/include/Prelude.hquals
@@ -0,0 +1,23 @@
+//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 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 Papp(v:a,~P:Pred a) : papp1(~P, v)
+constant papp1 : func(2, [Pred @(0); @(1); bool])
+
+qualif Papp2(v:a,~X:b,~P:Pred a b) : papp2(~P, v, ~X)
+constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool])
+
+constant Prop : func(0, [GHC.Types.Bool; bool])
diff --git a/include/Prelude.spec b/include/Prelude.spec
new file mode 100644
--- /dev/null
+++ b/include/Prelude.spec
@@ -0,0 +1,35 @@
+module spec Prelude where
+
+import GHC.Base
+import GHC.Int
+import GHC.List
+import GHC.Num
+import GHC.Real
+import GHC.Word
+
+import Data.Maybe
+
+assume GHC.Base.. :: forall< p :: xx:b -> c -> Prop
+ , q :: yy:a -> b -> Prop>.
+ f:(x:b -> c) ->
+ g:(y:a -> b) ->
+ x:a ->
+ exists[z:b].c
+assume GHC.Integer.smallInteger :: x:GHC.Prim.Int#
+ -> { v:GHC.Integer.Type.Integer |
+ v = (x :: int) }
+assume GHC.Num.+ :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x + y }
+assume GHC.Num.- :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x - y }
+assume GHC.Num.* :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | ((((x >= 0) && (y >= 0)) => ((v >= x) && (v >= y))) && (((x > 1) && (y > 1)) => ((v > x) && (v > y)))) }
+
+embed GHC.Integer.Type.Integer as int
+
+type GeInt N = {v: GHC.Types.Int | v >= N }
+type LeInt N = {v: GHC.Types.Int | v <= N }
+type Nat = {v: GHC.Types.Int | v >= 0 }
+type BNat N = {v: Nat | v <= N }
+
+predicate Max V X Y = ((X > Y) ? (V = X) : (V = Y))
+predicate Min V X Y = ((X < Y) ? (V = X) : (V = Y))
+
+type IncrListD a D = [a]<{\x y -> (x+D) <= y}>
diff --git a/include/System/IO.spec b/include/System/IO.spec
new file mode 100644
--- /dev/null
+++ b/include/System/IO.spec
@@ -0,0 +1,3 @@
+module spec System.IO where
+
+import GHC.IO.Handle
diff --git a/include/len.hquals b/include/len.hquals
new file mode 100644
--- /dev/null
+++ b/include/len.hquals
@@ -0,0 +1,5 @@
+
+//Qualifiers about complex length relationships
+
+qualif LenSum(v:[a], ~A:[b], ~B:[c]): len([v]) = (len([~A]) [ +; - ] len([~B]))
+
diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal
new file mode 100644
--- /dev/null
+++ b/liquidhaskell.cabal
@@ -0,0 +1,140 @@
+Name: liquidhaskell
+Version: 0.1
+Copyright: 2010-13 Ranjit Jhala, University of California, San Diego.
+build-type: Simple
+Synopsis: Liquid Types for Haskell
+Description: Liquid Types for Haskell.
+Homepage: http://goto.ucsd.edu/liquidhaskell
+License: GPL
+License-file: LICENSE
+Author: Ranjit Jhala
+Maintainer: Ranjit Jhala
+Category: Language
+Build-Type: Simple
+Cabal-version: >=1.8
+
+data-files: include/*.hquals
+ , include/*.hs
+ , include/*.spec
+ , include/Control/*.spec
+ , include/Data/*.hquals
+ , include/Data/*.spec
+ , include/Data/Text/*.spec
+ , include/Data/Text/Fusion/*.spec
+ , include/Data/Text/Lazy/*.spec
+ , include/Foreign/*.spec
+ , include/Foreign/C/*.spec
+ , include/Foreign/Marshal/*.spec
+ , include/GHC/List.lhs
+ , include/GHC/*.hquals
+ , include/GHC/*.spec
+ , include/GHC/IO/*.spec
+ , include/Language/Haskell/Liquid/List.hs
+ , include/Language/Haskell/Liquid/Prelude.hs
+ , include/Language/Haskell/Liquid/Prelude.pred
+ , include/System/*.spec
+ , syntax/liquid.css
+
+Executable liquid
+ Build-Depends: base >= 4 && < 5
+ , ghc==7.6.3
+ , ansi-terminal
+ , bifunctors
+ , cmdargs
+ , containers
+ , cpphs
+ , deepseq
+ , directory
+ , Diff
+ , filemanip
+ , filepath
+ , ghc-paths
+ , hscolour
+ , mtl
+ , parsec
+ , pretty
+ , process
+ , syb
+ , text
+ , vector
+ , liquid-fixpoint
+ , hashable<1.2
+ , unordered-containers
+ , aeson
+ , bytestring
+ -- , liquidtypes
+
+ Main-is: Liquid.hs
+ --ghc-options: -O -W
+ Extensions: PatternGuards
+
+Library
+ Build-Depends: base
+ , ghc==7.6.3
+ , ansi-terminal
+ , bifunctors
+ , cmdargs
+ , containers
+ , cpphs
+ , deepseq
+ , directory
+ , Diff
+ , filemanip
+ , filepath
+ , ghc-paths
+ , hscolour
+ , mtl
+ , parsec
+ , pretty
+ , process
+ , syb
+ , text
+ , vector
+ , hashable<1.2
+ , unordered-containers
+ , liquid-fixpoint
+ , aeson
+ , bytestring
+
+ hs-source-dirs: include, .
+
+ Exposed-Modules: Language.Haskell.Liquid.Prelude,
+ Language.Haskell.Liquid.List,
+ Language.Haskell.Liquid.PrettyPrint,
+ Language.Haskell.Liquid.Bare,
+ Language.Haskell.Liquid.Constraint,
+ Language.Haskell.Liquid.Measure,
+ Language.Haskell.Liquid.Parse,
+ Language.Haskell.Liquid.GhcInterface,
+ Language.Haskell.Liquid.RefType,
+ Language.Haskell.Liquid.PredType,
+ Language.Haskell.Liquid.Predicates,
+ Language.Haskell.Liquid.ACSS,
+ Language.Haskell.Liquid.DiffCheck,
+ Language.Haskell.Liquid.ANFTransform,
+ Language.Haskell.Liquid.Annotate,
+ Language.Haskell.Liquid.CTags,
+ Language.Haskell.Liquid.CmdLine,
+ Language.Haskell.Liquid.GhcMisc,
+ Language.Haskell.Liquid.Misc,
+ Language.Haskell.Liquid.Qualifier,
+ Language.Haskell.Liquid.TransformRec,
+ Language.Haskell.Liquid.Tidy,
+ Language.Haskell.Liquid.Types
+ Language.Haskell.Liquid.Fresh
+
+ other-modules: Language.Haskell.Liquid.Desugar.Desugar
+ Language.Haskell.Liquid.Desugar.DsExpr,
+ Language.Haskell.Liquid.Desugar.DsListComp,
+ Language.Haskell.Liquid.Desugar.MatchCon,
+ Language.Haskell.Liquid.Desugar.MatchLit,
+ Language.Haskell.Liquid.Desugar.DsArrows,
+ Language.Haskell.Liquid.Desugar.DsUtils,
+ Language.Haskell.Liquid.Desugar.Match,
+ Language.Haskell.Liquid.Desugar.DsBinds,
+ Language.Haskell.Liquid.Desugar.DsGRHSs,
+ Language.Haskell.Liquid.Desugar.HscMain
+ --ghc-options: -O -W
+ Extensions: PatternGuards
+
+
diff --git a/syntax/liquid.css b/syntax/liquid.css
new file mode 100644
--- /dev/null
+++ b/syntax/liquid.css
@@ -0,0 +1,105 @@
+.hs-linenum {
+ color: #B2B2B2;
+ font-style: italic;
+}
+
+.hs-error {
+ background-color: #FF8585 ;
+}
+
+.hs-keyglyph {
+ color: #007020
+}
+
+.hs-keyword {
+ color: #007020;
+ // font-weight: bold;
+}
+
+.hs-comment, .hs-comment a {color: green;}
+
+.hs-str, .hs-chr {color: teal;}
+
+.hs-conid {
+ color: #902000; /* color: #00FFFF; color: #0E84B5; */
+ //font-weight: bold;
+}
+
+.hs-definition {
+ color: #06287E
+ /* font-weight: bold; */
+}
+
+.hs-varid, .hs-varop, .hs-layout {
+ color: black;
+}
+
+.hs-num {
+ color: #40A070;
+}
+
+.hs-conop {
+ color: #902000;
+}
+
+.hs-cpp {
+ color: orange;
+}
+
+.hs-sel {}
+
+a.annot {
+ position:relative;
+ color:#000;
+ text-decoration:none;
+ white-space: pre;
+}
+
+a.annot:hover {
+ z-index:25;
+ background-color: #D8D8D8;
+}
+
+a.annot span.annottext{display: none}
+
+a.annot:hover span.annottext{
+
+ border-radius: 5px 5px;
+
+ -moz-border-radius: 5px;
+ -webkit-border-radius: 5px;
+
+ box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1);
+ -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);
+ -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);
+
+ white-space:pre;
+ display:block;
+ position: absolute;
+ left: 1em; top: 2em;
+ z-index: 99;
+ margin-left: 5;
+ background: #FFFFAA;
+ border: 3px solid #FFAD33;
+ padding: 0.8em 1em;
+}
+
+code {
+ /* font-weight: bold; */
+ background-color: rgb(250, 250, 250);
+ border: 1px solid rgb(200, 200, 200);
+ padding-left: 4px;
+ padding-right: 4px;
+}
+
+pre {
+ background-color: #f0f0f0;
+ border-top: 1px solid #ccc;
+ border-bottom: 1px solid #ccc;
+ padding: 5px;
+ // font-size: 120%;
+ // font-family: Bitstream Vera Sans Mono,monospace;
+ display: block;
+ overflow: visible;
+}
+