liquidhaskell 0.2.1.0 → 0.3.0.0
raw patch · 68 files changed
+6320/−5193 lines, 68 filesdep ~liquid-fixpoint
Dependency ranges changed: liquid-fixpoint
Files
- Liquid.hs +8/−10
- include/CoreToLogic.lg +10/−0
- include/GHC/Base.spec +4/−0
- include/Language/Haskell/Liquid/Foreign.hs +3/−3
- include/Language/Haskell/Liquid/List.hs +1/−3
- include/Language/Haskell/Liquid/Prelude.hs +12/−9
- include/Prelude.spec +2/−0
- liquidhaskell.cabal +33/−6
- src/Language/Haskell/Liquid/ACSS.hs +2/−33
- src/Language/Haskell/Liquid/ANFTransform.hs +6/−12
- src/Language/Haskell/Liquid/Annotate.hs +8/−12
- src/Language/Haskell/Liquid/Bare.hs +13/−1857
- src/Language/Haskell/Liquid/Bare/Check.hs +298/−0
- src/Language/Haskell/Liquid/Bare/DataType.hs +153/−0
- src/Language/Haskell/Liquid/Bare/Env.hs +105/−0
- src/Language/Haskell/Liquid/Bare/Existential.hs +102/−0
- src/Language/Haskell/Liquid/Bare/Expand.hs +138/−0
- src/Language/Haskell/Liquid/Bare/GhcSpec.hs +292/−0
- src/Language/Haskell/Liquid/Bare/Lookup.hs +159/−0
- src/Language/Haskell/Liquid/Bare/Measure.hs +204/−0
- src/Language/Haskell/Liquid/Bare/Misc.hs +134/−0
- src/Language/Haskell/Liquid/Bare/OfType.hs +227/−0
- src/Language/Haskell/Liquid/Bare/Plugged.hs +125/−0
- src/Language/Haskell/Liquid/Bare/RTEnv.hs +249/−0
- src/Language/Haskell/Liquid/Bare/RefToLogic.hs +139/−0
- src/Language/Haskell/Liquid/Bare/Resolve.hs +108/−0
- src/Language/Haskell/Liquid/Bare/Spec.hs +232/−0
- src/Language/Haskell/Liquid/Bare/SymSort.hs +82/−0
- src/Language/Haskell/Liquid/CTags.hs +1/−2
- src/Language/Haskell/Liquid/CmdLine.hs +4/−13
- src/Language/Haskell/Liquid/Constraint.hs +0/−1956
- src/Language/Haskell/Liquid/Constraint/Constraint.hs +49/−0
- src/Language/Haskell/Liquid/Constraint/Generate.hs +1764/−0
- src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +32/−0
- src/Language/Haskell/Liquid/Constraint/Types.hs +260/−0
- src/Language/Haskell/Liquid/CoreToLogic.hs +250/−46
- src/Language/Haskell/Liquid/Desugar/Check.lhs +6/−6
- src/Language/Haskell/Liquid/Desugar/DsBinds.lhs +1/−1
- src/Language/Haskell/Liquid/Desugar/DsExpr.lhs +5/−5
- src/Language/Haskell/Liquid/Desugar/DsForeign.lhs +21/−22
- src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs +0/−1
- src/Language/Haskell/Liquid/Desugar/DsListComp.lhs +4/−5
- src/Language/Haskell/Liquid/Desugar/HscMain.hs +0/−60
- src/Language/Haskell/Liquid/Desugar/Match.lhs +2/−1
- src/Language/Haskell/Liquid/Desugar/MatchCon.lhs +3/−3
- src/Language/Haskell/Liquid/Desugar/MatchLit.lhs +5/−8
- src/Language/Haskell/Liquid/Dictionaries.hs +66/−0
- src/Language/Haskell/Liquid/DiffCheck.hs +19/−73
- src/Language/Haskell/Liquid/Errors.hs +43/−21
- src/Language/Haskell/Liquid/GhcInterface.hs +19/−94
- src/Language/Haskell/Liquid/GhcMisc.hs +31/−28
- src/Language/Haskell/Liquid/GhcPlay.hs +84/−0
- src/Language/Haskell/Liquid/Literals.hs +38/−0
- src/Language/Haskell/Liquid/Measure.hs +14/−8
- src/Language/Haskell/Liquid/Misc.hs +29/−9
- src/Language/Haskell/Liquid/Parse.hs +116/−150
- src/Language/Haskell/Liquid/PredType.hs +18/−206
- src/Language/Haskell/Liquid/PrettyPrint.hs +36/−23
- src/Language/Haskell/Liquid/Qualifier.hs +3/−13
- src/Language/Haskell/Liquid/RefType.hs +112/−171
- src/Language/Haskell/Liquid/Strata.hs +2/−11
- src/Language/Haskell/Liquid/Tidy.hs +4/−10
- src/Language/Haskell/Liquid/TransformRec.hs +30/−73
- src/Language/Haskell/Liquid/Types.hs +246/−192
- src/Language/Haskell/Liquid/Variance.hs +11/−0
- src/Language/Haskell/Liquid/WiredIn.hs +112/−0
- syntax/liquid-tip.el +23/−34
- tests/test.hs +8/−3
Liquid.hs view
@@ -12,7 +12,6 @@ import qualified Language.Fixpoint.Config as FC import qualified Language.Haskell.Liquid.DiffCheck as DC-import Language.Fixpoint.Files import Language.Fixpoint.Misc import Language.Fixpoint.Interface import Language.Fixpoint.Types (sinfo)@@ -20,7 +19,9 @@ import Language.Haskell.Liquid.Errors import Language.Haskell.Liquid.CmdLine import Language.Haskell.Liquid.GhcInterface-import Language.Haskell.Liquid.Constraint +import Language.Haskell.Liquid.Constraint.Generate +import Language.Haskell.Liquid.Constraint.ToFixpoint +import Language.Haskell.Liquid.Constraint.Types import Language.Haskell.Liquid.TransformRec import Language.Haskell.Liquid.Annotate (mkOutput) @@ -54,10 +55,6 @@ let cbs'' = maybe cbs' DC.newBinds dc let cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info {cbs = cbs''} cgi `deepseq` donePhase Loud "generateConstraints"- -- SUPER SLOW: ONLY FOR DESPERATE DEBUGGING- -- SUPER SLOW: whenLoud $ do donePhase Loud "START: Write CGI (can be slow!)"- -- SUPER SLOW: {-# SCC "writeCGI" #-} writeCGI target cgi - -- SUPER SLOW: donePhase Loud "FINISH: Write CGI" out <- solveCs cfg target cgi info dc donePhase Loud "solve" let out' = mconcat [maybe mempty DC.oldOutput dc, out]@@ -81,7 +78,8 @@ vs = tgtVars $ spec info solveCs cfg target cgi info dc - = do (r, sol) <- solve fx target (hqFiles info) (cgInfoFInfo cgi)+ = do let finfo = cgInfoFInfo info cgi+ (r, sol) <- solve fx target (hqFiles info) finfo let names = checkedNames dc let warns = logErrors cgi let annm = annotMap cgi@@ -93,8 +91,8 @@ ferr s r = fmap (tidyError s) $ result $ sinfo <$> r -writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str- where - str = {-# SCC "PPcgi" #-} showpp cgi+-- writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str+-- where +-- str = {-# SCC "PPcgi" #-} showpp cgi
+ include/CoreToLogic.lg view
@@ -0,0 +1,10 @@+define Data.Set.Base.singleton x = (Set_sng x)+define Data.Set.Base.union x y = (Set_cup x y)+define Data.Set.Base.intersection x y = (Set_cap x y)+define Data.Set.Base.difference x y = (Set_dif x y)+define Data.Set.Base.empty = (Set_empty 0)+define Data.Set.Base.member x xs = (Set_mem x xs)+define Data.Set.Base.isSubsetOf x y = (Set_sub x y)++define Data.Map.Base.insert k v m = (Map_store m k v)+define Data.Map.Base.select k v = (Map_select m k)
include/GHC/Base.spec view
@@ -23,6 +23,10 @@ measure snd :: (a,b) -> b snd (a,b) = b +qualif Fst(v:a, y:b): (v = (fst y)) +qualif Snd(v:a, y:b): (v = (snd y))++ invariant {v: [a] | len(v) >= 0 } map :: (a -> b) -> xs:[a] -> {v: [b] | len(v) = len(xs)} (++) :: xs:[a] -> ys:[a] -> {v:[a] | (len v) = (len xs) + (len ys)}
include/Language/Haskell/Liquid/Foreign.hs view
@@ -33,7 +33,7 @@ {-@ 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 +mkPtr = undefined -- Ptr x {-@ isNullPtr :: p:(Ptr a) -> {v:Bool | ((Prop v) <=> (isNullPtr p)) } @-}@@ -43,11 +43,11 @@ {-@ fpLen :: p:(ForeignPtr a) -> {v:Int | v = (fplen p) } @-} fpLen :: ForeignPtr a -> Int-fpLen p = undefined+fpLen = undefined {-@ pLen :: p:(Ptr a) -> {v:Int | v = (plen p) } @-} pLen :: Ptr a -> Int-pLen p = undefined+pLen = undefined {-@ deref :: p:Ptr a -> {v:a | v = (deref p)} @-} deref :: Ptr a -> a
include/Language/Haskell/Liquid/List.hs view
@@ -1,9 +1,7 @@ module Language.Haskell.Liquid.List (transpose) where -import Data.List hiding (transpose)- transpose :: Int -> [[a]] -> [[a]]-transpose n [] = []+transpose _ [] = [] transpose n ([] : xss) = transpose n xss transpose n ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n - 1) (xs : [ t | (_:t) <- xss])
include/Language/Haskell/Liquid/Prelude.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE EmptyDataDecls #-} {- OPTIONS_GHC -cpp #-} {- OPTIONS_GHC -cpp -fglasgow-exts -} module Language.Haskell.Liquid.Prelude where -import GHC.Base- ------------------------------------------------------------------- --------------------------- Arithmetic ---------------------------- -------------------------------------------------------------------@@ -65,6 +64,7 @@ ------------------------ Specifications --------------------------- ------------------------------------------------------------------- + {-@ assume liquidAssertB :: x:{v:Bool | (Prop v)} -> {v: Bool | (Prop v)} @-} {-# NOINLINE liquidAssertB #-} liquidAssertB :: Bool -> Bool@@ -73,17 +73,17 @@ {-@ assume liquidAssert :: {v:Bool | (Prop v)} -> a -> a @-} {-# NOINLINE liquidAssert #-} liquidAssert :: Bool -> a -> a -liquidAssert b x = x+liquidAssert _ x = x {-@ assume liquidAssume :: b:Bool -> a -> {v: a | (Prop b)} @-} {-# NOINLINE liquidAssume #-} liquidAssume :: Bool -> a -> a -liquidAssume b x = x+liquidAssume _ x = x {-@ assume liquidAssumeB :: forall <p :: a -> Prop>. (a<p> -> {v:Bool| ((Prop v) <=> true)}) -> a -> a<p> @-} liquidAssumeB :: (a -> Bool) -> a -> a liquidAssumeB p x | p x = x- | otherwise = error "liquidAssumeB fails"+ | otherwise = error "liquidAssumeB fails" @@ -95,14 +95,14 @@ {-@ assume crash :: forall a . x:{v:Bool | (Prop v)} -> a @-} {-# NOINLINE crash #-} crash :: Bool -> a -crash b = undefined +crash = undefined {-# NOINLINE force #-}-force x = True +force = True {-# NOINLINE choose #-} choose :: Int -> Int-choose x = undefined +choose = undefined ------------------------------------------------------------------- ----------- Modular Arithmetic Wrappers ---------------------------@@ -124,4 +124,7 @@ {-@ 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+safeZipWith _ [] [] = []+safeZipWith _ _ _ = error "safeZipWith: cannot happen!" +
include/Prelude.spec view
@@ -34,6 +34,8 @@ type Even = {v: GHC.Types.Int | (v mod 2) = 0 } type Odd = {v: GHC.Types.Int | (v mod 2) = 1 } type BNat N = {v: Nat | v <= N } +type TT = {v: Bool | Prop v}+type FF = {v: Bool | not (Prop v)} predicate Max V X Y = if X > Y then V = X else V = Y predicate Min V X Y = if X < Y then V = X else V = Y
liquidhaskell.cabal view
@@ -1,5 +1,5 @@ Name: liquidhaskell-Version: 0.2.1.0+Version: 0.3.0.0 Copyright: 2010-15 Ranjit Jhala, University of California, San Diego. build-type: Simple Synopsis: Liquid Types for Haskell @@ -16,6 +16,7 @@ data-files: include/*.hquals , include/*.hs , include/*.spec+ , include/CoreToLogic.lg , include/Control/*.spec , include/Data/*.hquals , include/Data/*.spec@@ -67,7 +68,7 @@ , syb , text , vector- , liquid-fixpoint >= 0.2.1.0+ , liquid-fixpoint , hashable , unordered-containers , aeson@@ -76,7 +77,7 @@ , liquidhaskell Main-is: Liquid.hs- --ghc-options: -O -W+ ghc-options: -W Default-Extensions: PatternGuards -- Executable liquid-count-binders@@ -145,7 +146,7 @@ , vector , hashable , unordered-containers- , liquid-fixpoint >= 0.2.1.0+ , liquid-fixpoint >= 0.2.2.0 , aeson , bytestring , fingertree@@ -157,7 +158,10 @@ Language.Haskell.Liquid.List, Language.Haskell.Liquid.PrettyPrint, Language.Haskell.Liquid.Bare,- Language.Haskell.Liquid.Constraint, + Language.Haskell.Liquid.Constraint.Constraint, + Language.Haskell.Liquid.Constraint.Types, + Language.Haskell.Liquid.Constraint.Generate, + Language.Haskell.Liquid.Constraint.ToFixpoint, Language.Haskell.Liquid.Measure, Language.Haskell.Liquid.Parse, Language.Haskell.Liquid.GhcInterface, @@ -172,16 +176,39 @@ Language.Haskell.Liquid.CTags, Language.Haskell.Liquid.CmdLine, Language.Haskell.Liquid.GhcMisc, + Language.Haskell.Liquid.GhcPlay, Language.Haskell.Liquid.Misc, Language.Haskell.Liquid.CoreToLogic,+ Language.Haskell.Liquid.Variance,+ Language.Haskell.Liquid.Dictionaries, Language.Haskell.Liquid.Qualifier, Language.Haskell.Liquid.TransformRec, Language.Haskell.Liquid.Tidy, Language.Haskell.Liquid.Types,+ Language.Haskell.Liquid.Literals, Language.Haskell.Liquid.Strata, Language.Haskell.Liquid.Fresh,+ Language.Haskell.Liquid.WiredIn, Paths_liquidhaskell, + -- FIXME: These shouldn't really be exposed, but the linker complains otherwise...+ Language.Haskell.Liquid.Bare.RefToLogic+ Language.Haskell.Liquid.Bare.Check+ Language.Haskell.Liquid.Bare.DataType+ Language.Haskell.Liquid.Bare.Env+ Language.Haskell.Liquid.Bare.Expand+ Language.Haskell.Liquid.Bare.Existential+ Language.Haskell.Liquid.Bare.GhcSpec+ Language.Haskell.Liquid.Bare.Lookup+ Language.Haskell.Liquid.Bare.Measure+ Language.Haskell.Liquid.Bare.Misc+ Language.Haskell.Liquid.Bare.OfType+ Language.Haskell.Liquid.Bare.Plugged+ Language.Haskell.Liquid.Bare.Resolve+ Language.Haskell.Liquid.Bare.RTEnv+ Language.Haskell.Liquid.Bare.SymSort+ Language.Haskell.Liquid.Bare.Spec+ --NOTE: these need to be exposed so GHC generates .dyn_o files for them.. Language.Haskell.Liquid.Desugar.Desugar, Language.Haskell.Liquid.Desugar.DsExpr,@@ -198,7 +225,7 @@ Language.Haskell.Liquid.Desugar.DsBinds, Language.Haskell.Liquid.Desugar.DsGRHSs, Language.Haskell.Liquid.Desugar.HscMain- --ghc-options: -O -W+ ghc-options: -W ghc-prof-options: -fprof-auto Default-Extensions: PatternGuards
src/Language/Haskell/Liquid/ACSS.hs view
@@ -20,12 +20,7 @@ import Data.Char (isSpace) import Text.Printf import Language.Haskell.Liquid.GhcMisc--- import Language.Fixpoint.Misc--- import Data.Monoid ---- import Debug.Trace- data AnnMap = Ann { types :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type) , errors :: [(Loc, Loc, String)] -- ^ List of error intervals@@ -35,18 +30,13 @@ data Status = Safe | Unsafe | Error | Crash deriving (Eq, Ord, Show) -emptyAnnMap = Ann M.empty [] - data Annotation = A { typ :: Maybe String -- ^ type string , err :: Maybe String -- ^ error string , lin :: Maybe (Int, Int) -- ^ line number, total width of lines i.e. max (length (show lineNum)) } deriving (Show) -getFirstMaybe x@(Just _) _ = x-getFirstMaybe Nothing y = y - -- | Formats Haskell source code using HTML and mouse-over annotations hscolour :: Bool -- ^ Whether to include anchors. -> Bool -- ^ Whether input document is literate haskell or not@@ -160,7 +150,8 @@ = error "stitch" stitch _ [] = []-+stitch _ _ + = error "stitch: cannot happen" splitSrcAndAnns :: String -> (String, AnnMap) splitSrcAndAnns s = @@ -184,13 +175,6 @@ breakS = "MOUSEOVER ANNOTATIONS" --- annotParse :: String -> String -> AnnMap--- annotParse mname = Ann . M.map reduce . group . parseLines mname 0 . lines--- where --- group = foldl' (\m (k, v) -> inserts k v m) M.empty --- reduce anns@((x,_):_) = (x, mconcat $ map snd anns)--- inserts k v m = M.insert k (v : M.lookupDefault [] k m) m- annotParse :: String -> String -> AnnMap annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe where @@ -224,13 +208,6 @@ parseLines _ i _ = error $ "Error Parsing Annot Input on Line: " ++ show i --- stringAnnotation s --- | "ERROR" `isPrefixOf` s = A Nothing (Just s)--- | otherwise = A (Just s) Nothing---- takeFileName s = map slashWhite s--- where slashWhite '/' = ' '- instance Show AnnMap where show (Ann ts es _ ) = "\n\n" ++ (concatMap ppAnnotTyp $ M.toList ts) ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es])@@ -238,13 +215,7 @@ ppAnnotTyp (L (l, c), (x, s)) = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s ppAnnotErr (L (l, c), L (l', c')) = printf " \n%d\n%d\n0\n%d\n%d\n\n\n\n" l c l' c' --- where ppAnnot (L (l, c), (x,s)) = x ++ "\n" --- ++ show l ++ "\n"--- ++ show c ++ "\n"--- ++ show (length $ lines s) ++ "\n"--- ++ s ++ "\n\n\n" - --------------------------------------------------------------------------------- ---- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour -- ---------------------------------------------------------------------------------@@ -260,7 +231,6 @@ where lines' [] acc = [acc []] lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id -- DOS---lines' ('\^M':s) acc = acc ['\n'] : lines' s id -- MacOS lines' ('\n':s) acc = acc ['\n'] : lines' s id -- Unix lines' (c:s) acc = lines' s (acc . (c:)) @@ -284,7 +254,6 @@ go (x:xs) | end `isPrefixOf `x = Lit x: classify xs go (x:xs) = Code x: go xs- -- | Join up chunks of code\/comment that are next to each other.
src/Language/Haskell/Liquid/ANFTransform.hs view
@@ -1,21 +1,19 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------------- ------------ Code to convert Core to Administrative Normal Form --------------------- ------------------------------------------------------------------------------------- module Language.Haskell.Liquid.ANFTransform (anormalize) where-import Coercion (isCoVar, isCoVarType) import CoreSyn import CoreUtils (exprType) import qualified DsMonad import DsMonad (initDs)-import FastString (fsLit) import GHC hiding (exprType) import HscTypes import Id (mkSysLocalM)@@ -30,9 +28,6 @@ import FamInstEnv (emptyFamInstEnv) import VarEnv (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv) import Control.Monad.State.Lazy-import Control.Monad.Trans (lift)-import Control.Monad-import Control.Applicative ((<$>)) import UniqSupply (MonadUnique) import Language.Fixpoint.Types (anfPrefix) import Language.Haskell.Liquid.GhcMisc (MGIModGuts(..), showPpr, symbolFastString)@@ -41,7 +36,6 @@ import Data.Maybe (fromMaybe) import Data.List (sortBy, (\\)) import Control.Applicative-import qualified Data.Text as T anormalize :: Bool -> HscEnv -> MGIModGuts -> IO [CoreBind] anormalize expandFlag hscEnv modGuts@@ -137,7 +131,7 @@ normalizeName _ e@(Lit _) = return e -normalizeName γ e@(Coercion _)+normalizeName _ e@(Coercion _) = do x <- lift $ freshNormalVar $ exprType e add [NonRec x e] return $ Var x
src/Language/Haskell/Liquid/Annotate.hs view
@@ -17,11 +17,8 @@ , srcSpanStartCol , srcSpanEndCol , srcSpanStartLine- , srcSpanEndLine- , RealSrcSpan (..))-import Var (Var (..))-import TypeRep (Prec(..))-import Text.PrettyPrint.HughesPJ hiding (first, second)+ , srcSpanEndLine)+import Text.PrettyPrint.HughesPJ hiding (first) import GHC.Exts (groupWith, sortWith) import Data.Char (isSpace)@@ -32,9 +29,7 @@ import Data.Aeson import Control.Arrow hiding ((<+>)) import Control.Applicative ((<$>))-import Control.DeepSeq import Control.Monad (when, forM_)-import Data.Monoid import System.FilePath (takeFileName, dropFileName, (</>)) import System.Directory (findExecutable, copyFile)@@ -50,11 +45,11 @@ import Language.Fixpoint.Names hiding (encode) import Language.Fixpoint.Misc import Language.Haskell.Liquid.GhcMisc-import Language.Fixpoint.Types hiding (Def (..), Located (..))+import Language.Fixpoint.Types hiding (Def (..), Constant (..), Located (..)) import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.PrettyPrint import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.Errors+import Language.Haskell.Liquid.Errors () import Language.Haskell.Liquid.Tidy import Language.Haskell.Liquid.Types hiding (Located(..), Def(..)) @@ -95,7 +90,7 @@ bots = o_bots out tyHtmlF = extFileName Html srcF tpHtmlF = extFileName Html $ extFileName Cst srcF - annF = extFileName Annot srcF+ _annF = extFileName Annot srcF jsonF = extFileName Json srcF vimF = extFileName Vim srcF showWarns = not $ nowarnings cfg@@ -260,6 +255,7 @@ (_, x:_, _, _) -> [x] (_, _, x:_, _) -> [x] (_, _, _, x:_) -> [x]+ (_, _, _, _ ) -> [ ] where rs = [x | x@(_, AnnRDf _) <- xas] ds = [x | x@(_, AnnDef _) <- xas]@@ -404,8 +400,8 @@ -- | A Little Unit Test -------------------------------------------------------- -------------------------------------------------------------------------------- -anns :: AnnTypes -anns = i [(5, i [( 14, A1 { ident = "foo"+_anns :: AnnTypes +_anns = i [(5, i [( 14, A1 { ident = "foo" , ann = "int -> int" , row = 5 , col = 14
src/Language/Haskell/Liquid/Bare.hs view
@@ -1,1857 +1,13 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE LambdaCase #-}---- | This module contains the functions that convert /from/ descriptions of --- symbols, names and types (over freshly parsed /bare/ Strings),--- /to/ representations connected to GHC vars, names, and types.--- The actual /representations/ of bare and real (refinement) types are all--- in `RefType` -- they are different instances of `RType`--module Language.Haskell.Liquid.Bare (- GhcSpec (..)- , makeGhcSpec- ) where--import ConLike -import GHC hiding (lookupName, Located)-import Text.PrettyPrint.HughesPJ hiding (first, (<>))-import Var-import Name (getSrcSpan, isInternalName)-import NameSet-import Id (isConLikeId)-import CoreSyn hiding (Expr)-import PrelNames-import PrelInfo (wiredInThings)-import Type (expandTypeSynonyms, splitFunTy_maybe)-import DataCon (dataConWorkId, dataConStupidTheta, dataConName)-import TyCon (SynTyConRhs(SynonymTyCon))-import HscMain-import TysWiredIn-import BasicTypes (TupleSort (..), Arity)-import TcRnDriver (tcRnLookupRdrName) -import RdrName (setRdrNameSpace)-import OccName (tcName)-import Data.Char (isLower, isUpper)-import Text.Printf--- import Data.Maybe (listToMaybe, fromMaybe, mapMaybe, catMaybes, isNothing, fromJust)-import Control.DeepSeq (force)-import Control.Monad.State (get, gets, modify, put, State, evalState, evalStateT, execState, execStateT, StateT)-import Data.Traversable (forM)-import Control.Applicative ((<$>), (<*>), (<|>))-import Control.Monad.Reader hiding (forM)-import Control.Monad.Error hiding (Error, forM)-import Control.Monad.Writer hiding (forM)-import qualified Control.Exception as Ex -import Data.Bifunctor-import Data.Generics.Aliases (mkT)-import Data.Generics.Schemes (everywhere)--- import Data.Data hiding (TyCon, tyConName)--- import Data.Function (on)-import qualified Data.Text as T-import Text.Parsec.Pos-import Language.Fixpoint.Misc-import Language.Fixpoint.Names (prims, hpropConName, propConName, takeModuleNames, dropModuleNames, isPrefixOfSym, dropSym, lengthSym, headSym, stripParensSym, takeWhileSym)-import Language.Fixpoint.Types hiding (Def, Predicate, R)-import Language.Fixpoint.Sort (checkSortFull, checkSortedReftFull, checkSorted)-import Language.Haskell.Liquid.GhcMisc hiding (L)-import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.RefType hiding (freeTyVars)-import Language.Haskell.Liquid.Errors-import Language.Haskell.Liquid.PredType hiding (unify)-import Language.Haskell.Liquid.CoreToLogic-import qualified Language.Haskell.Liquid.Measure as Ms---import Data.Maybe-import qualified Data.List as L-import qualified Data.HashSet as S-import qualified Data.HashMap.Strict as M-import TypeRep--import Debug.Trace (trace)------------------------------------------------------------------------------- Top Level Output -----------------------------------------------------------------------------------------------------------makeGhcSpec :: Config -> ModName -> [CoreBind] -> [Var] -> [Var] -> NameSet -> HscEnv- -> [(ModName,Ms.BareSpec)]- -> IO GhcSpec-makeGhcSpec cfg name cbs vars defVars exports env specs- - = throwOr (throwOr return . checkGhcSpec specs . postProcess cbs) =<< execBare act initEnv- where- act = makeGhcSpec' cfg cbs vars defVars exports specs- throwOr = either Ex.throw- initEnv = BE name mempty mempty mempty env- -postProcess :: [CoreBind] -> GhcSpec -> GhcSpec-postProcess cbs sp@(SP {..}) = sp { tySigs = sigs, texprs = ts }- -- HEREHEREHEREHERE (addTyConInfo stuff) - where- (sigs, ts) = replaceLocalBinds tcEmbeds tyconEnv tySigs texprs (ghcSpecEnv sp) cbs----------------------------------------------------------------------------------------------------makeGhcSpec' :: Config -> [CoreBind] -> [Var] -> [Var] -> NameSet -> [(ModName, Ms.BareSpec)] -> BareM GhcSpec--------------------------------------------------------------------------------------------------makeGhcSpec' cfg cbs vars defVars exports specs- = do name <- gets modName- _ <- makeRTEnv specs- (tycons, datacons, dcSs, tyi, embs) <- makeGhcSpecCHOP1 specs- modify $ \be -> be { tcEnv = tyi }- (cls, mts) <- second mconcat . unzip . mconcat <$> mapM (makeClasses cfg vars) specs- (invs, ialias, sigs, asms) <- makeGhcSpecCHOP2 cfg vars defVars specs name cls mts embs- (measures, cms', ms', cs', xs') <- makeGhcSpecCHOP3 cfg cbs vars specs dcSs datacons cls embs- syms <- makeSymbols (vars ++ map fst cs') xs' (sigs ++ asms ++ cs') ms' (invs ++ (snd <$> ialias))- let su = mkSubst [ (x, mkVarExpr v) | (x, v) <- syms]- return (emptySpec cfg)- >>= makeGhcSpec0 cfg defVars exports name- >>= makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su - >>= makeGhcSpec2 invs ialias measures su - >>= makeGhcSpec3 datacons tycons embs syms - >>= makeGhcSpec4 defVars specs name su --emptySpec :: Config -> GhcSpec-emptySpec cfg = SP [] [] [] [] [] [] [] [] [] mempty [] [] [] [] mempty mempty cfg mempty [] mempty ---makeGhcSpec0 cfg defVars exports name sp- = do targetVars <- makeTargetVars name defVars $ binders cfg- return $ sp { config = cfg - , exports = exports - , tgtVars = targetVars }--makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su sp- = do tySigs <- makePluggedSigs name embs tyi exports $ tx sigs- asmSigs <- makePluggedAsmSigs embs tyi $ tx asms- ctors <- makePluggedAsmSigs embs tyi $ tx cs'- return $ sp { tySigs = tySigs- , asmSigs = asmSigs- , ctors = ctors- , meas = tx' $ tx $ ms' ++ varMeasures vars ++ cms' }- where- tx = fmap . mapSnd . subst $ su- tx' = fmap (mapSnd $ fmap uRType)---makeGhcSpec2 invs ialias measures su sp- = return $ sp { invariants = subst su invs - , ialiases = subst su ialias - , measures = subst su <$> M.elems $ Ms.measMap measures }--makeGhcSpec3 datacons tycons embs syms sp- = do tcEnv <- gets tcEnv- return $ sp { tyconEnv = tcEnv- , dconsP = datacons- , tconsP = tycons- , tcEmbeds = embs - , freeSyms = [(symbol v, v) | (_, v) <- syms] }--makeGhcSpec4 defVars specs name su sp- = do decr' <- mconcat <$> mapM (makeHints defVars) specs- texprs' <- mconcat <$> mapM (makeTExpr defVars) specs- lazies <- mkThing makeLazy- lvars' <- mkThing makeLVar- hmeas <- mkThing makeHMeas- quals <- mconcat <$> mapM makeQualifiers specs- return $ sp { qualifiers = subst su quals- , decr = decr'- , texprs = texprs'- , lvars = lvars'- , lazy = lazies - , tySigs = strengthenHaskellMeasures hmeas ++ tySigs sp} - where- mkThing mk = S.fromList . mconcat <$> sequence [ mk defVars (m, s) | (m, s) <- specs, m == name ]--makeGhcSpecCHOP1 specs- = do (tcs, dcs) <- mconcat <$> mapM makeConTypes specs- let tycons = tcs ++ wiredTyCons - let tyi = makeTyConInfo tycons- embs <- mconcat <$> mapM makeTyConEmbeds specs- datacons <- makePluggedDataCons embs tyi (concat dcs ++ wiredDataCons)- let dcSelectors = concat $ map makeMeasureSelectors datacons- return $ (tycons, second val <$> datacons, dcSelectors, tyi, embs) --makeGhcSpecCHOP2 cfg vars defVars specs name cls mts embs- = do sigs' <- mconcat <$> mapM (makeAssertSpec name cfg vars defVars) specs- asms' <- mconcat <$> mapM (makeAssumeSpec name cfg vars defVars) specs- invs <- mconcat <$> mapM makeInvariants specs- ialias <- mconcat <$> mapM makeIAliases specs- let dms = makeDefaultMethods vars mts- tyi <- gets tcEnv- let sigs = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (m, x, t) <- sigs' ++ mts ++ dms ]- let asms = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (m, x, t) <- asms' ]- return (invs, ialias, sigs, asms)--makeGhcSpecCHOP3 cfg cbs vars specs dcSelectors datacons cls embs- = do measures' <- mconcat <$> mapM makeMeasureSpec specs- tyi <- gets tcEnv- name <- gets modName - hmeans <- mapM (makeHaskellMeasures cbs name) specs- let measures = mconcat (measures':Ms.mkMSpec' dcSelectors:hmeans)- let (cs, ms) = makeMeasureSpec' measures- let cms = makeClassMeasureSpec measures- let cms' = [ (x, Loc l $ cSort t) | (Loc l x, t) <- cms ]- let ms' = [ (x, Loc l t) | (Loc l x, t) <- ms, isNothing $ lookup x cms' ]- let cs' = [ (v, Loc (getSourcePos v) (txRefSort tyi embs t)) | (v, t) <- meetDataConSpec cs (datacons ++ cls)]- let xs' = val . fst <$> ms- return (measures, cms', ms', cs', xs')- -makeHaskellMeasures :: [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM (Ms.MSpec SpecType DataCon)-makeHaskellMeasures cbs name' (name, spec) | name /= name' = return mempty-makeHaskellMeasures cbs _ (name, spec) = Ms.mkMSpec' <$> mapM (makeMeasureDefinition cbs) (S.toList $ Ms.hmeas spec)--makeMeasureDefinition :: [CoreBind] -> LocSymbol -> BareM (Measure SpecType DataCon)-makeMeasureDefinition cbs x - = case (filter ((val x `elem`) . (map (dropModuleNames . simplesymbol)) . binders) cbs) of- (NonRec v def:_) -> (Ms.mkM x (ofType $ varType v)) <$> coreToDef' x v def- (Rec [(v, def)]:_) -> (Ms.mkM x (ofType $ varType v)) <$> coreToDef' x v def- _ -> mkError "Cannot extract measure from haskell function"- where- binders (NonRec x _) = [x]- binders (Rec xes) = fst <$> xes -- coreToDef' x v def = case (runToLogic $ coreToDef x v def) of - Left x -> return x- Right (LE str) -> mkError str-- mkError str = throwError $ ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str) --simplesymbol = symbol . getName---strengthenHaskellMeasures :: S.HashSet Var -> [(Var, Located SpecType)]-strengthenHaskellMeasures hmeas = (\v -> (v, dummyLoc $ strengthenResult v)) <$> (S.toList hmeas)--strengthenResult :: Var -> SpecType-strengthenResult v- = fromRTypeRep $ rep{ty_res = ty_res rep `strengthen` r}- where rep = toRTypeRep t- r = U (exprReft (EApp f [EVar x])) mempty mempty- x = safeHead "strengthenResult" $ ty_binds rep- f = dummyLoc $ dropModuleNames $ simplesymbol v- t = (ofType $ varType v) :: SpecType--makeMeasureSelectors :: (DataCon, Located DataConP) -> [Measure SpecType DataCon]-makeMeasureSelectors (dc, (Loc loc (DataConP _ vs _ _ _ xts r))) = go <$> zip (reverse xts) [1..]- where- go ((x,t), i) = makeMeasureSelector (Loc loc x) (dty t) dc n i- - dty t = foldr RAllT (RFun dummySymbol r (fmap mempty t) mempty) vs- n = length xts--makePluggedSigs name embs tcEnv exports sigs- = forM sigs $ \(x,t) -> do- let τ = expandTypeSynonyms $ varType x- let r = maybeTrue x name exports- (x,) <$> plugHoles embs tcEnv x r τ t--makePluggedAsmSigs embs tcEnv sigs- = forM sigs $ \(x,t) -> do- let τ = expandTypeSynonyms $ varType x- let r = killHoles- (x,) <$> plugHoles embs tcEnv x r τ t--makePluggedDataCons embs tcEnv dcs- = forM dcs $ \(dc, Loc l dcp) -> do- let (das, _, dts, dt) = dataConSig dc- let su = zip (freeTyVars dcp) (map rTyVar das)- tyArgs <- zipWithM (\t1 (x,t2) -> - (x,) . val <$> plugHoles embs tcEnv (dataConName dc) killHoles t1 (Loc l t2)) - dts (reverse $ tyArgs dcp)- tyRes <- val <$> plugHoles embs tcEnv (dataConName dc) killHoles dt (Loc l (tyRes dcp))- return (dc, Loc l dcp { freeTyVars = map rTyVar das- , freePred = map (subts (zip (freeTyVars dcp) (map (rVar :: TyVar -> RSort) das))) (freePred dcp)- , tyArgs = reverse tyArgs- , tyRes = tyRes})--makeMeasureSelector x s dc n i = M {name = x, sort = s, eqns = [eqn]}- where eqn = Def x dc (mkx <$> [1 .. n]) (E (EVar $ mkx i)) - mkx j = symbol ("xx" ++ show j)- ---- Refinement Type Aliases-makeRTEnv specs- = do forM_ rts $ \(mod, rta) -> setRTAlias (rtName rta) $ Left (mod, rta)- forM_ pts $ \(mod, pta) -> setRPAlias (rtName pta) $ Left (mod, pta)- forM_ ets $ \(mod, eta) -> setREAlias (rtName eta) $ Left (mod, eta)- makeREAliases ets- makeRPAliases pts- makeRTAliases rts- where- rts = (concat [(m,) <$> Ms.aliases s | (m, s) <- specs])- pts = (concat [(m,) <$> Ms.paliases s | (m, s) <- specs])- ets = (concat [(m,) <$> Ms.ealiases s | (m, s) <- specs])- -makeRTAliases xts = mapM_ expBody xts- where- expBody (mod,xt) = inModule mod $ do- let l = rtPos xt- body <- withVArgs l (rtVArgs xt) $ expandRTAlias l $ rtBody xt- setRTAlias (rtName xt) $ Right $ mapRTAVars symbolRTyVar $ xt { rtBody = body }--makeRPAliases xts = mapM_ expBody xts- where - expBody (mod, xt) = inModule mod $ do- let l = rtPos xt- env <- gets $ predAliases . rtEnv- body <- withVArgs l (rtVArgs xt) $ expandRPAliasE l $ rtBody xt- setRPAlias (rtName xt) $ Right $ xt { rtBody = body }--makeREAliases xts = mapM_ expBody xts- where - expBody (mod, xt) = inModule mod $ do- let l = rtPos xt- env <- gets $ exprAliases . rtEnv- body <- withVArgs l (rtVArgs xt) $ expandREAliasE l $ rtBody xt- setREAlias (rtName xt) $ Right $ xt { rtBody = body }---- | Using the Alias Environment to Expand Definitions-expandRTAliasMeasure m- = do eqns <- sequence $ expandRTAliasDef <$> (eqns m)- return $ m { sort = generalize (sort m)- , eqns = eqns }--expandRTAliasDef :: Def LocSymbol -> BareM (Def LocSymbol)-expandRTAliasDef d- = do env <- gets rtEnv- body <- expandRTAliasBody (loc $ measure d) env $ body d- return $ d { body = body }--expandRTAliasBody :: SourcePos -> RTEnv -> Body -> BareM Body-expandRTAliasBody l env (P p) = P <$> expPAlias l p-expandRTAliasBody l env (R x p) = R x <$> expPAlias l p-expandRTAliasBody l _ (E e) = E <$> resolve l e--expPAlias :: SourcePos -> Pred -> BareM Pred-expPAlias l = expandPAlias l []---expandRTAlias :: SourcePos -> BareType -> BareM SpecType-expandRTAlias l bt = expType =<< expReft bt- where - expReft = mapReftM (txPredReft expPred expExpr)- expType = expandAlias l []- expPred = expandPAlias l []- expExpr = expandEAlias l []--mapPredM f = go- where- go (PAnd ps) = PAnd <$> mapM go ps- go (POr ps) = POr <$> mapM go ps- go (PNot p) = PNot <$> go p- go (PImp p q) = PImp <$> go p <*> go q- go (PIff p q) = PIff <$> go p <*> go q- go (PBexp e) = PBexp <$> f e- go (PAtom b e1 e2) = PAtom b <$> f e1 <*> f e2- go (PAll xs p) = PAll xs <$> go p- go p = return p- --txPredReft :: (Pred -> BareM Pred) -> (Expr -> BareM Expr) -> RReft -> BareM RReft-txPredReft f fe (U r p l) = (\r -> U r p l) <$> txPredReft' f r- where - txPredReft' f (Reft (v, ras)) = Reft . (v,) <$> mapM (txPredRefa f) ras- txPredRefa f (RConc p) = fmap RConc $ (f <=< mapPredM fe) p- txPredRefa _ z = return z---- | Using the Alias Environment to Expand Definitions--expandAlias :: SourcePos -> [Symbol] -> BareType -> BareM SpecType-expandAlias l = go- where- go s t@(RApp (Loc _ c) _ _ _)- | c `elem` s = Ex.throw $ errOther $ text - $ "Cyclic Reftype Alias Definition: " ++ show (c:s)- | otherwise = lookupExpandRTApp l s t- go s (RVar a r) = RVar (symbolRTyVar a) <$> resolve l r- go s (RFun x t t' r) = rFun x <$> go s t <*> go s t'- go s (RAppTy t t' r) = RAppTy <$> go s t <*> go s t' <*> resolve l r- go s (RAllE x t1 t2) = liftM2 (RAllE x) (go s t1) (go s t2)- go s (REx x t1 t2) = liftM2 (REx x) (go s t1) (go s t2)- go s (RAllT a t) = RAllT (symbolRTyVar a) <$> go s t- go s (RAllP a t) = RAllP <$> ofBPVar a <*> go s t- go s (RAllS l t) = RAllS l <$> go s t- go _ (ROth s) = return $ ROth s- go _ (RExprArg e) = return $ RExprArg e- go _ (RHole r) = RHole <$> resolve l r---lookupExpandRTApp l s (RApp lc@(Loc _ c) ts rs r) = do- env <- gets (typeAliases.rtEnv)- case M.lookup c env of- Just (Left (mod,rtb)) -> do- st <- inModule mod $ withVArgs l (rtVArgs rtb) $ expandAlias l (c:s) $ rtBody rtb- let rts = mapRTAVars symbolRTyVar $ rtb { rtBody = st }- setRTAlias c $ Right rts- r' <- resolve l r- expandRTApp l s rts ts r'- Just (Right rts) -> do- r' <- resolve l r- withVArgs l (rtVArgs rts) $ expandRTApp l s rts ts r'- Nothing- | isList c && length ts == 1 -> do- tyi <- tcEnv <$> get- r' <- resolve l r- liftM2 (bareTCApp tyi r' listTyCon) (mapM (go s) rs) (mapM (expandAlias l s) ts)- | isTuple c -> do- tyi <- tcEnv <$> get- r' <- resolve l r- let tc = tupleTyCon BoxedTuple (length ts)- liftM2 (bareTCApp tyi r' tc) (mapM (go s) rs) (mapM (expandAlias l s) ts)- | otherwise -> do- tyi <- tcEnv <$> get- r' <- resolve l r- liftM3 (bareTCApp tyi r') (lookupGhcTyCon lc) (mapM (go s) rs) (mapM (expandAlias l s) ts)- where- go s (RPropP ss r) = RPropP <$> mapM ofSyms ss <*> resolve l r- go s (RProp ss t) = RProp <$> mapM ofSyms ss <*> expandAlias l s t- go _ (RHProp _ _) = errorstar "TODO:EFFECTS:lookupExpandRTApp"--expandRTApp :: SourcePos -> [Symbol] -> RTAlias RTyVar SpecType -> [BareType] -> RReft -> BareM SpecType-expandRTApp l s rta args r- | length args == length αs + length εs- = do args' <- mapM (expandAlias l s) args- let ts = take (length αs) args'- αts = zipWith (\α t -> (α, toRSort t, t)) αs ts- return $ subst su . (`strengthen` r) . subsTyVars_meet αts $ rtBody rta- | otherwise- = Ex.throw err- where- su = mkSubst $ zip (symbol <$> εs) es- αs = rtTArgs rta - εs = rtVArgs rta- es_ = drop (length αs) args- es = map (exprArg $ show err) es_- msg = show err- err :: Error- err = ErrAliasApp (sourcePosSrcSpan l) (length args) (pprint $ rtName rta) (sourcePosSrcSpan $ rtPos rta) (length αs + length εs) -- -- JUNK msg = "Malformed type alias application at " ++ show l ++ "\n\t"- -- JUNK ++ show (rtName rta) - -- JUNK ++ " defined at " ++ show (rtPos rta)- -- JUNK ++ "\n\texpects " ++ show ()- -- JUNK ++ " arguments but it is given " ++ show (length args)-- -- JUNK Ex.throw $ errOther $ text - -- JUNK $ "Cyclic Reftype Alias Definition: " ++ show (c:s)- --- | exprArg converts a tyVar to an exprVar because parser cannot tell --- HORRIBLE HACK To allow treating upperCase X as value variables X--- e.g. type Matrix a Row Col = List (List a Row) Col--exprArg _ (RExprArg e) - = e-exprArg _ (RVar x _) - = EVar (symbol x)-exprArg _ (RApp x [] [] _) - = EVar (symbol x)-exprArg msg (RApp f ts [] _) - = EApp (symbol <$> f) (exprArg msg <$> ts)-exprArg msg (RAppTy (RVar f _) t _) - = EApp (dummyLoc $ symbol f) [exprArg msg t]-exprArg msg z - = errorstar $ printf "Unexpected expression parameter: %s in %s" (show z) msg --expandRPAliasE l = expandPAlias l []--expandPAlias :: SourcePos -> [Symbol] -> Pred -> BareM Pred-expandPAlias l = go- where - go s p@(PBexp (EApp f@(Loc l' f') es))- | f' `elem` s = errorstar $ "Cyclic Predicate Alias Definition: " ++ show (f':s)- | otherwise = do- env <- gets (predAliases.rtEnv)- case M.lookup f' env of- Just (Left (mod,rp)) -> do- body <- inModule mod $ withVArgs l' (rtVArgs rp) $ expandPAlias l' (f':s) $ rtBody rp- let rp' = rp { rtBody = body }- setRPAlias f' $ Right $ rp'- expandEApp l (f':s) rp' <$> resolve l es- Just (Right rp) ->- withVArgs l (rtVArgs rp) (expandEApp l (f':s) rp <$> resolve l es)- Nothing -> fmap PBexp (EApp <$> resolve l f <*> resolve l es)- go s (PAnd ps) = PAnd <$> (mapM (go s) ps)- go s (POr ps) = POr <$> (mapM (go s) ps)- go s (PNot p) = PNot <$> (go s p)- go s (PImp p q) = PImp <$> (go s p) <*> (go s q)- go s (PIff p q) = PIff <$> (go s p) <*> (go s q)- go s (PAll xts p) = PAll xts <$> (go s p)- go _ p = resolve l p--expandREAliasE l = expandEAlias l []--expandEAlias :: SourcePos -> [Symbol] -> Expr -> BareM Expr-expandEAlias l = go- where - --NOTE: don't do any name-resolution here, expandPAlias runs afterwards and- -- will handle it- go s e@(EApp f@(Loc l' f') es)- | f' `elem` s = errorstar $ "Cyclic Predicate Alias Definition: " ++ show (f':s)- | otherwise = do- env <- gets (exprAliases.rtEnv)- case M.lookup f' env of- Just (Left (mod,re)) -> do- body <- inModule mod $ withVArgs l' (rtVArgs re) $ expandEAlias l' (f':s) $ rtBody re- let re' = re { rtBody = body }- setREAlias f' $ Right $ re'- expandEApp l (f':s) re' <$> mapM (go (f':s)) es- Just (Right re) ->- withVArgs l (rtVArgs re) (expandEApp l (f':s) re <$> mapM (go (f':s)) es)- Nothing -> EApp f <$> mapM (go s) es- go s (EBin op e1 e2) = EBin op <$> go s e1 <*> go s e2- go s (EIte p e1 e2) = EIte p <$> go s e1 <*> go s e2- go s (ECst e st) = (`ECst` st) <$> go s e- go _ e = return e--expandEApp l s re es- = let su = mkSubst $ safeZipWithError msg (rtVArgs re) es- msg = "Malformed alias application at " ++ show l ++ "\n\t"- ++ show (rtName re) - ++ " defined at " ++ show (rtPos re)- ++ "\n\texpects " ++ show (length $ rtVArgs re)- ++ " arguments but it is given " ++ show (length es)--- msg = "expandRPApp: " ++ show (EApp (dummyLoc $ symbol $ rtName rp) es)- in subst su $ rtBody re--makeQualifiers (mod,spec) = inModule mod mkQuals- where- mkQuals = -- resolve dummyPos $ Ms.qualifiers spec- mapM (\q -> resolve (q_pos q) q) $ Ms.qualifiers spec---makeClasses cfg vs (mod, spec) = inModule mod $ mapM mkClass $ Ms.classes spec- where- --FIXME: cleanup this code- unClass = snd . bkClass . fourth4 . bkUniv- mkClass (RClass c ss as ms)- = do let l = loc c - tc <- lookupGhcTyCon c- ss' <- mapM (mkSpecType l) ss- let (dc:_) = tyConDataCons tc- let αs = map symbolRTyVar as- let as' = [rVar $ symbolTyVar a | a <- as ]- let ms' = [ (s, rFun "" (RApp c (flip RVar mempty <$> as) [] mempty) t) | (s, t) <- ms]- vts <- makeSpec cfg vs ms'- let sts = [(val s, unClass $ val t) | (s, _) <- ms- | (_, _, t) <- vts]- let t = rCls tc as'- let dcp = DataConP l αs [] [] ss' (reverse sts) t- return ((dc,dcp),vts)--makeHints vs (_, spec) = varSymbols id "Hint" vs $ Ms.decr spec-makeLVar vs (_, spec) = fmap fst <$> (varSymbols id "LazyVar" vs $ [(v, ()) | v <- Ms.lvars spec])-makeLazy vs (_, spec) = fmap fst <$> (varSymbols id "Lazy" vs $ [(v, ()) | v <- S.toList $ Ms.lazy spec])-makeHMeas vs (_, spec) = fmap fst <$> (varSymbols id "HMeas" vs $ [(v, loc v) | v <- S.toList $ Ms.hmeas spec])-makeTExpr vs (_, spec) = varSymbols id "TermExpr" vs $ Ms.termexprs spec--varSymbols :: ([Var] -> [Var]) -> Symbol -> [Var] -> [(LocSymbol, a)] -> BareM [(Var, a)]-varSymbols f n vs = concatMapM go- where lvs = M.map L.sort $ group [(sym v, locVar v) | v <- vs]- sym = dropModuleNames . symbol . showPpr- locVar v = (getSourcePos v, v)- go (s, ns) = case M.lookup (val s) lvs of - Just lvs -> return ((, ns) <$> varsAfter f s lvs)- Nothing -> ((:[]).(,ns)) <$> lookupGhcVar s- msg s = printf "%s: %s for Undefined Var %s"- (symbolString n) (show (loc s)) (show (val s))--varsAfter f s lvs - | eqList (fst <$> lvs) = f (snd <$> lvs)- | otherwise = map snd $ takeEqLoc $ dropLeLoc lvs- where- takeEqLoc xs@((l, _):_) = L.takeWhile ((l==) . fst) xs- takeEqLoc [] = []- dropLeLoc = L.dropWhile ((loc s >) . fst)- eqList [] = True- eqList (x:xs) = all (==x) xs---- EFFECTS: TODO is this the SAME as addTyConInfo? No. `txRefSort`--- (1) adds the _real_ sorts to RProp,--- (2) gathers _extra_ RProp at turnst them into refinements,--- e.g. tests/pos/multi-pred-app-00.hs-txRefSort tyi tce = mapBot (addSymSort tce tyi)--addSymSort tce tyi t@(RApp rc@(RTyCon c _ _) ts rs r) - = RApp rc ts (zipWith addSymSortRef pvs rargs) r'- where- rc' = appRTyCon tce tyi rc ts- pvs = rTyConPVs rc' - rs' = zipWith addSymSortRef pvs rargs- (rargs, rrest) = splitAt (length pvs) rs- r' = L.foldl' go r rrest- go r (RPropP _ r') = r' `meet` r- go _ (RHProp _ _ ) = errorstar "TODO:EFFECTS:addSymSort"- go r _ = errorstar "YUCKER" -- r--addSymSort _ _ t - = t--addSymSortRef _ (RHProp _ _) = errorstar "TODO:EFFECTS:addSymSortRef"-addSymSortRef p r | isPropPV p = addSymSortRef' p r - | otherwise = errorstar "addSymSortRef: malformed ref application"---addSymSortRef' p (RProp s (RVar v r)) | isDummy v- = RProp xs t- where- t = ofRSort (pvType p) `strengthen` r- xs = spliceArgs "addSymSortRef 1" s p--addSymSortRef' p (RProp s t) - = RProp xs t- where- xs = spliceArgs "addSymSortRef 2" s p---- EFFECTS: why can't we replace the next two equations with (breaks many tests)------ EFFECTS: addSymSortRef' (PV _ (PVProp t) _ ptxs) (RPropP s r@(U _ (Pr [up]) _)) --- EFFECTS: = RProp xts $ (ofRSort t) `strengthen` r--- EFFECTS: where--- EFFECTS: xts = safeZip "addRefSortMono" xs ts--- EFFECTS: xs = snd3 <$> pargs up--- EFFECTS: ts = fst3 <$> ptxs--- --- EFFECTS: addSymSortRef' (PV _ (PVProp t) _ _) (RPropP s r)--- EFFECTS: = RProp s $ (ofRSort t) `strengthen` r--addSymSortRef' p (RPropP s r@(U _ (Pr [up]) _)) - = RPropP xts r- where- xts = safeZip "addRefSortMono" xs ts- xs = snd3 <$> pargs up- ts = fst3 <$> pargs p--addSymSortRef' p (RPropP s r)- = RPropP s r--addSymSortRef' _ _- = errorstar "TODO:EFFECTS:addSymSortRef'"--spliceArgs msg s p = safeZip msg (fst <$> s) (fst3 <$> pargs p) -varMeasures vars = [ (symbol v, varSpecType v) | v <- vars, isDataConWorkId v, isSimpleType $ varType v ]-varSpecType v = Loc (getSourcePos v) (ofType $ varType v)-isSimpleType t = null tvs && isNothing (splitFunTy_maybe tb) where (tvs, tb) = splitForAllTys t ------------------------------------------------------------------------------------ Renaming Type Variables in Haskell Signatures ----------------------------------------------------------------------------------------------------------------data MapTyVarST = MTVST { vmap :: [(Var, RTyVar)]- , errmsg :: Error - }--initMapSt = MTVST []--runMapTyVars :: StateT MapTyVarST (Either Error) () -> MapTyVarST -> Either Error MapTyVarST-runMapTyVars x s = execStateT x s--mapTyVars :: (PPrint r, Reftable r) => Type -> RRType r -> StateT MapTyVarST (Either Error) ()-mapTyVars τ (RAllT a t) - = mapTyVars τ t-mapTyVars (ForAllTy α τ) t - = mapTyVars τ t-mapTyVars (FunTy τ τ') (RFun _ t t' _) - = mapTyVars τ t >> mapTyVars τ' t'-mapTyVars (TyConApp _ τs) (RApp _ ts _ _) - = zipWithM_ mapTyVars τs ts-mapTyVars (TyVarTy α) (RVar a _) - = do s <- get- s' <- mapTyRVar α a s- put s'-mapTyVars τ (RAllP _ t) - = mapTyVars τ t -mapTyVars τ (RAllS _ t) - = mapTyVars τ t -mapTyVars τ (RAllE _ _ t) - = mapTyVars τ t -mapTyVars τ (REx _ _ t)- = mapTyVars τ t -mapTyVars τ (RExprArg _)- = return ()-mapTyVars (AppTy τ τ') (RAppTy t t' _) - = do mapTyVars τ t - mapTyVars τ' t' -mapTyVars τ (RHole _)- = return ()-mapTyVars τ t- = throwError =<< errmsg <$> get--mapTyRVar α a s@(MTVST αas err)- = case lookup α αas of- Just a' | a == a' -> return s- | otherwise -> throwError err- Nothing -> return $ MTVST ((α,a):αas) err--mkVarExpr v - | isFunVar v = EApp (varFunSymbol v) []- | otherwise = EVar (symbol v)--varFunSymbol = dummyLoc . dataConSymbol . idDataCon --isFunVar v = isDataConWorkId v && not (null αs) && isNothing tf- where- (αs, t) = splitForAllTys $ varType v - tf = splitFunTy_maybe t- --- meetDataConSpec :: [(Var, SpecType)] -> [(DataCon, DataConP)] -> [(Var, SpecType)]-meetDataConSpec xts dcs = M.toList $ L.foldl' upd dcm xts - where - dcm = M.fromList $ dataConSpec dcs- upd dcm (x, t) = M.insert x (maybe t (meetPad t) (M.lookup x dcm)) dcm- strengthen (x,t) = (x, maybe t (meetPad t) (M.lookup x dcm))----- dataConSpec :: [(DataCon, DataConP)] -> [(Var, SpecType)]-dataConSpec :: [(DataCon, DataConP)]-> [(Var, (RType Class RTyCon RTyVar RReft))]-dataConSpec dcs = concatMap mkDataConIdsTy [(dc, dataConPSpecType dc t) | (dc, t) <- dcs]--meetPad t1 t2 = -- traceShow ("meetPad: " ++ msg) $- case (bkUniv t1, bkUniv t2) of- ((_, π1s, ls1, _), (α2s, [], ls2, t2')) -> meet t1 (mkUnivs α2s π1s (ls1 ++ ls2) t2')- ((α1s, [], ls1, t1'), (_, π2s, ls2, _)) -> meet (mkUnivs α1s π2s (ls1 ++ ls2) t1') t2- _ -> errorstar $ "meetPad: " ++ msg- where msg = "\nt1 = " ++ showpp t1 ++ "\nt2 = " ++ showpp t2- --------------------------------------------------------------------------------------- | Error-Reader-IO For Bare Transformation ----------------------------------------------------------------------------------------------------------------------------- FIXME: don't use WriterT [], very slow-type BareM a = WriterT [Warn] (ErrorT Error (StateT BareEnv IO)) a--type Warn = String--type TCEnv = M.HashMap TyCon RTyCon--data BareEnv = BE { modName :: !ModName- , tcEnv :: !TCEnv- , rtEnv :: !RTEnv- , varEnv :: ![(Symbol,Var)]- , hscEnv :: HscEnv }--setModule m b = b { modName = m }--inModule m act = do- old <- gets modName- modify $ setModule m- res <- act- modify $ setModule old- return res--withVArgs l vs act = do- old <- gets rtEnv- mapM_ (mkExprAlias l . symbol . showpp) vs- res <- act- modify $ \be -> be { rtEnv = old }- return res--addSym x = modify $ \be -> be { varEnv = (varEnv be) `L.union` [x] }--mkExprAlias l v- = setRTAlias v (Right (RTA v [] [] (RExprArg (EVar $ symbol v)) l))--setRTAlias s a =- modify $ \b -> b { rtEnv = mapRT (M.insert s a) $ rtEnv b }--setRPAlias s a =- modify $ \b -> b { rtEnv = mapRP (M.insert s a) $ rtEnv b }--setREAlias s a =- modify $ \b -> b { rtEnv = mapRE (M.insert s a) $ rtEnv b }---------------------------------------------------------------------execBare :: BareM a -> BareEnv -> IO (Either Error a)--------------------------------------------------------------------execBare act benv = - do z <- evalStateT (runErrorT (runWriterT act)) benv `Ex.catch` (return . Left)- case z of- Left s -> return $ Left s- Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++) - return $ Right x----------------------------------------------------------------------- | API: Bare Refinement Types -------------------------------------------------------------------------------------------------------makeMeasureSpec :: (ModName, Ms.Spec BareType LocSymbol) -> BareM (Ms.MSpec SpecType DataCon)-makeMeasureSpec (mod,spec) = inModule mod mkSpec- where- mkSpec = mkMeasureDCon =<< mkMeasureSort =<< m- m = Ms.mkMSpec <$> (mapM expandRTAliasMeasure $ Ms.measures spec)- <*> return (Ms.cmeasures spec)- <*> (mapM expandRTAliasMeasure $ Ms.imeasures spec)--makeMeasureSpec' = mapFst (mapSnd uRType <$>) . Ms.dataConTypes . first (mapReft ur_reft)--makeClassMeasureSpec (Ms.MSpec {..}) = tx <$> M.elems cmeasMap- where- tx (M n s _) = (n, CM n (mapReft ur_reft s) -- [(t,m) | (IM n' t m) <- imeas, n == n']- )--makeTargetVars :: ModName -> [Var] -> [String] -> BareM [Var]-makeTargetVars name vs ss- = do env <- gets hscEnv- ns <- liftIO $ concatMapM (lookupName env name . dummyLoc . prefix) ss- return $ filter ((`elem` ns) . varName) vs- where- prefix s = qualifySymbol (symbol name) (symbol s)---makeAssertSpec cmod cfg vs lvs (mod,spec)- | cmod == mod- = makeLocalSpec cfg cmod vs lvs (Ms.sigs spec ++ Ms.localSigs spec)- | otherwise- = inModule mod $ makeSpec cfg vs $ Ms.sigs spec--makeAssumeSpec cmod cfg vs lvs (mod,spec)- | cmod == mod- = makeLocalSpec cfg cmod vs lvs $ Ms.asmSigs spec- | otherwise- = inModule mod $ makeSpec cfg vs $ Ms.asmSigs spec--makeDefaultMethods :: [Var] -> [(ModName,Var,Located SpecType)]- -> [(ModName,Var,Located SpecType)]-makeDefaultMethods defVs sigs- = [ (m,dmv,t)- | dmv <- defVs- , let dm = symbol $ showPpr dmv- , "$dm" `isPrefixOfSym` (dropModuleNames dm)- , let mod = takeModuleNames dm- , let method = qualifySymbol mod $ dropSym 3 (dropModuleNames dm)- , let mb = L.find ((method `isPrefixOfSym`) . symbol . snd3) sigs- , isJust mb- , let Just (m,_,t) = mb- ]--makeLocalSpec :: Config -> ModName -> [Var] -> [Var] -> [(LocSymbol, BareType)]- -> BareM [(ModName, Var, Located SpecType)]-makeLocalSpec cfg mod vs lvs xbs- = do env <- get- vbs1 <- fmap expand3 <$> varSymbols fchoose "Var" lvs (dupSnd <$> xbs1)- unless (noCheckUnknown cfg) $ checkDefAsserts env vbs1 xbs1- vts1 <- map (addFst3 mod) <$> mapM mkVarSpec vbs1- vts2 <- makeSpec cfg vs xbs2- return $ vts1 ++ vts2- where- (xbs1, xbs2) = L.partition (modElem mod . fst) xbs- dupSnd (x, y) = (dropMod x, (x, y))- expand3 (x, (y, w)) = (x, y, w)- dropMod = fmap (dropModuleNames . symbol)- fchoose ls = maybe ls (:[]) $ L.find (`elem` vs) ls- modElem n x = (takeModuleNames $ val x) == (symbol n)--makeSpec :: Config -> [Var] -> [(LocSymbol, BareType)]- -> BareM [(ModName, Var, Located SpecType)]-makeSpec cfg vs xbs- = do vbs <- map (joinVar vs) <$> lookupIds xbs- env@(BE { modName = mod}) <- get- unless (noCheckUnknown cfg) $ checkDefAsserts env vbs xbs- map (addFst3 mod) <$> mapM mkVarSpec vbs---- the Vars we lookup in GHC don't always have the same tyvars as the Vars--- we're given, so return the original var when possible.--- see tests/pos/ResolvePred.hs for an example-joinVar vs (v,s,t) = case L.find ((== showPpr v) . showPpr) vs of- Just v' -> (v',s,t)- Nothing -> (v,s,t)--lookupIds = mapM lookup- where- lookup (s, t) = (,s,t) <$> lookupGhcVar s--checkDefAsserts :: BareEnv -> [(Var, LocSymbol, BareType)] -> [(LocSymbol, BareType)] -> BareM ()-checkDefAsserts env vbs xbs = applyNonNull (return ()) grumble undefSigs- where- undefSigs = [x | (x, _) <- assertSigs, not (x `S.member` definedSigs)]- assertSigs = filter isTarget xbs- definedSigs = S.fromList $ snd3 <$> vbs- grumble = mapM_ (warn . berrUnknownVar)- moduleName = symbol $ modName env- isTarget = isPrefixOfSym moduleName . stripParensSym . val . fst--warn x = tell [x]---mkVarSpec :: (Var, LocSymbol, BareType) -> BareM (Var, Located SpecType)-mkVarSpec (v, Loc l _, b) = tx <$> mkSpecType l b- where- tx = (v,) . Loc l . generalize--plugHoles tce tyi x f t (Loc l st) - = do tyvsmap <- case runMapTyVars (mapTyVars (toType rt') st'') initvmap of- Left e -> throwError e- Right s -> return $ vmap s- let su = [(y, rTyVar x) | (x, y) <- tyvsmap]- st''' = subts su st''- ps' = fmap (subts su') <$> ps- su' = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]- Loc l . mkArrow αs ps' (ls1 ++ ls2) cs' <$> go rt' st'''- where- (αs, _, ls1, rt) = bkUniv (ofType t :: SpecType)- (cs, rt') = bkClass rt-- (_, ps, ls2, st') = bkUniv st- (_, st'') = bkClass st'- cs' = [(dummySymbol, RApp c t [] mempty) | (c,t) <- cs]- initvmap = initMapSt $ ErrMismatch (sourcePosSrcSpan l) (pprint x) t st-- go :: SpecType -> SpecType -> BareM SpecType- go t (RHole r) = return $ (addHoles t') { rt_reft = f r }- where- t' = everywhere (mkT $ addRefs tce tyi) t- addHoles = fmap (const $ f $ uReft ("v", [hole]))- go (RVar _ _) v@(RVar _ _) = return v- go (RFun _ i o _) (RFun x i' o' r) = RFun x <$> go i i' <*> go o o' <*> return r- go (RAllT _ t) (RAllT a t') = RAllT a <$> go t t'- go t (RAllE b a t') = RAllE b a <$> go t t'- go t (REx b x t') = REx b x <$> go t t'- go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy <$> go t1 t1' <*> go t2 t2' <*> return r- go (RApp _ t _ _) (RApp c t' p r) = RApp c <$> (zipWithM go t t') <*> return p <*> return r- go t st = throwError err- where- err = errOther $ text $ printf "plugHoles: unhandled case!\nt = %s\nst = %s\n" (showpp t) (showpp st)--addRefs :: TCEmb TyCon- -> M.HashMap TyCon RTyCon- -> SpecType- -> SpecType-addRefs tce tyi (RApp c ts _ r) = RApp c' ts ps r- where- RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r)- ps' = safeZip "addRefHoles" ps (rTyConPVs c')-addRefs _ _ t = t--showTopLevelVars vs = - forM vs $ \v -> - when (isExportedId v) $- donePhase Loud ("Exported: " ++ showPpr v)--------------------------------------------------------------------------makeTyConEmbeds (mod, spec)- = inModule mod $ makeTyConEmbeds' $ Ms.embeds spec--makeTyConEmbeds' :: TCEmb (Located Symbol) -> BareM (TCEmb TyCon)-makeTyConEmbeds' z = M.fromList <$> mapM tx (M.toList z)- where - tx (c, y) = (, y) <$> lookupGhcTyCon c--makeIAliases (mod, spec)- = inModule mod $ makeIAliases' $ Ms.ialiases spec--makeIAliases' :: [(Located BareType, Located BareType)] -> BareM [(Located SpecType, Located SpecType)]-makeIAliases' ts = mapM mkIA ts- where - mkIA (t1, t2) = liftM2 (,) (mkI t1) (mkI t2)- mkI (Loc l t) = (Loc l) . generalize <$> mkSpecType l t--makeInvariants (mod,spec)- = inModule mod $ makeInvariants' $ Ms.invariants spec--makeInvariants' :: [Located BareType] -> BareM [Located SpecType]-makeInvariants' ts = mapM mkI ts- where - mkI (Loc l t) = (Loc l) . generalize <$> mkSpecType l t--mkSpecType l t = mkSpecType' l (ty_preds $ toRTypeRep t) t--mkSpecType' :: SourcePos -> [PVar BSort] -> BareType -> BareM SpecType-mkSpecType' l πs = expandRTAlias l . txParams subvUReft (uPVar <$> πs)---- WTF does this function do?-makeSymbols vs xs' xts yts ivs- = do svs <- gets varEnv- return [ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)]- where- xs = sortNub $ zs ++ zs' ++ zs''- zs = concatMap freeSymbols (snd <$> xts) `sortDiff` xs'- zs' = concatMap freeSymbols (snd <$> yts) `sortDiff` xs'- zs'' = concatMap freeSymbols ivs `sortDiff` xs'- -freeSymbols ty = sortNub $ concat $ efoldReft (\_ _ -> []) (\ _ -> ()) f (\_ -> id) emptySEnv [] (val ty)- where - f γ _ r xs = let Reft (v, _) = toReft r in - [ x | x <- syms r, x /= v, not (x `memberSEnv` γ)] : xs-------------------------------------------------------------------------- Querying GHC for Id, Type, Class, Con etc. -----------------------------------------------------------------------------------class Symbolic a => GhcLookup a where- lookupName :: HscEnv -> ModName -> a -> IO [Name]- srcSpan :: a -> SrcSpan--instance GhcLookup (Located Symbol) where- lookupName e m = symbolLookup e m . val- srcSpan = sourcePosSrcSpan . loc--instance GhcLookup Name where- lookupName _ _ = return . (:[])- srcSpan = nameSrcSpan---- lookupGhcThing :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM b-lookupGhcThing name f x- = do zs <- lookupGhcThing' name f x- case zs of- Just x' -> return x'- Nothing -> throwError $ ErrGhc (srcSpan x) (text msg)- where- msg = "Not in scope: " ++ name ++ " `" ++ symbolString (symbol x) ++ "'"---- lookupGhcThing' :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM (Maybe b)-lookupGhcThing' _ f x- = do (BE mod _ _ _ env) <- get- ns <- liftIO $ lookupName env mod x- mts <- liftIO $ mapM (fmap (join . fmap f) . hscTcRcLookupName env) ns- case catMaybes mts of- [] -> return Nothing- (t:_) -> return $ Just t--symbolLookup :: HscEnv -> ModName -> Symbol -> IO [Name]-symbolLookup env mod k- | k `M.member` wiredIn- = return $ maybeToList $ M.lookup k wiredIn- | otherwise- = symbolLookupEnv env mod k--symbolLookupEnv env mod s- | isSrcImport mod- = do let modName = getModName mod- L _ rn <- hscParseIdentifier env $ symbolString s- res <- lookupRdrName env modName rn- -- 'hscParseIdentifier' defaults constructors to 'DataCon's, but we also- -- need to get the 'TyCon's for declarations like @data Foo = Foo Int@.- res' <- lookupRdrName env modName (setRdrNameSpace rn tcName)- return $ catMaybes [res, res']- | otherwise- = do L _ rn <- hscParseIdentifier env $ symbolString s- (_, lookupres) <- tcRnLookupRdrName env rn- case lookupres of- Just ns -> return ns- _ -> return []---- | It's possible that we have already resolved the 'Name' we are looking for,--- but have had to turn it back into a 'String', e.g. to be used in an 'Expr',--- as in @{v:Ordering | v = EQ}@. In this case, the fully-qualified 'Name'--- (@GHC.Types.EQ@) will likely not be in scope, so we store our own mapping of--- fully-qualified 'Name's to 'Var's and prefer pulling 'Var's from it.-lookupGhcVar :: GhcLookup a => a -> BareM Var-lookupGhcVar x- = do env <- gets varEnv- case L.lookup (symbol x) env of- Nothing -> lookupGhcThing "variable" fv x- Just v -> return v- where- fv (AnId x) = Just x- fv (AConLike (RealDataCon x)) = Just $ dataConWorkId x- fv _ = Nothing--lookupGhcTyCon :: GhcLookup a => a -> BareM TyCon-lookupGhcTyCon s = (lookupGhcThing "type constructor or class" ftc s)- `catchError` (tryPropTyCon s)- where - ftc (ATyCon x) = Just x- ftc _ = Nothing--tryPropTyCon s e - | sx == propConName = return propTyCon- | sx == hpropConName = return hpropTyCon- | otherwise = throwError e- where- sx = symbol s- -lookupGhcClass = lookupGhcThing "class" ftc- where - ftc (ATyCon x) = tyConClass_maybe x - ftc _ = Nothing--lookupGhcDataCon dc = case isTupleDC $ val dc of- Just n -> return $ tupleCon BoxedTuple n- Nothing -> lookupGhcDataCon' dc --isTupleDC zs- | "(," `isPrefixOfSym` zs- = Just $ lengthSym zs - 1- | otherwise- = Nothing--lookupGhcDataCon' = lookupGhcThing "data constructor" fdc- where - fdc (AConLike (RealDataCon x)) = Just x- fdc _ = Nothing--wiredIn :: M.HashMap Symbol Name-wiredIn = M.fromList $ special ++ wiredIns - where- wiredIns = [ (symbol n, n) | thing <- wiredInThings, let n = getName thing ]- special = [ ("GHC.Integer.smallInteger", smallIntegerName)- , ("GHC.Num.fromInteger" , fromIntegerName ) ]--class Resolvable a where- resolve :: SourcePos -> a -> BareM a--instance Resolvable a => Resolvable [a] where- resolve = mapM . resolve--instance Resolvable Qualifier where- resolve _ (Q n ps b l) = Q n <$> mapM (secondM (resolve l)) ps <*> resolve l b <*> return l--instance Resolvable Pred where- resolve l (PAnd ps) = PAnd <$> resolve l ps- resolve l (POr ps) = POr <$> resolve l ps- resolve l (PNot p) = PNot <$> resolve l p- resolve l (PImp p q) = PImp <$> resolve l p <*> resolve l q- resolve l (PIff p q) = PIff <$> resolve l p <*> resolve l q- resolve l (PBexp b) = PBexp <$> resolve l b- resolve l (PAtom r e1 e2) = PAtom r <$> resolve l e1 <*> resolve l e2- resolve l (PAll vs p) = PAll <$> mapM (secondM (resolve l)) vs <*> resolve l p- resolve _ p = return p--instance Resolvable Expr where- resolve l (EVar s) = EVar <$> resolve l s- resolve l (EApp s es) = EApp <$> resolve l s <*> resolve l es- resolve l (EBin o e1 e2) = EBin o <$> resolve l e1 <*> resolve l e2- resolve l (EIte p e1 e2) = EIte <$> resolve l p <*> resolve l e1 <*> resolve l e2- resolve l (ECst x s) = ECst <$> resolve l x <*> resolve l s- resolve l x = return x--instance Resolvable LocSymbol where- resolve _ ls@(Loc l s)- | s `elem` prims - = return ls- | otherwise - = do env <- gets (typeAliases . rtEnv)- case M.lookup s env of- Nothing | isCon s -> do v <- lookupGhcVar $ Loc l s- let qs = symbol v- addSym (qs,v)- return $ Loc l qs- _ -> return ls--isCon c - | Just (c,cs) <- T.uncons $ symbolText c = isUpper c- | otherwise = False--instance Resolvable Symbol where- resolve l x = fmap val $ resolve l $ Loc l x --instance Resolvable Sort where- resolve _ FInt = return FInt- resolve _ FNum = return FNum- resolve _ s@(FObj _) = return s --FObj . S <$> lookupName env m s- resolve _ s@(FVar _) = return s- resolve l (FFunc i ss) = FFunc i <$> resolve l ss- resolve _ (FApp tc ss)- | tcs' `elem` prims = FApp tc <$> ss'- | otherwise = FApp <$> (symbolFTycon.Loc l.symbol <$> lookupGhcTyCon tcs) <*> ss'- where- tcs@(Loc l tcs') = fTyconSymbol tc- ss' = resolve l ss--instance Resolvable (UReft Reft) where- resolve l (U r p s) = U <$> resolve l r <*> resolve l p <*> return s--instance Resolvable Reft where- resolve l (Reft (s, ras)) = Reft . (s,) <$> mapM resolveRefa ras- where- resolveRefa (RConc p) = RConc <$> resolve l p- resolveRefa kv = return kv--instance Resolvable Predicate where- resolve l (Pr pvs) = Pr <$> resolve l pvs--instance (Resolvable t) => Resolvable (PVar t) where- resolve l (PV n t v as) = PV n t v <$> mapM (third3M (resolve l)) as--instance Resolvable () where- resolve l = return ----------------------------------------------------------------------------- Predicate Types for WiredIns -------------------------------------------------------------------------------------------------------maxArity :: Arity -maxArity = 7--wiredTyCons = fst wiredTyDataCons-wiredDataCons = snd wiredTyDataCons--wiredTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, Located DataConP)])-wiredTyDataCons = (concat tcs, mapSnd dummyLoc <$> concat dcs)- where - (tcs, dcs) = unzip l- l = [listTyDataCons] ++ map tupleTyDataCons [2..maxArity]--listTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)])-listTyDataCons = ( [(c, TyConP [(RTV tyv)] [p] [] [0] [] (Just fsize))]- , [(nilDataCon, DataConP l0 [(RTV tyv)] [p] [] [] [] lt)- , (consDataCon, DataConP l0 [(RTV tyv)] [p] [] [] cargs lt)])- where- l0 = dummyPos "LH.Bare.listTyDataCons"- c = listTyCon- [tyv] = tyConTyVars c- t = rVar tyv :: RSort- fld = "fldList"- x = "xListSelector"- xs = "xsListSelector"- p = PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar fld)]- px = pdVarReft $ PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar x)] - lt = rApp c [xt] [RPropP [] $ pdVarReft p] mempty - xt = rVar tyv- xst = rApp c [RVar (RTV tyv) px] [RPropP [] $ pdVarReft p] mempty- cargs = [(xs, xst), (x, xt)]- fsize = \x -> EApp (dummyLoc "len") [EVar x]--tupleTyDataCons :: Int -> ([(TyCon, TyConP)] , [(DataCon, DataConP)])-tupleTyDataCons n = ( [(c, TyConP (RTV <$> tyvs) ps [] [0..(n-2)] [] Nothing)]- , [(dc, DataConP l0 (RTV <$> tyvs) ps [] [] cargs lt)])- where - l0 = dummyPos "LH.Bare.tupleTyDataCons"- c = tupleTyCon BoxedTuple n- dc = tupleCon BoxedTuple n - tyvs@(tv:tvs) = tyConTyVars c- (ta:ts) = (rVar <$> tyvs) :: [RSort]- flds = mks "fld_Tuple"- fld = "fld_Tuple"- x1:xs = mks ("x_Tuple" ++ show n)- ps = mkps pnames (ta:ts) ((fld, EVar fld):(zip flds (EVar <$>flds)))- ups = uPVar <$> ps- pxs = mkps pnames (ta:ts) ((fld, EVar x1):(zip flds (EVar <$> xs)))- lt = rApp c (rVar <$> tyvs) (RPropP [] . pdVarReft <$> ups) mempty- xts = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs- cargs = reverse $ (x1, rVar tv) : (zip xs xts)- pnames = mks_ "p"- mks x = (\i -> symbol (x++ show i)) <$> [1..n]- mks_ x = (\i -> symbol (x++ show i)) <$> [2..n]---pdVarReft = (\p -> U mempty p mempty) . pdVar --mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] []-mkps _ _ _ = error "Bare : mkps"--mkps_ [] _ _ _ ps = ps-mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps)- where- p = PV n (PVProp t) (vv Nothing) args- a = (t, f, x)-mkps_ _ _ _ _ _ = error "Bare : mkps_"----------------------------------------------------------------------------- | Transforming Raw Strings using GHC Env ------------------------------------------------------------------------------------------------------ofBareType :: (PPrint r, Reftable r) => BRType r -> BareM (RRType r)--------------------------------------------------------------------------ofBareType (RVar a r) - = return $ RVar (symbolRTyVar a) r-ofBareType (RFun x t1 t2 _) - = liftM2 (rFun x) (ofBareType t1) (ofBareType t2)-ofBareType t@(RAppTy t1 t2 r) - = liftM3 RAppTy (ofBareType t1) (ofBareType t2) (return r)-ofBareType (RAllE x t1 t2)- = liftM2 (RAllE x) (ofBareType t1) (ofBareType t2)-ofBareType (REx x t1 t2)- = liftM2 (REx x) (ofBareType t1) (ofBareType t2)-ofBareType (RAllT a t) - = liftM (RAllT (symbolRTyVar a)) (ofBareType t)-ofBareType (RAllP π t) - = liftM2 RAllP (ofBPVar π) (ofBareType t)-ofBareType (RAllS s t) - = liftM (RAllS s) (ofBareType t)-ofBareType (RApp tc ts@[_] rs r) - | isList tc- = do tyi <- tcEnv <$> get- liftM2 (bareTCApp tyi r listTyCon) (mapM ofRef rs) (mapM ofBareType ts)-ofBareType (RApp tc ts rs r) - | isTuple tc- = do tyi <- tcEnv <$> get- liftM2 (bareTCApp tyi r c) (mapM ofRef rs) (mapM ofBareType ts)- where c = tupleTyCon BoxedTuple (length ts)-ofBareType (RApp tc ts rs r) - = do tyi <- tcEnv <$> get- liftM3 (bareTCApp tyi r) (lookupGhcTyCon tc) (mapM ofRef rs) (mapM ofBareType ts)-ofBareType (ROth s)- = return $ ROth s-ofBareType (RHole r)- = return $ RHole r-ofBareType t- = errorstar $ "Bare : ofBareType cannot handle " ++ show t--ofRef (RProp ss t) - = RProp <$> mapM ofSyms ss <*> ofBareType t-ofRef (RPropP ss r) - = (`RPropP` r) <$> mapM ofSyms ss-ofRef (RHProp _ _)- = errorstar "TODO:EFFECTS:ofRef"---ofSyms (x, t)- = liftM ((,) x) (ofBareType t)--tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `meet` r')-tyApp t [] [] r = t `strengthen` r--bareTCApp _ r c rs ts | Just (SynonymTyCon rhs) <- synTyConRhs_maybe c- = tyApp (subsTyVars_meet su $ ofType rhs) (drop nts ts) rs r - where tvs = tyConTyVars c- su = zipWith (\a t -> (rTyVar a, toRSort t, t)) tvs ts- nts = length tvs---- TODO expandTypeSynonyms here to-bareTCApp _ r c rs ts | isFamilyTyCon c && isTrivial t- = expandRTypeSynonyms $ t `strengthen` r - where t = rApp c ts rs mempty--bareTCApp _ r c rs ts - = rApp c ts rs r--expandRTypeSynonyms = ofType . expandTypeSynonyms . toType--symbolRTyVar = rTyVar . stringTyVar . symbolString--- stringTyVarTy = TyVarTy . stringTyVar--mkMeasureDCon :: Ms.MSpec t LocSymbol -> BareM (Ms.MSpec t DataCon)-mkMeasureDCon m = (forM (measureCtors m) $ \n -> (val n,) <$> lookupGhcDataCon n)- >>= (return . mkMeasureDCon_ m)--mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(Symbol, DataCon)] -> Ms.MSpec t DataCon-mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}- where - m' = fmap (tx.val) m- cm' = hashMapMapKeys (tx' . tx) $ Ms.ctorMap m'- tx = mlookup (M.fromList ndcs)- tx' = dataConSymbol--measureCtors :: Ms.MSpec t LocSymbol -> [LocSymbol]-measureCtors = sortNub . fmap ctor . concat . M.elems . Ms.ctorMap---- mkMeasureSort :: (PVarable pv, Reftable r) => Ms.MSpec (BRType pv r) bndr-> BareM (Ms.MSpec (RRType pv r) bndr)-mkMeasureSort (Ms.MSpec c mm cm im)- = Ms.MSpec c <$> forM mm tx <*> forM cm tx <*> forM im tx- where- tx m = liftM (\s' -> m {sort = s'}) (ofBareType (sort m))------------------------------------------------------------------------------ | LH Primitive TyCons ------------------------------------------------------------------------------------------------------------------------propTyCon, hpropTyCon :: TyCon -propTyCon = symbolTyCon 'w' 24 propConName-hpropTyCon = symbolTyCon 'w' 24 hpropConName ------------------------------------------------------------------------------------------ Bare Predicate: DataCon Definitions --------------------------------------------------------------------------------------------makeConTypes (name,spec) = inModule name $ makeConTypes' $ Ms.dataDecls spec--makeConTypes' :: [DataDecl] -> BareM ([(TyCon, TyConP)], [[(DataCon, Located DataConP)]])-makeConTypes' dcs = unzip <$> mapM ofBDataDecl dcs--ofBDataDecl :: DataDecl -> BareM ((TyCon, TyConP), [(DataCon, Located DataConP)])-ofBDataDecl (D tc as ps ls cts pos sfun)- = do πs <- mapM ofBPVar ps- tc' <- lookupGhcTyCon tc- cts' <- mapM (ofBDataCon lc tc' αs ps ls πs) cts- let tys = [t | (_, dcp) <- cts', (_, t) <- tyArgs dcp]- let initmap = zip (uPVar <$> πs) [0..]- let varInfo = concatMap (getPsSig initmap True) tys- let neutral = [0 .. (length πs)] L.\\ (fst <$> varInfo)- let cov = neutral ++ [i | (i, b)<- varInfo, b, i >=0]- let contr = neutral ++ [i | (i, b)<- varInfo, not b, i >=0]- return ((tc', TyConP αs πs ls cov contr sfun), (mapSnd (Loc lc) <$> cts'))- where - αs = RTV . symbolTyVar <$> as- lc = loc tc--getPsSig m pos (RAllT _ t) - = getPsSig m pos t-getPsSig m pos (RApp _ ts rs r) - = addps m pos r ++ concatMap (getPsSig m pos) ts - ++ concatMap (getPsSigPs m pos) rs-getPsSig m pos (RVar _ r) - = addps m pos r-getPsSig m pos (RAppTy t1 t2 r) - = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2-getPsSig m pos (RFun _ t1 t2 r) - = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1-getPsSig m pos (RHole r)- = addps m pos r -getPsSig m pos z - = error $ "getPsSig" ++ show z- --getPsSigPs m pos (RPropP _ r) = addps m pos r-getPsSigPs m pos (RProp _ t) = getPsSig m pos t-getPsSigPs _ _ (RHProp _ _) = errorstar "TODO:EFFECTS:getPsSigPs"--addps m pos (U _ ps _) = (flip (,)) pos . f <$> pvars ps- where f = fromMaybe (error "Bare.addPs: notfound") . (`L.lookup` m) . uPVar--- ofBPreds = fmap (fmap stringTyVarTy)-dataDeclTyConP d - = do let αs = fmap (RTV . symbolTyVar) (tycTyVars d) -- as- πs <- mapM ofBPVar (tycPVars d) -- ps- tc' <- lookupGhcTyCon (tycName d) -- tc- return $ (tc', TyConP αs πs)---- ofBPreds = fmap (fmap stringTyVarTy)-ofBPVar :: PVar BSort -> BareM (PVar RSort)-ofBPVar = mapM_pvar ofBareType --mapM_pvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b)-mapM_pvar f (PV x t v txys) - = do t' <- forM t f - txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys - return $ PV x t' v txys'---- TODO:EFFECTS:ofBDataCon-ofBDataCon l tc αs ps ls πs (c, xts)- = do c' <- lookupGhcDataCon c- ts' <- mapM (mkSpecType' l ps) ts- let cs = map ofType (dataConStupidTheta c')- let t0 = rApp tc rs (RPropP [] . pdVarReft <$> πs) mempty - return $ (c', DataConP l αs πs ls cs (reverse (zip xs ts')) t0)- where - (xs, ts) = unzip xts- rs = [rVar α | RTV α <- αs]------------------------------------------------------------------------------------------ Bare Predicate: RefTypes -------------------------------------------------------------------------------------------------------txParams f πs t = mapReft (f (txPvar (predMap πs t))) t--txPvar :: M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar -txPvar m π = π { pargs = args' }- where args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)- | otherwise = pargs π'- π' = fromMaybe (errorstar err) $ M.lookup (pname π) m- err = "Bare.replaceParams Unbound Predicate Variable: " ++ show π--predMap πs t = {-Ex.assert (M.size xπm == length xπs)-} xπm- where xπm = M.fromList xπs- xπs = [(pname π, π) | π <- πs ++ rtypePredBinds t]--rtypePredBinds = map uPVar . ty_preds . toRTypeRep---- rtypePredBinds t = everything (++) ([] `mkQ` grab) t--- where grab ((RAllP pv _) :: BRType RPVar RPredicate) = [pv]--- grab _ = []------------------------------------------------------------------------------------------------------ Checking GhcSpec ------------------------------------------------------------------------------------------------------------------------------------------------------------------------checkGhcSpec :: [(ModName, Ms.BareSpec)]- -> GhcSpec -> Either [Error] GhcSpec--checkGhcSpec specs sp = applyNonNull (Right sp) Left errors- where - errors = mapMaybe (checkBind "constructor" emb tcEnv env) (dcons sp)- ++ mapMaybe (checkBind "measure" emb tcEnv env) (meas sp)- ++ mapMaybe (checkInv emb tcEnv env) (invariants sp)- ++ (checkIAl emb tcEnv env) (ialiases sp)- ++ checkMeasures emb env ms- ++ mapMaybe checkMismatch sigs- ++ checkDuplicate (tySigs sp)- ++ checkDuplicate (asmSigs sp)- ++ checkDupIntersect (tySigs sp) (asmSigs sp)- ++ checkRTAliases "Type Alias" env tAliases- ++ checkRTAliases "Pred Alias" env pAliases - -- ++ checkDuplicateRTAlias "Predicate Alias" pAliases - -- ++ checkRTAliasSyms "Predicate Alias" (concat [Ms.paliases sp | (_, sp) <- specs])--- tAliases = concat [Ms.aliases sp | (_, sp) <- specs]- pAliases = concat [Ms.paliases sp | (_, sp) <- specs]- dcons spec = [(v, Loc l t) | (v,t) <- dataConSpec (dconsP spec) - | (_,dcp) <- dconsP spec- , let l = dc_loc dcp- ]- emb = tcEmbeds sp- env = ghcSpecEnv sp- tcEnv = tyconEnv sp- ms = measures sp- sigs = tySigs sp ++ asmSigs sp----- RJ: This is not nice. More than 3 elements should be a record.- -type ReplaceM = ReaderT ( M.HashMap Symbol Symbol- , SEnv SortedReft- , TCEmb TyCon- , M.HashMap TyCon RTyCon- ) (State ( M.HashMap Var (Located SpecType)- , M.HashMap Var [Expr]- ))--replaceLocalBinds :: TCEmb TyCon- -> M.HashMap TyCon RTyCon- -> [(Var, Located SpecType)]- -> [(Var, [Expr])]- -> SEnv SortedReft- -> CoreProgram- -> ([(Var, Located SpecType)], [(Var, [Expr])])-replaceLocalBinds emb tyi sigs texprs senv cbs- = (M.toList s, M.toList t)- where- (s,t) = execState (runReaderT (mapM_ (`traverseBinds` return ()) cbs)- (M.empty, senv, emb, tyi))- (M.fromList sigs, M.fromList texprs)--traverseExprs (Let b e)- = traverseBinds b (traverseExprs e)-traverseExprs (Lam _ e)- = traverseExprs e-traverseExprs (App x y)- = traverseExprs x >> traverseExprs y-traverseExprs (Case e _ _ as)- = traverseExprs e >> mapM_ (traverseExprs . thd3) as-traverseExprs (Cast e _)- = traverseExprs e-traverseExprs (Tick _ e)- = traverseExprs e-traverseExprs _- = return ()--traverseBinds b k- = do (env', fenv', emb, tyi) <- ask- let env = L.foldl' (\m v -> M.insert (takeWhileSym (/='#') $ symbol v) (symbol v) m) env' vs- fenv = L.foldl' (\m v -> insertSEnv (symbol v) (rTypeSortedReft emb (ofType $ varType v :: RSort)) m) fenv' vs- withReaderT (const (env,fenv,emb,tyi)) $ do- mapM_ replaceLocalBindsOne vs- mapM_ traverseExprs es- k- where- vs = bindersOf b- es = rhssOfBind b--replaceLocalBindsOne :: Var -> ReplaceM ()-replaceLocalBindsOne v- = do mt <- gets (M.lookup v . fst)- case mt of- Nothing -> return ()- Just (Loc l (toRTypeRep -> t@(RTypeRep {..}))) -> do- (env',fenv,emb,tyi) <- ask- let f m k = M.lookupDefault k k m- let (env,args) = L.mapAccumL (\e (v,t) -> (M.insert v v e, substa (f e) t))- env' (zip ty_binds ty_args)- let res = substa (f env) ty_res- let t' = fromRTypeRep $ t { ty_args = args, ty_res = res }- let msg = ErrTySpec (sourcePosSrcSpan l) (pprint v) t'- case checkTy msg emb tyi fenv t' of- Just err -> Ex.throw err- Nothing -> modify (first $ M.insert v (Loc l t'))- mes <- gets (M.lookup v . snd)- case mes of- Nothing -> return ()- Just es -> do- let es' = substa (f env) es- case checkExpr "termination" emb fenv (v, Loc l t', es') of- Just err -> Ex.throw err- Nothing -> modify (second $ M.insert v es')-- --checkInv :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> Located SpecType -> Maybe Error-checkInv emb tcEnv env t = checkTy err emb tcEnv env (val t) - where - err = ErrInvt (sourcePosSrcSpan $ loc t) (val t) --checkIAl :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> [(Located SpecType, Located SpecType)] -> [Error]-checkIAl emb tcEnv env ials = catMaybes $ concatMap (checkIAlOne emb tcEnv env) ials--checkIAlOne emb tcEnv env (t1, t2) = checkEq : (tcheck <$> [t1, t2])- where - tcheck t = checkTy (err t) emb tcEnv env (val t)- err t = ErrIAl (sourcePosSrcSpan $ loc t) (val t) - t1' :: RSort - t1' = toRSort $ val t1- t2' :: RSort - t2' = toRSort $ val t2- checkEq = if (t1' == t2') then Nothing else Just errmis- errmis = ErrIAlMis (sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg- emsg = pprint t1 <+> text "does not match with" <+> pprint t2 ---checkRTAliases msg env as = err1s -- ++ err2s- where - err1s = checkDuplicateRTAlias msg as- err2s = concatMap (checkRTAliasWF env) as--checkRTAliasWF env a = {- trace ("checkRTAliasWF: " ++ rtName a) $ -}- mkErr <$> filter (not . ok) aSyms - where- aSyms = {- traceShow ("RTAWF: " ++ aName) $ -} syms $ rtBody a- ok x = memberSEnv x env || x `elem` params - params = symbol <$> rtVArgs a- mkErr = ErrUnbound sp . pprint - sp = sourcePosSrcSpan (rtPos a)- aName = rtName a---checkBind :: (PPrint v) => String -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error -checkBind s emb tcEnv env (v, Loc l t) = checkTy msg emb tcEnv env' t- where - msg = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t - env' = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms--checkExpr :: (Eq v, PPrint v) => String -> TCEmb TyCon -> SEnv SortedReft -> (v, Located SpecType, [Expr])-> Maybe Error -checkExpr s emb env (v, Loc l t, es) = mkErr <$> go es- where - mkErr = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t - go = foldl (\err e -> err <|> checkSorted env' e) Nothing - env' = foldl (\e (x, s) -> insertSEnv x s e) env'' wiredSortedSyms- env'' = mapSEnv sr_sort $ foldl (\e (x,s) -> insertSEnv x s e) env xss- xss = mapSnd rSort <$> (uncurry zip $ dropThd3 $ bkArrowDeep t)- rSort = rTypeSortedReft emb - msg = "Bare.checkExpr " ++ showpp v ++ " not found\n"- ++ "\t Try give a haskell type signature to the recursive function"--checkTy :: (Doc -> Error) -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> SpecType -> Maybe Error-checkTy mkE emb tcEnv env t = mkE <$> checkRType emb env (txRefSort tcEnv emb t)--checkDupIntersect :: [(Var, Located SpecType)] -> [(Var, Located SpecType)] -> [Error]-checkDupIntersect xts mxts = concatMap mkWrn dups- where - mkWrn (x, t) = pprWrn x (sourcePosSrcSpan $ loc t)- dups = L.intersectBy (\x y -> (fst x == fst y)) mxts xts- pprWrn v l = trace ("WARNING: Assume Overwrites Specifications for "++ show v ++ " : " ++ showPpr l) []--checkDuplicate :: [(Var, Located SpecType)] -> [Error]-checkDuplicate xts = mkErr <$> dups- where - mkErr (x, ts) = ErrDupSpecs (getSrcSpan x) (pprint x) (sourcePosSrcSpan . loc <$> ts)- dups = [z | z@(x, t1:t2:_) <- M.toList $ group xts ]--checkDuplicateRTAlias :: String -> [RTAlias s a] -> [Error]-checkDuplicateRTAlias s tas = mkErr <$> dups- where- mkErr xs@(x:_) = ErrDupAlias (sourcePosSrcSpan $ rtPos x) - (text s) - (pprint $ rtName x) - (sourcePosSrcSpan . rtPos <$> xs)- dups = [z | z@(_:_:_) <- L.groupBy (\x y -> rtName x == rtName y) tas]----checkMismatch :: (Var, Located SpecType) -> Maybe Error-checkMismatch (x, t) = if ok then Nothing else Just err- where - ok = tyCompat x (val t)- err = errTypeMismatch x t--tyCompat x t = lhs == rhs- where - lhs :: RSort = toRSort t- rhs :: RSort = ofType $ varType x- msg = printf "tyCompat: l = %s r = %s" (showpp lhs) (showpp rhs)--ghcSpecEnv sp = fromListSEnv binds- where - emb = tcEmbeds sp- binds = [(x, rSort t) | (x, Loc _ t) <- meas sp]- ++ [(symbol v, rSort t) | (v, Loc _ t) <- ctors sp]- ++ [(x, vSort v) | (x, v) <- freeSyms sp, isConLikeId v]- rSort = rTypeSortedReft emb - vSort = rSort . varRSort - varRSort :: Var -> RSort- varRSort = ofType . varType--errTypeMismatch :: Var -> Located SpecType -> Error-errTypeMismatch x t = ErrMismatch (sourcePosSrcSpan $ loc t) (pprint x) (varType x) (val t)----------------------------------------------------------------------------------------------------- | @checkRType@ determines if a type is malformed in a given environment -----------------------------------------------------------------------------------------------------------------------checkRType :: (PPrint r, Reftable r) => TCEmb TyCon -> SEnv SortedReft -> RRType r -> Maybe Doc ---------------------------------------------------------------------------------------------------checkRType emb env t = efoldReft cb (rTypeSortedReft emb) f insertPEnv env Nothing t - where - cb c ts = classBinds (rRCls c ts)- f env me r err = err <|> checkReft env emb me r- insertPEnv p γ = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p) - pbinds p = (pname p, pvarRType p :: RSort) - : [(x, t) | (t, x, _) <- pargs p]---checkReft :: (PPrint r, Reftable r) => SEnv SortedReft -> TCEmb TyCon -> Maybe (RRType r) -> r -> Maybe Doc -checkReft env emb Nothing _ = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet. -checkReft env emb (Just t) _ = (dr $+$) <$> checkSortedReftFull env' r - where - r = rTypeSortedReft emb t- dr = text "Sort Error in Refinement:" <+> pprint r - env' = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms---- DONT DELETE the below till we've added pred-checking as well--- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t) --- where xs = fromMaybe [] $ params <$> stripRTypeBase t ---- checkSig env (x, t) --- = case filter (not . (`S.member` env)) (freeSymbols t) of--- [] -> True--- ys -> errorstar (msg ys) --- where --- msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t)-------------------------------------------------------------------------------------------------------- | @checkMeasures@ determines if a measure definition is wellformed ----------------------------------------------------------------------------------------------------------------------------------checkMeasures :: M.HashMap TyCon FTycon -> SEnv SortedReft -> [Measure SpecType DataCon] -> [Error]-----------------------------------------------------------------------------------------------------checkMeasures emb env = concatMap (checkMeasure emb env)--checkMeasure :: M.HashMap TyCon FTycon -> SEnv SortedReft -> Measure SpecType DataCon -> [Error]-checkMeasure emb γ (M name@(Loc src n) sort body)- = [txerror e | Just e <- checkMBody γ emb name sort <$> body]- where - txerror = ErrMeas (sourcePosSrcSpan src) n--checkMBody γ emb name sort (Def s c bs body) = checkMBody' emb sort γ' body- where - γ' = L.foldl' (\γ (x, t) -> insertSEnv x t γ) γ xts- xts = zip bs $ rTypeSortedReft emb . subsTyVars_meet su <$> ty_args trep- trep = toRTypeRep ct- su = checkMBodyUnify (ty_res trep) (head $ snd3 $ bkArrowDeep sort)- ct = ofType $ dataConUserType c :: SpecType--checkMBodyUnify = go- where- go (RVar tv _) t = [(tv, toRSort t, t)]- go t@(RApp {}) t'@(RApp {}) = concat $ zipWith go (rt_args t) (rt_args t')- go _ _ = []--checkMBody' emb sort γ body = case body of- E e -> checkSortFull γ (rTypeSort emb sort') e- P p -> checkSortFull γ psort p- R s p -> checkSortFull (insertSEnv s sty γ) psort p- where- psort = FApp propFTyCon []- sty = rTypeSortedReft emb sort' - sort' = fromRTypeRep $ trep' { ty_vars = [], ty_preds = [], ty_labels = []- , ty_binds = tail $ ty_binds trep'- , ty_args = tail $ ty_args trep' }- trep' = toRTypeRep sort-------------------------------------------------------------------------------------- | Replace Predicate Arguments With Existentials --------------------------------------------------------------------------------------------------------------data ExSt = ExSt { fresh :: Int- , emap :: M.HashMap Symbol (RSort, Expr)- , pmap :: M.HashMap Symbol RPVar - }---- | Niki: please write more documentation for this, maybe an example? --- I can't really tell whats going on... (RJ)--txExpToBind :: SpecType -> SpecType-txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)- where πs = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]--expToBindT :: SpecType -> State ExSt SpecType-expToBindT (RVar v r) - = expToBindRef r >>= addExists . RVar v-expToBindT (RFun x t1 t2 r) - = do t1' <- expToBindT t1- t2' <- expToBindT t2- expToBindRef r >>= addExists . RFun x t1' t2'-expToBindT (RAllT a t) - = liftM (RAllT a) (expToBindT t)-expToBindT (RAllP p t)- = liftM (RAllP p) (expToBindT t)-expToBindT (RAllS s t)- = liftM (RAllS s) (expToBindT t)-expToBindT (RApp c ts rs r) - = do ts' <- mapM expToBindT ts- rs' <- mapM expToBindReft rs- expToBindRef r >>= addExists . RApp c ts' rs'-expToBindT (RAppTy t1 t2 r)- = do t1' <- expToBindT t1- t2' <- expToBindT t2- expToBindRef r >>= addExists . RAppTy t1' t2'-expToBindT t - = return t--expToBindReft :: SpecProp -> State ExSt SpecProp-expToBindReft (RProp s t) = RProp s <$> expToBindT t-expToBindReft (RPropP s r) = RPropP s <$> expToBindRef r-expToBindReft (RHProp _ _) = errorstar "TODO:EFFECTS:expToBindReft"--getBinds :: State ExSt (M.HashMap Symbol (RSort, Expr))-getBinds - = do bds <- emap <$> get- modify $ \st -> st{emap = M.empty}- return bds--addExists t = liftM (M.foldlWithKey' addExist t) getBinds--addExist t x (tx, e) = RAllE x t' t- where t' = (ofRSort tx) `strengthen` uTop r- r = Reft (vv Nothing, [RConc (PAtom Eq (EVar (vv Nothing)) e)])--expToBindRef :: UReft r -> State ExSt (UReft r)-expToBindRef (U r (Pr p) l)- = mapM expToBind p >>= return . (\p -> U r p l). Pr--expToBind :: UsedPVar -> State ExSt UsedPVar-expToBind p- = do Just π <- liftM (M.lookup (pname p)) (pmap <$> get)- let pargs0 = zip (pargs p) (fst3 <$> pargs π)- pargs' <- mapM expToBindParg pargs0- return $ p{pargs = pargs'}--expToBindParg :: (((), Symbol, Expr), RSort) -> State ExSt ((), Symbol, Expr)-expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s')--expToBindExpr :: Expr -> RSort -> State ExSt Expr-expToBindExpr e@(EVar s) _ | isLower $ headSym $ symbol s- = return e-expToBindExpr e t - = do s <- freshSymbol- modify $ \st -> st{emap = M.insert s (t, e) (emap st)}- return $ EVar s--freshSymbol :: State ExSt Symbol-freshSymbol - = do n <- fresh <$> get- modify $ \s -> s{fresh = n+1}- return $ symbol $ "ex#" ++ show n--maybeTrue :: NamedThing a => a -> ModName -> NameSet -> RReft -> RReft-maybeTrue x target exports r- | isInternalName name || inTarget && notExported- = r- | otherwise- = killHoles r- where- inTarget = moduleName (nameModule name) == getModName target- name = getName x- notExported = not $ getName x `elemNameSet` exports--killHoles r@(U (Reft (v,rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) }------------------------------------------------------------------------------------------ | Tasteful Error Messages ------------------------------------------------------------------------------------------------------------------------------------------------berrUnknownVar = berrUnknown "Variable"--berrUnknown :: (PPrint a) => String -> Located a -> String -berrUnknown thing x = printf "[%s]\nSpecification for unknown %s : %s" - thing (showpp $ loc x) (showpp $ val x)+-- | This module contains the functions that convert /from/ descriptions of +-- symbols, names and types (over freshly parsed /bare/ Strings),+-- /to/ representations connected to GHC vars, names, and types.+-- The actual /representations/ of bare and real (refinement) types are all+-- in `RefType` -- they are different instances of `RType`++module Language.Haskell.Liquid.Bare (+ GhcSpec (..)+ , makeGhcSpec+ ) where++import Language.Haskell.Liquid.Bare.GhcSpec+
+ src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.Check (+ checkGhcSpec++ , checkDefAsserts+ , checkTerminationExpr+ , checkTy+ ) where++import Debug.Trace++import DataCon+import Name (getSrcSpan)+import TyCon+import Var++import Control.Applicative ((<$>), (<|>))+import Control.Arrow ((&&&))+import Control.Monad.Writer+import Data.Maybe+import Text.PrettyPrint.HughesPJ+import Text.Printf++import qualified Data.List as L+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S++import Language.Fixpoint.Misc (applyNonNull, group, mapSnd, snd3)+import Language.Fixpoint.Names (isPrefixOfSym, stripParensSym)+import Language.Fixpoint.Sort (checkSorted, checkSortedReftFull, checkSortFull)+import Language.Fixpoint.Types hiding (R)++import Language.Haskell.Liquid.GhcMisc (showPpr, sourcePosSrcSpan)+import Language.Haskell.Liquid.Misc (dropThd3, firstDuplicate)+import Language.Haskell.Liquid.PredType (pvarRType, wiredSortedSyms)+import Language.Haskell.Liquid.PrettyPrint (pprintSymbol)+import Language.Haskell.Liquid.RefType (classBinds, ofType, rTypeSort, rTypeSortedReft, subsTyVars_meet)+import Language.Haskell.Liquid.Types++import qualified Language.Haskell.Liquid.Measure as Ms++import Language.Haskell.Liquid.Bare.DataType (dataConSpec)+import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.SymSort (txRefSort)++----------------------------------------------------------------------------------------------+----- Checking GhcSpec -----------------------------------------------------------------------+----------------------------------------------------------------------------------------------++checkGhcSpec :: [(ModName, Ms.BareSpec)]+ -> SEnv SortedReft+ -> GhcSpec+ -> Either [Error] GhcSpec++checkGhcSpec specs env sp = applyNonNull (Right sp) Left errors+ where + errors = mapMaybe (checkBind "constructor" emb tcEnv env) (dcons sp)+ ++ mapMaybe (checkBind "measure" emb tcEnv env) (meas sp)+ ++ mapMaybe (checkInv emb tcEnv env) (invariants sp)+ ++ (checkIAl emb tcEnv env) (ialiases sp)+ ++ checkMeasures emb env ms+ ++ mapMaybe checkMismatch sigs+ ++ checkDuplicate (tySigs sp)+ ++ checkDuplicate (asmSigs sp)+ ++ checkDupIntersect (tySigs sp) (asmSigs sp)+ ++ checkRTAliases "Type Alias" env tAliases+ ++ checkRTAliases "Pred Alias" env pAliases + ++ checkDuplicateFieldNames (dconsP sp)+ ++ checkRefinedClasses (concatMap (Ms.classes . snd) specs) (concatMap (Ms.rinstance . snd) specs)+++ tAliases = concat [Ms.aliases sp | (_, sp) <- specs]+ pAliases = concat [Ms.paliases sp | (_, sp) <- specs]+ dcons spec = [(v, Loc l t) | (v,t) <- dataConSpec (dconsP spec) + | (_,dcp) <- dconsP spec+ , let l = dc_loc dcp+ ]+ emb = tcEmbeds sp+ tcEnv = tyconEnv sp+ ms = measures sp+ sigs = tySigs sp ++ asmSigs sp++checkRefinedClasses :: [RClass BareType] -> [RInstance BareType] -> [Error]+checkRefinedClasses definitions instances+ = mkError <$> duplicates+ where + duplicates+ = mapMaybe checkCls (rcName <$> definitions)+ checkCls cls+ = case findConflicts cls of+ [] ->+ Nothing+ conflicts ->+ Just (cls, conflicts)+ findConflicts cls+ = filter ((== cls) . riclass) instances++ mkError (cls, conflicts)+ = ErrRClass (sourcePosSrcSpan $ loc cls) (pprint cls) (ofConflict <$> conflicts)+ ofConflict+ = sourcePosSrcSpan . loc . riclass &&& pprint . ritype++checkDuplicateFieldNames :: [(DataCon, DataConP)] -> [Error]+checkDuplicateFieldNames = catMaybes . map go+ where+ go (d, dts) = checkNoDups (dc_loc dts) d (fst <$> tyArgs dts)+ checkNoDups l d xs = mkErr l d <$> firstDuplicate xs ++ mkErr l d x = ErrBadData (sourcePosSrcSpan l) + (pprint d) + (text "Multiple declarations of record selector" <+> pprintSymbol x)++checkInv :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> Located SpecType -> Maybe Error+checkInv emb tcEnv env t = checkTy err emb tcEnv env (val t) + where + err = ErrInvt (sourcePosSrcSpan $ loc t) (val t) ++checkIAl :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> [(Located SpecType, Located SpecType)] -> [Error]+checkIAl emb tcEnv env ials = catMaybes $ concatMap (checkIAlOne emb tcEnv env) ials++checkIAlOne emb tcEnv env (t1, t2) = checkEq : (tcheck <$> [t1, t2])+ where + tcheck t = checkTy (err t) emb tcEnv env (val t)+ err t = ErrIAl (sourcePosSrcSpan $ loc t) (val t) + t1' :: RSort + t1' = toRSort $ val t1+ t2' :: RSort + t2' = toRSort $ val t2+ checkEq = if (t1' == t2') then Nothing else Just errmis+ errmis = ErrIAlMis (sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg+ emsg = pprint t1 <+> text "does not match with" <+> pprint t2 +++-- FIXME: Should _ be removed if it isn't used?+checkRTAliases msg _ as = err1s+ where + err1s = checkDuplicateRTAlias msg as++checkBind :: (PPrint v) => String -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error +checkBind s emb tcEnv env (v, Loc l t) = checkTy msg emb tcEnv env' t+ where + msg = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t + env' = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms++checkTerminationExpr :: (Eq v, PPrint v) => TCEmb TyCon -> SEnv SortedReft -> (v, Located SpecType, [Expr])-> Maybe Error +checkTerminationExpr emb env (v, Loc l t, es) = (mkErr <$> go es) <|> (mkErr' <$> go' es)+ where + mkErr = uncurry (ErrTermSpec (sourcePosSrcSpan l) (text "termination expression" <+> pprint v))+ mkErr' = uncurry (ErrTermSpec (sourcePosSrcSpan l) (text "termination expression is not numeric"))+ go = foldl (\err e -> err <|> fmap (e,) (checkSorted env' e)) Nothing+ go' = foldl (\err e -> err <|> fmap (e,) (checkSorted env' (cmpZero e))) Nothing+ env' = foldl (\e (x, s) -> insertSEnv x s e) env'' wiredSortedSyms+ env'' = mapSEnv sr_sort $ foldl (\e (x,s) -> insertSEnv x s e) env xss+ xss = mapSnd rSort <$> (uncurry zip $ dropThd3 $ bkArrowDeep t)+ rSort = rTypeSortedReft emb+ cmpZero = PAtom Le zero ++checkTy :: (Doc -> Error) -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> SpecType -> Maybe Error+checkTy mkE emb tcEnv env t = mkE <$> checkRType emb env (txRefSort tcEnv emb t)++checkDupIntersect :: [(Var, Located SpecType)] -> [(Var, Located SpecType)] -> [Error]+checkDupIntersect xts mxts = concatMap mkWrn dups+ where + mkWrn (x, t) = pprWrn x (sourcePosSrcSpan $ loc t)+ dups = L.intersectBy (\x y -> (fst x == fst y)) mxts xts+ pprWrn v l = trace ("WARNING: Assume Overwrites Specifications for "++ show v ++ " : " ++ showPpr l) []++checkDuplicate :: [(Var, Located SpecType)] -> [Error]+checkDuplicate xts = mkErr <$> dups+ where+ mkErr (x, ts) = ErrDupSpecs (getSrcSpan x) (pprint x) (sourcePosSrcSpan . loc <$> ts)+ dups = [z | z@(_, _:_:_) <- M.toList $ group xts ]++checkDuplicateRTAlias :: String -> [RTAlias s a] -> [Error]+checkDuplicateRTAlias s tas = mkErr <$> dups+ where+ mkErr xs@(x:_) = ErrDupAlias (sourcePosSrcSpan $ rtPos x) + (text s) + (pprint $ rtName x) + (sourcePosSrcSpan . rtPos <$> xs)+ mkErr [] = error "mkError: called on empty list"+ dups = [z | z@(_:_:_) <- L.groupBy (\x y -> rtName x == rtName y) tas]++++checkMismatch :: (Var, Located SpecType) -> Maybe Error+checkMismatch (x, t) = if ok then Nothing else Just err+ where + ok = tyCompat x (val t)+ err = errTypeMismatch x t++tyCompat x t = lhs == rhs+ where + lhs :: RSort = toRSort t+ rhs :: RSort = ofType $ varType x++errTypeMismatch :: Var -> Located SpecType -> Error+errTypeMismatch x t = ErrMismatch (sourcePosSrcSpan $ loc t) (pprint x) (varType x) (val t)++------------------------------------------------------------------------------------------------+-- | @checkRType@ determines if a type is malformed in a given environment ---------------------+------------------------------------------------------------------------------------------------+checkRType :: (PPrint r, Reftable r) => TCEmb TyCon -> SEnv SortedReft -> RRType r -> Maybe Doc +------------------------------------------------------------------------------------------------++checkRType emb env t = efoldReft cb (rTypeSortedReft emb) f insertPEnv env Nothing t + where + cb c ts = classBinds (rRCls c ts)+ f env me r err = err <|> checkReft env emb me r+ insertPEnv p γ = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p) + pbinds p = (pname p, pvarRType p :: RSort) + : [(x, t) | (t, x, _) <- pargs p]+++checkReft :: (PPrint r, Reftable r) => SEnv SortedReft -> TCEmb TyCon -> Maybe (RRType r) -> r -> Maybe Doc +checkReft _ _ Nothing _ = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet. +checkReft env emb (Just t) _ = (dr $+$) <$> checkSortedReftFull env' r + where + r = rTypeSortedReft emb t+ dr = text "Sort Error in Refinement:" <+> pprint r + env' = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms++-- DONT DELETE the below till we've added pred-checking as well+-- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t) +-- where xs = fromMaybe [] $ params <$> stripRTypeBase t ++-- checkSig env (x, t) +-- = case filter (not . (`S.member` env)) (freeSymbols t) of+-- [] -> TrueNGUAGE ScopedTypeVariables #-}+-- ys -> errorstar (msg ys) +-- where +-- msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t)++---------------------------------------------------------------------------------------------------+-- | @checkMeasures@ determines if a measure definition is wellformed -----------------------------+---------------------------------------------------------------------------------------------------+checkMeasures :: M.HashMap TyCon FTycon -> SEnv SortedReft -> [Measure SpecType DataCon] -> [Error]+---------------------------------------------------------------------------------------------------+checkMeasures emb env = concatMap (checkMeasure emb env)++checkMeasure :: M.HashMap TyCon FTycon -> SEnv SortedReft -> Measure SpecType DataCon -> [Error]+checkMeasure emb γ (M name@(Loc src n) sort body)+ = [txerror e | Just e <- checkMBody γ emb name sort <$> body]+ where + txerror = ErrMeas (sourcePosSrcSpan src) n++checkMBody γ emb _ sort (Def _ c bs body) = checkMBody' emb sort γ' body+ where + γ' = L.foldl' (\γ (x, t) -> insertSEnv x t γ) γ xts+ xts = zip bs $ rTypeSortedReft emb . subsTyVars_meet su <$> ty_args trep+ trep = toRTypeRep ct+ su = checkMBodyUnify (ty_res trep) (head $ snd3 $ bkArrowDeep sort)+ ct = ofType $ dataConUserType c :: SpecType++checkMBodyUnify = go+ where+ go (RVar tv _) t = [(tv, toRSort t, t)]+ go t@(RApp {}) t'@(RApp {}) = concat $ zipWith go (rt_args t) (rt_args t')+ go _ _ = []++checkMBody' emb sort γ body = case body of+ E e -> checkSortFull γ (rTypeSort emb sort') e+ P p -> checkSortFull γ psort p+ R s p -> checkSortFull (insertSEnv s sty γ) psort p+ where+ psort = FApp propFTyCon []+ sty = rTypeSortedReft emb sort' + sort' = fromRTypeRep $ trep' { ty_vars = [], ty_preds = [], ty_labels = []+ , ty_binds = tail $ ty_binds trep'+ , ty_args = tail $ ty_args trep' }+ trep' = toRTypeRep sort+++checkDefAsserts :: BareEnv -> [(Var, LocSymbol, BareType)] -> [(LocSymbol, BareType)] -> BareM ()+checkDefAsserts env vbs xbs = applyNonNull (return ()) grumble undefSigs+ where+ undefSigs = [x | (x, _) <- assertSigs, not (x `S.member` definedSigs)]+ assertSigs = filter isTarget xbs+ definedSigs = S.fromList $ snd3 <$> vbs+ grumble = mapM_ (warn . berrUnknownVar)+ moduleName = symbol $ modName env+ isTarget = isPrefixOfSym moduleName . stripParensSym . val . fst++warn x = tell [x]++-------------------------------------------------------------------------------------+-- | Tasteful Error Messages --------------------------------------------------------+-------------------------------------------------------------------------------------++berrUnknownVar = berrUnknown "Variable"++berrUnknown :: (PPrint a) => String -> Located a -> String +berrUnknown thing x = printf "[%s]\nSpecification for unknown %s : %s" + thing (showpp $ loc x) (showpp $ val x)+
+ src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.DataType (+ makeConTypes+ , makeTyConEmbeds++ , dataConSpec+ , meetDataConSpec+ ) where++import DataCon+import TyCon+import Var++import Control.Applicative ((<$>))+import Data.Maybe+import Data.Monoid++import qualified Data.List as L+import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Misc (errorstar, mapSnd)+import Language.Fixpoint.Types (Symbol, TCEmb, meet)++import Language.Haskell.Liquid.GhcMisc (symbolTyVar)+import Language.Haskell.Liquid.PredType (dataConPSpecType)+import Language.Haskell.Liquid.RefType (mkDataConIdsTy, ofType, rApp, rVar, uPVar)+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Variance+import Language.Haskell.Liquid.WiredIn++import qualified Language.Haskell.Liquid.Measure as Ms++import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Lookup+import Language.Haskell.Liquid.Bare.OfType++-----------------------------------------------------------------------+-- Bare Predicate: DataCon Definitions --------------------------------+-----------------------------------------------------------------------++makeConTypes (name,spec) = inModule name $ makeConTypes' (Ms.dataDecls spec) (Ms.dvariance spec)++makeConTypes' :: [DataDecl] -> [(LocSymbol, [Variance])] -> BareM ([(TyCon, TyConP)], [[(DataCon, Located DataConP)]])+makeConTypes' dcs vdcs = unzip <$> mapM (uncurry ofBDataDecl) (group dcs vdcs)+ where + group ds vs = merge (L.sort ds) (L.sortBy (\x y -> compare (fst x) (fst y)) vs) ++ merge (d:ds) (v:vs) + | tycName d == fst v = (Just d, Just v) : merge ds vs+ | tycName d < fst v = (Just d, Nothing) : merge ds (v:vs)+ | otherwise = (Nothing, Just v) : merge (d:ds) vs + merge [] vs = ((Nothing,) . Just) <$> vs+ merge ds [] = ((,Nothing) . Just) <$> ds ++++dataConSpec :: [(DataCon, DataConP)]-> [(Var, (RType RTyCon RTyVar RReft))]+dataConSpec dcs = concatMap mkDataConIdsTy [(dc, dataConPSpecType dc t) | (dc, t) <- dcs]++meetDataConSpec xts dcs = M.toList $ L.foldl' upd dcm xts + where + dcm = M.fromList $ dataConSpec dcs+ upd dcm (x, t) = M.insert x (maybe t (meetPad t) (M.lookup x dcm)) dcm++meetPad t1 t2 = -- traceShow ("meetPad: " ++ msg) $+ case (bkUniv t1, bkUniv t2) of+ ((_, π1s, ls1, _), (α2s, [], ls2, t2')) -> meet t1 (mkUnivs α2s π1s (ls1 ++ ls2) t2')+ ((α1s, [], ls1, t1'), (_, π2s, ls2, _)) -> meet (mkUnivs α1s π2s (ls1 ++ ls2) t1') t2+ _ -> errorstar $ "meetPad: " ++ msg+ where msg = "\nt1 = " ++ showpp t1 ++ "\nt2 = " ++ showpp t2++++++ofBDataDecl :: Maybe DataDecl -> (Maybe (LocSymbol, [Variance])) -> BareM ((TyCon, TyConP), [(DataCon, Located DataConP)])+ofBDataDecl (Just (D tc as ps ls cts _ sfun)) maybe_invariance_info+ = do πs <- mapM ofBPVar ps+ tc' <- lookupGhcTyCon tc+ cts' <- mapM (ofBDataCon lc tc' αs ps ls πs) cts+ let tys = [t | (_, dcp) <- cts', (_, t) <- tyArgs dcp]+ let initmap = zip (uPVar <$> πs) [0..]+ let varInfo = L.nub $ concatMap (getPsSig initmap True) tys+ let defaultPs = varSignToVariance varInfo <$> [0 .. (length πs - 1)] + let (tvarinfo, pvarinfo) = f defaultPs+ return ((tc', TyConP αs πs ls tvarinfo pvarinfo sfun), (mapSnd (Loc lc) <$> cts'))+ where + αs = RTV . symbolTyVar <$> as+ n = length αs+ lc = loc tc+ f defaultPs = case maybe_invariance_info of + {Nothing -> ([], defaultPs); + Just (_,is) -> (take n is, if null (drop n is) then defaultPs else (drop n is))} +++ varSignToVariance varsigns i = case filter (\p -> fst p == i) varsigns of + [] -> Invariant+ [(_, b)] -> if b then Covariant else Contravariant+ _ -> Bivariant++ofBDataDecl Nothing (Just (tc, is))+ = do tc' <- lookupGhcTyCon tc+ return ((tc', TyConP [] [] [] tcov tcontr Nothing), [])+ where + (tcov, tcontr) = (is, []) ++ofBDataDecl Nothing Nothing+ = errorstar $ "Bare.DataType.ofBDataDecl called on invalid inputs"++getPsSig m pos (RAllT _ t) + = getPsSig m pos t+getPsSig m pos (RApp _ ts rs r) + = addps m pos r ++ concatMap (getPsSig m pos) ts + ++ concatMap (getPsSigPs m pos) rs+getPsSig m pos (RVar _ r) + = addps m pos r+getPsSig m pos (RAppTy t1 t2 r) + = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2+getPsSig m pos (RFun _ t1 t2 r) + = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1+getPsSig m pos (RHole r)+ = addps m pos r +getPsSig _ _ z + = error $ "getPsSig" ++ show z++getPsSigPs m pos (RPropP _ r) = addps m pos r+getPsSigPs m pos (RProp _ t) = getPsSig m pos t+getPsSigPs _ _ (RHProp _ _) = errorstar "TODO:EFFECTS:getPsSigPs"++addps m pos (U _ ps _) = (flip (,)) pos . f <$> pvars ps+ where f = fromMaybe (error "Bare.addPs: notfound") . (`L.lookup` m) . uPVar++-- TODO:EFFECTS:ofBDataCon+ofBDataCon l tc αs ps ls πs (c, xts)+ = do c' <- lookupGhcDataCon c+ ts' <- mapM (mkSpecType' l ps) ts+ let cs = map ofType (dataConStupidTheta c')+ let t0 = rApp tc rs (RPropP [] . pdVarReft <$> πs) mempty + return $ (c', DataConP l αs πs ls cs (reverse (zip xs ts')) t0)+ where + (xs, ts) = unzip xts+ rs = [rVar α | RTV α <- αs]+++makeTyConEmbeds (mod, spec)+ = inModule mod $ makeTyConEmbeds' $ Ms.embeds spec++makeTyConEmbeds' :: TCEmb (Located Symbol) -> BareM (TCEmb TyCon)+makeTyConEmbeds' z = M.fromList <$> mapM tx (M.toList z)+ where + tx (c, y) = (, y) <$> lookupGhcTyCon c+
+ src/Language/Haskell/Liquid/Bare/Env.hs view
@@ -0,0 +1,105 @@+module Language.Haskell.Liquid.Bare.Env (+ BareM+ , Warn+ , TCEnv++ , BareEnv(..)++ , TInline(..), InlnEnv++ , inModule+ , withVArgs++ , setRTAlias+ , setRPAlias+ , setREAlias++ , execBare+ ) where++import HscTypes+import TyCon+import Var++import Control.Monad.Error hiding (Error)+import Control.Monad.State+import Control.Monad.Writer++import qualified Control.Exception as Ex +import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Types (Expr(..), Symbol, symbol, Pred)++import Language.Haskell.Liquid.Errors ()+import Language.Haskell.Liquid.Types+++-----------------------------------------------------------------------------------+-- | Error-Reader-IO For Bare Transformation --------------------------------------+-----------------------------------------------------------------------------------++-- FIXME: don't use WriterT [], very slow+type BareM = WriterT [Warn] (ErrorT Error (StateT BareEnv IO))++type Warn = String++type TCEnv = M.HashMap TyCon RTyCon++type InlnEnv = M.HashMap Symbol TInline++data TInline = TI { tiargs :: [Symbol]+ , tibody :: Either Pred Expr + } deriving (Show)++++data BareEnv = BE { modName :: !ModName+ , tcEnv :: !TCEnv+ , rtEnv :: !RTEnv+ , varEnv :: ![(Symbol,Var)]+ , hscEnv :: HscEnv + , logicEnv :: LogicMap+ , inlines :: InlnEnv+ }+++++setModule m b = b { modName = m }++inModule m act = do+ old <- gets modName+ modify $ setModule m+ res <- act+ modify $ setModule old+ return res++withVArgs l vs act = do+ old <- gets rtEnv+ mapM_ (mkExprAlias l . symbol . showpp) vs+ res <- act+ modify $ \be -> be { rtEnv = old }+ return res++mkExprAlias l v+ = setRTAlias v (RTA v [] [] (RExprArg (EVar $ symbol v)) l)++setRTAlias s a =+ modify $ \b -> b { rtEnv = mapRT (M.insert s a) $ rtEnv b }++setRPAlias s a =+ modify $ \b -> b { rtEnv = mapRP (M.insert s a) $ rtEnv b }++setREAlias s a =+ modify $ \b -> b { rtEnv = mapRE (M.insert s a) $ rtEnv b }++------------------------------------------------------------------+execBare :: BareM a -> BareEnv -> IO (Either Error a)+------------------------------------------------------------------+execBare act benv = + do z <- evalStateT (runErrorT (runWriterT act)) benv `Ex.catch` (return . Left)+ case z of+ Left s -> return $ Left s+ Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++) + return $ Right x+
+ src/Language/Haskell/Liquid/Bare/Existential.hs view
@@ -0,0 +1,102 @@+module Language.Haskell.Liquid.Bare.Existential (+ txExpToBind+ ) where++import Control.Applicative ((<$>))+import Control.Monad.State+import Data.Char++import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Misc (errorstar, fst3)+import Language.Fixpoint.Names (headSym)+import Language.Fixpoint.Types (Brel(..), Expr(..), Pred(..), Refa(..), Reft(..), Symbol, symbol, vv)++import Language.Haskell.Liquid.RefType (strengthen, uTop)+import Language.Haskell.Liquid.Types++-------------------------------------------------------------------------------+-- | Replace Predicate Arguments With Existentials ----------------------------+-------------------------------------------------------------------------------++data ExSt = ExSt { fresh :: Int+ , emap :: M.HashMap Symbol (RSort, Expr)+ , pmap :: M.HashMap Symbol RPVar + }++-- | Niki: please write more documentation for this, maybe an example? +-- I can't really tell whats going on... (RJ)++txExpToBind :: SpecType -> SpecType+txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)+ where πs = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]++expToBindT :: SpecType -> State ExSt SpecType+expToBindT (RVar v r) + = expToBindRef r >>= addExists . RVar v+expToBindT (RFun x t1 t2 r) + = do t1' <- expToBindT t1+ t2' <- expToBindT t2+ expToBindRef r >>= addExists . RFun x t1' t2'+expToBindT (RAllT a t) + = liftM (RAllT a) (expToBindT t)+expToBindT (RAllP p t)+ = liftM (RAllP p) (expToBindT t)+expToBindT (RAllS s t)+ = liftM (RAllS s) (expToBindT t)+expToBindT (RApp c ts rs r) + = do ts' <- mapM expToBindT ts+ rs' <- mapM expToBindReft rs+ expToBindRef r >>= addExists . RApp c ts' rs'+expToBindT (RAppTy t1 t2 r)+ = do t1' <- expToBindT t1+ t2' <- expToBindT t2+ expToBindRef r >>= addExists . RAppTy t1' t2'+expToBindT t + = return t++expToBindReft :: SpecProp -> State ExSt SpecProp+expToBindReft (RProp s t) = RProp s <$> expToBindT t+expToBindReft (RPropP s r) = RPropP s <$> expToBindRef r+expToBindReft (RHProp _ _) = errorstar "TODO:EFFECTS:expToBindReft"++getBinds :: State ExSt (M.HashMap Symbol (RSort, Expr))+getBinds + = do bds <- emap <$> get+ modify $ \st -> st{emap = M.empty}+ return bds++addExists t = liftM (M.foldlWithKey' addExist t) getBinds++addExist t x (tx, e) = RAllE x t' t+ where t' = (ofRSort tx) `strengthen` uTop r+ r = Reft (vv Nothing, [RConc (PAtom Eq (EVar (vv Nothing)) e)])++expToBindRef :: UReft r -> State ExSt (UReft r)+expToBindRef (U r (Pr p) l)+ = mapM expToBind p >>= return . (\p -> U r p l). Pr++expToBind :: UsedPVar -> State ExSt UsedPVar+expToBind p+ = do Just π <- liftM (M.lookup (pname p)) (pmap <$> get)+ let pargs0 = zip (pargs p) (fst3 <$> pargs π)+ pargs' <- mapM expToBindParg pargs0+ return $ p{pargs = pargs'}++expToBindParg :: (((), Symbol, Expr), RSort) -> State ExSt ((), Symbol, Expr)+expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s')++expToBindExpr :: Expr -> RSort -> State ExSt Expr+expToBindExpr e@(EVar s) _ | isLower $ headSym $ symbol s+ = return e+expToBindExpr e t + = do s <- freshSymbol+ modify $ \st -> st{emap = M.insert s (t, e) (emap st)}+ return $ EVar s++freshSymbol :: State ExSt Symbol+freshSymbol + = do n <- fresh <$> get+ modify $ \s -> s{fresh = n+1}+ return $ symbol $ "ex#" ++ show n+
+ src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.Expand (+ expandReft+ , expandPred+ , expandExpr+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad.Reader hiding (forM)+import Control.Monad.State hiding (forM)++import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Types (Expr(..), Pred(..), Refa(..), Reft(..), mkSubst, subst)++import Language.Haskell.Liquid.Misc (safeZipWithError)+import Language.Haskell.Liquid.Types++import Language.Haskell.Liquid.Bare.Env++--------------------------------------------------------------------------------+-- Expand Reft Preds & Exprs ---------------------------------------------------+--------------------------------------------------------------------------------++expandReft :: RReft -> BareM RReft+expandReft = txPredReft expandPred expandExpr++txPredReft :: (Pred -> BareM Pred) -> (Expr -> BareM Expr) -> RReft -> BareM RReft+txPredReft f fe (U r p l) = (\r -> U r p l) <$> txPredReft' f r+ where + txPredReft' f (Reft (v, ras)) = Reft . (v,) <$> mapM (txPredRefa f) ras+ txPredRefa f (RConc p) = fmap RConc $ (f <=< mapPredM fe) p+ txPredRefa _ z = return z++mapPredM :: (Expr -> BareM Expr) -> Pred -> BareM Pred+mapPredM f = go+ where+ go PTrue = return PTrue+ go PFalse = return PFalse+ go (PAnd ps) = PAnd <$> mapM go ps+ go (POr ps) = POr <$> mapM go ps+ go (PNot p) = PNot <$> go p+ go (PImp p q) = PImp <$> go p <*> go q+ go (PIff p q) = PIff <$> go p <*> go q+ go (PBexp e) = PBexp <$> f e+ go (PAtom b e1 e2) = PAtom b <$> f e1 <*> f e2+ go (PAll xs p) = PAll xs <$> go p+ go PTop = return PTop++--------------------------------------------------------------------------------+-- Expand Preds ----------------------------------------------------------------+--------------------------------------------------------------------------------++expandPred :: Pred -> BareM Pred++expandPred p@(PBexp (EApp (Loc l f') es))+ = do env <- gets (predAliases.rtEnv)+ return $+ case M.lookup f' env of+ Just rp ->+ expandApp l rp es+ Nothing ->+ p+expandPred p@(PBexp _)+ = return p++expandPred (PAnd ps)+ = PAnd <$> mapM expandPred ps+expandPred (POr ps)+ = POr <$> mapM expandPred ps++expandPred (PNot p)+ = PNot <$> expandPred p+expandPred (PAll xts p)+ = PAll xts <$> expandPred p++expandPred (PImp p q)+ = PImp <$> expandPred p <*> expandPred q+expandPred (PIff p q)+ = PIff <$> expandPred p <*> expandPred q++expandPred p@(PAtom _ _ _)+ = return p++expandPred PTrue+ = return PTrue+expandPred PFalse+ = return PFalse+expandPred PTop+ = return PTop++--------------------------------------------------------------------------------+-- Expand Exprs ----------------------------------------------------------------+--------------------------------------------------------------------------------++expandExpr :: Expr -> BareM Expr++expandExpr (EApp f@(Loc l f') es)+ = do env <- gets (exprAliases.rtEnv)+ case M.lookup f' env of+ Just re ->+ expandApp l re <$> mapM expandExpr es+ Nothing ->+ EApp f <$> mapM expandExpr es++expandExpr (EBin op e1 e2)+ = EBin op <$> expandExpr e1 <*> expandExpr e2+expandExpr (EIte p e1 e2)+ = EIte p <$> expandExpr e1 <*> expandExpr e2+expandExpr (ECst e s)+ = (`ECst` s) <$> expandExpr e++expandExpr e@(ESym _)+ = return e+expandExpr e@(ECon _)+ = return e+expandExpr e@(EVar _)+ = return e+expandExpr e@(ELit _ _)+ = return e++expandExpr EBot+ = return EBot++--------------------------------------------------------------------------------+-- Expand Alias Application ----------------------------------------------------+--------------------------------------------------------------------------------++expandApp l re es+ = subst su $ rtBody re+ where su = mkSubst $ safeZipWithError msg (rtVArgs re) es+ msg = "Malformed alias application at " ++ show l ++ "\n\t"+ ++ show (rtName re) + ++ " defined at " ++ show (rtPos re)+ ++ "\n\texpects " ++ show (length $ rtVArgs re)+ ++ " arguments but it is given " ++ show (length es)+
+ src/Language/Haskell/Liquid/Bare/GhcSpec.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Language.Haskell.Liquid.Bare.GhcSpec (+ GhcSpec(..)+ , makeGhcSpec+ ) where++import CoreSyn hiding (Expr)+import HscTypes+import Id+import NameSet+import TyCon+import Var++import Control.Applicative ((<$>))+import Control.Monad.Reader+import Control.Monad.State+import Data.Bifunctor+import Data.Maybe+import Data.Monoid++import qualified Control.Exception as Ex +import qualified Data.List as L+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S++import Language.Fixpoint.Misc (mapSnd, thd3)+import Language.Fixpoint.Names (takeWhileSym)+import Language.Fixpoint.Types (Expr, SEnv, SortedReft, Symbol, TCEmb, fromListSEnv, insertSEnv, mkSubst, subst, substa, symbol)++import Language.Haskell.Liquid.Dictionaries+import Language.Haskell.Liquid.GhcMisc (getSourcePos, sourcePosSrcSpan)+import Language.Haskell.Liquid.PredType (makeTyConInfo)+import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.WiredIn++import qualified Language.Haskell.Liquid.Measure as Ms++import Language.Haskell.Liquid.Bare.Check+import Language.Haskell.Liquid.Bare.DataType+import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Existential+import Language.Haskell.Liquid.Bare.Measure+import Language.Haskell.Liquid.Bare.Misc (makeSymbols, mkVarExpr)+import Language.Haskell.Liquid.Bare.Plugged+import Language.Haskell.Liquid.Bare.RTEnv+import Language.Haskell.Liquid.Bare.Spec+import Language.Haskell.Liquid.Bare.SymSort+import Language.Haskell.Liquid.Bare.RefToLogic++------------------------------------------------------------------+---------- Top Level Output --------------------------------------+------------------------------------------------------------------++makeGhcSpec :: Config -> ModName -> [CoreBind] -> [Var] -> [Var] -> NameSet -> HscEnv -> Either Error LogicMap+ -> [(ModName,Ms.BareSpec)]+ -> IO GhcSpec+makeGhcSpec cfg name cbs vars defVars exports env lmap specs+ + = do sp <- throwLeft =<< execBare act initEnv+ let env = ghcSpecEnv sp+ throwLeft $ checkGhcSpec specs env $ postProcess cbs env sp+ where+ act = makeGhcSpec' cfg cbs vars defVars exports specs+ throwLeft = either Ex.throw return+ initEnv = BE name mempty mempty mempty env lmap' mempty+ lmap' = case lmap of {Left e -> Ex.throw e; Right x -> x}+ +postProcess :: [CoreBind] -> SEnv SortedReft -> GhcSpec -> GhcSpec+postProcess cbs specEnv sp@(SP {..}) = sp { tySigs = tySigs', texprs = ts, asmSigs = asmSigs', dicts = dicts' }+ -- HEREHEREHEREHERE (addTyConInfo stuff) + where+ (sigs, ts) = replaceLocalBinds tcEmbeds tyconEnv tySigs texprs specEnv cbs+ tySigs' = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> sigs+ asmSigs' = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> asmSigs+ dicts' = dmapty (addTyConInfo tcEmbeds tyconEnv) dicts++ghcSpecEnv sp = fromListSEnv binds+ where + emb = tcEmbeds sp+ binds = [(x, rSort t) | (x, Loc _ t) <- meas sp]+ ++ [(symbol v, rSort t) | (v, Loc _ t) <- ctors sp]+ ++ [(x, vSort v) | (x, v) <- freeSyms sp, isConLikeId v]+ rSort = rTypeSortedReft emb + vSort = rSort . varRSort + varRSort :: Var -> RSort+ varRSort = ofType . varType++------------------------------------------------------------------------------------------------+makeGhcSpec' :: Config -> [CoreBind] -> [Var] -> [Var] -> NameSet -> [(ModName, Ms.BareSpec)] -> BareM GhcSpec+------------------------------------------------------------------------------------------------+makeGhcSpec' cfg cbs vars defVars exports specs+ = do name <- gets modName+ makeRTEnv specs+ (tycons, datacons, dcSs, tyi, embs) <- makeGhcSpecCHOP1 specs+ modify $ \be -> be { tcEnv = tyi }+ (cls, mts) <- second mconcat . unzip . mconcat <$> mapM (makeClasses cfg vars) specs+ (measures, cms', ms', cs', xs') <- makeGhcSpecCHOP2 cbs specs dcSs datacons cls embs+ (invs, ialias, sigs, asms) <- makeGhcSpecCHOP3 cfg vars defVars specs name mts embs+ syms <- makeSymbols (vars ++ map fst cs') xs' (sigs ++ asms ++ cs') ms' (invs ++ (snd <$> ialias))+ let su = mkSubst [ (x, mkVarExpr v) | (x, v) <- syms]+ return (emptySpec cfg)+ >>= makeGhcSpec0 cfg defVars exports name+ >>= makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su + >>= makeGhcSpec2 invs ialias measures su + >>= makeGhcSpec3 datacons tycons embs syms + >>= makeGhcSpec4 defVars specs name su + >>= makeSpecDictionaries embs vars specs++emptySpec :: Config -> GhcSpec+emptySpec cfg = SP [] [] [] [] [] [] [] [] [] mempty [] [] [] [] mempty mempty cfg mempty [] mempty mempty+++makeGhcSpec0 cfg defVars exports name sp+ = do targetVars <- makeTargetVars name defVars $ binders cfg+ return $ sp { config = cfg + , exports = exports + , tgtVars = targetVars }++makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su sp+ = do tySigs <- makePluggedSigs name embs tyi exports $ tx sigs+ asmSigs <- makePluggedAsmSigs embs tyi $ tx asms+ ctors <- makePluggedAsmSigs embs tyi $ tx cs'+ lmap <- logicEnv <$> get + inlmap <- inlines <$> get+ let ctors' = [ (x, txRefToLogic lmap inlmap <$> t) | (x, t) <- ctors ]+ return $ sp { tySigs = tySigs+ , asmSigs = asmSigs+ , ctors = ctors'+ , meas = tx' $ tx $ ms' ++ varMeasures vars ++ cms' }+ where+ tx = fmap . mapSnd . subst $ su+ tx' = fmap (mapSnd $ fmap uRType)++makeGhcSpec2 invs ialias measures su sp+ = return $ sp { invariants = subst su invs + , ialiases = subst su ialias + , measures = subst su <$> M.elems $ Ms.measMap measures }++makeGhcSpec3 datacons tycons embs syms sp+ = do tcEnv <- gets tcEnv+ lmap <- logicEnv <$> get + inlmap <- inlines <$> get+ let dcons' = mapSnd (txRefToLogic lmap inlmap) <$> datacons+ return $ sp { tyconEnv = tcEnv+ , dconsP = dcons'+ , tconsP = tycons+ , tcEmbeds = embs + , freeSyms = [(symbol v, v) | (_, v) <- syms] }++makeGhcSpec4 defVars specs name su sp+ = do decr' <- mconcat <$> mapM (makeHints defVars . snd) specs+ texprs' <- mconcat <$> mapM (makeTExpr defVars . snd) specs+ lazies <- mkThing makeLazy+ lvars' <- mkThing makeLVar+ hmeas <- mkThing makeHIMeas+ quals <- mconcat <$> mapM makeQualifiers specs+ let sigs = strengthenHaskellMeasures hmeas ++ tySigs sp+ lmap <- logicEnv <$> get + inlmap <- inlines <$> get+ let tx = mapSnd (fmap $ txRefToLogic lmap inlmap)+ let mtx = txRefToLogic lmap inlmap + return $ sp { qualifiers = subst su quals+ , decr = decr'+ , texprs = texprs'+ , lvars = lvars'+ , lazy = lazies + , tySigs = tx <$> sigs+ , asmSigs = tx <$> (asmSigs sp)+ , measures = mtx <$> (measures sp)+ } + where+ mkThing mk = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs, m == name ]+++makeGhcSpecCHOP1 specs+ = do (tcs, dcs) <- mconcat <$> mapM makeConTypes specs+ let tycons = tcs ++ wiredTyCons + let tyi = makeTyConInfo tycons+ embs <- mconcat <$> mapM makeTyConEmbeds specs+ datacons <- makePluggedDataCons embs tyi (concat dcs ++ wiredDataCons)+ let dcSelectors = concat $ map makeMeasureSelectors datacons+ return $ (tycons, second val <$> datacons, dcSelectors, tyi, embs) ++makeGhcSpecCHOP3 cfg vars defVars specs name mts embs+ = do sigs' <- mconcat <$> mapM (makeAssertSpec name cfg vars defVars) specs+ asms' <- mconcat <$> mapM (makeAssumeSpec name cfg vars defVars) specs+ invs <- mconcat <$> mapM makeInvariants specs+ ialias <- mconcat <$> mapM makeIAliases specs+ let dms = makeDefaultMethods vars mts+ tyi <- gets tcEnv+ let sigs = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (_, x, t) <- sigs' ++ mts ++ dms ]+ let asms = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (_, x, t) <- asms' ]+ return (invs, ialias, sigs, asms)++makeGhcSpecCHOP2 cbs specs dcSelectors datacons cls embs+ = do measures' <- mconcat <$> mapM makeMeasureSpec specs+ tyi <- gets tcEnv+ name <- gets modName + mapM_ (makeHaskellInlines cbs name) specs+ hmeans <- mapM (makeHaskellMeasures cbs name) specs+ let measures = mconcat (measures':Ms.mkMSpec' dcSelectors:hmeans)+ let (cs, ms) = makeMeasureSpec' measures+ let cms = makeClassMeasureSpec measures+ let cms' = [ (x, Loc l $ cSort t) | (Loc l x, t) <- cms ]+ let ms' = [ (x, Loc l t) | (Loc l x, t) <- ms, isNothing $ lookup x cms' ]+ let cs' = [ (v, Loc (getSourcePos v) (txRefSort tyi embs t)) | (v, t) <- meetDataConSpec cs (datacons ++ cls)]+ let xs' = val . fst <$> ms+ return (measures, cms', ms', cs', xs')+++data ReplaceEnv = RE { _re_env :: M.HashMap Symbol Symbol+ , _re_fenv :: SEnv SortedReft+ , _re_emb :: TCEmb TyCon+ , _re_tyi :: M.HashMap TyCon RTyCon+ }++type ReplaceState = ( M.HashMap Var (Located SpecType)+ , M.HashMap Var [Expr]+ )++type ReplaceM = ReaderT ReplaceEnv (State ReplaceState)++replaceLocalBinds :: TCEmb TyCon+ -> M.HashMap TyCon RTyCon+ -> [(Var, Located SpecType)]+ -> [(Var, [Expr])]+ -> SEnv SortedReft+ -> CoreProgram+ -> ([(Var, Located SpecType)], [(Var, [Expr])])+replaceLocalBinds emb tyi sigs texprs senv cbs+ = (M.toList s, M.toList t)+ where+ (s,t) = execState (runReaderT (mapM_ (`traverseBinds` return ()) cbs)+ (RE M.empty senv emb tyi))+ (M.fromList sigs, M.fromList texprs)++traverseExprs (Let b e)+ = traverseBinds b (traverseExprs e)+traverseExprs (Lam b e)+ = withExtendedEnv [b] (traverseExprs e)+traverseExprs (App x y)+ = traverseExprs x >> traverseExprs y+traverseExprs (Case e _ _ as)+ = traverseExprs e >> mapM_ (traverseExprs . thd3) as+traverseExprs (Cast e _)+ = traverseExprs e+traverseExprs (Tick _ e)+ = traverseExprs e+traverseExprs _+ = return ()++traverseBinds b k = withExtendedEnv (bindersOf b) $ do+ mapM_ traverseExprs (rhssOfBind b)+ k++withExtendedEnv vs k+ = do RE env' fenv' emb tyi <- ask+ let env = L.foldl' (\m v -> M.insert (takeWhileSym (/='#') $ symbol v) (symbol v) m) env' vs+ fenv = L.foldl' (\m v -> insertSEnv (symbol v) (rTypeSortedReft emb (ofType $ varType v :: RSort)) m) fenv' vs+ withReaderT (const (RE env fenv emb tyi)) $ do+ mapM_ replaceLocalBindsOne vs+ k++replaceLocalBindsOne :: Var -> ReplaceM ()+replaceLocalBindsOne v+ = do mt <- gets (M.lookup v . fst)+ case mt of+ Nothing -> return ()+ Just (Loc l (toRTypeRep -> t@(RTypeRep {..}))) -> do+ (RE env' fenv emb tyi) <- ask+ let f m k = M.lookupDefault k k m+ let (env,args) = L.mapAccumL (\e (v,t) -> (M.insert v v e, substa (f e) t))+ env' (zip ty_binds ty_args)+ let res = substa (f env) ty_res+ let t' = fromRTypeRep $ t { ty_args = args, ty_res = res }+ let msg = ErrTySpec (sourcePosSrcSpan l) (pprint v) t'+ case checkTy msg emb tyi fenv t' of+ Just err -> Ex.throw err+ Nothing -> modify (first $ M.insert v (Loc l t'))+ mes <- gets (M.lookup v . snd)+ case mes of+ Nothing -> return ()+ Just es -> do+ let es' = substa (f env) es+ case checkTerminationExpr emb fenv (v, Loc l t', es') of+ Just err -> Ex.throw err+ Nothing -> modify (second $ M.insert v es')+
+ src/Language/Haskell/Liquid/Bare/Lookup.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.Bare.Lookup (+ GhcLookup(..)++ , lookupGhcThing+ , lookupGhcVar+ , lookupGhcTyCon+ , lookupGhcDataCon+ ) where++import BasicTypes+import ConLike+import DataCon+import GHC (HscEnv)+import HscMain+import Name+import PrelInfo (wiredInThings)+import PrelNames (fromIntegerName, smallIntegerName)+import RdrName (setRdrNameSpace)+import SrcLoc (SrcSpan, GenLocated(L))+import TcRnDriver (tcRnLookupRdrName) +import TcEnv+import TyCon+import TysWiredIn+import Var++import Control.Monad.Error (catchError, throwError)+import Control.Monad.State+import Data.Maybe+import Text.PrettyPrint.HughesPJ (text)++import qualified Data.List as L+import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Names (hpropConName, isPrefixOfSym, lengthSym, propConName, symbolString)+import Language.Fixpoint.Types (Symbol, Symbolic(..))++import Language.Haskell.Liquid.GhcMisc (lookupRdrName, sourcePosSrcSpan)+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.WiredIn++import Language.Haskell.Liquid.Bare.Env++-----------------------------------------------------------------+------ Querying GHC for Id, Type, Class, Con etc. ---------------+-----------------------------------------------------------------++class Symbolic a => GhcLookup a where+ lookupName :: HscEnv -> ModName -> a -> IO [Name]+ srcSpan :: a -> SrcSpan++instance GhcLookup (Located Symbol) where+ lookupName e m = symbolLookup e m . val+ srcSpan = sourcePosSrcSpan . loc++instance GhcLookup Name where+ lookupName _ _ = return . (:[])+ srcSpan = nameSrcSpan+++-- lookupGhcThing :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM b+lookupGhcThing name f x+ = do zs <- lookupGhcThing' name f x+ case zs of+ Just x' -> return x'+ Nothing -> throwError $ ErrGhc (srcSpan x) (text msg)+ where+ msg = "Not in scope: " ++ name ++ " `" ++ symbolString (symbol x) ++ "'"++-- lookupGhcThing' :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM (Maybe b)+lookupGhcThing' _ f x+ = do BE {modName = mod, hscEnv = env} <- get+ ns <- liftIO $ lookupName env mod x+ mts <- liftIO $ mapM (fmap (join . fmap f) . hscTcRcLookupName env) ns+ case catMaybes mts of+ [] -> return Nothing+ (t:_) -> return $ Just t++symbolLookup :: HscEnv -> ModName -> Symbol -> IO [Name]+symbolLookup env mod k+ | k `M.member` wiredIn+ = return $ maybeToList $ M.lookup k wiredIn+ | otherwise+ = symbolLookupEnv env mod k++wiredIn :: M.HashMap Symbol Name+wiredIn = M.fromList $ special ++ wiredIns + where+ wiredIns = [ (symbol n, n) | thing <- wiredInThings, let n = getName thing ]+ special = [ ("GHC.Integer.smallInteger", smallIntegerName)+ , ("GHC.Num.fromInteger" , fromIntegerName ) ]++symbolLookupEnv env mod s+ | isSrcImport mod+ = do let modName = getModName mod+ L _ rn <- hscParseIdentifier env $ symbolString s+ res <- lookupRdrName env modName rn+ -- 'hscParseIdentifier' defaults constructors to 'DataCon's, but we also+ -- need to get the 'TyCon's for declarations like @data Foo = Foo Int@.+ res' <- lookupRdrName env modName (setRdrNameSpace rn tcName)+ return $ catMaybes [res, res']+ | otherwise+ = do L _ rn <- hscParseIdentifier env $ symbolString s+ (_, lookupres) <- tcRnLookupRdrName env rn+ case lookupres of+ Just ns -> return ns+ _ -> return []+++-- | It's possible that we have already resolved the 'Name' we are looking for,+-- but have had to turn it back into a 'String', e.g. to be used in an 'Expr',+-- as in @{v:Ordering | v = EQ}@. In this case, the fully-qualified 'Name'+-- (@GHC.Types.EQ@) will likely not be in scope, so we store our own mapping of+-- fully-qualified 'Name's to 'Var's and prefer pulling 'Var's from it.+lookupGhcVar :: GhcLookup a => a -> BareM Var+lookupGhcVar x+ = do env <- gets varEnv+ case L.lookup (symbol x) env of+ Nothing -> lookupGhcThing "variable" fv x+ Just v -> return v+ where+ fv (AnId x) = Just x+ fv (AConLike (RealDataCon x)) = Just $ dataConWorkId x+ fv _ = Nothing+++lookupGhcTyCon :: GhcLookup a => a -> BareM TyCon+lookupGhcTyCon s = (lookupGhcThing "type constructor or class" ftc s)+ `catchError` (tryPropTyCon s)+ where + ftc (ATyCon x) = Just x+ ftc _ = Nothing++tryPropTyCon s e + | sx == propConName = return propTyCon+ | sx == hpropConName = return hpropTyCon+ | otherwise = throwError e+ where+ sx = symbol s+++lookupGhcDataCon dc = case isTupleDC $ val dc of+ Just n -> return $ tupleCon BoxedTuple n+ Nothing -> lookupGhcDataCon' dc ++isTupleDC zs+ | "(," `isPrefixOfSym` zs+ = Just $ lengthSym zs - 1+ | otherwise+ = Nothing++lookupGhcDataCon' = lookupGhcThing "data constructor" fdc+ where + fdc (AConLike (RealDataCon x)) = Just x+ fdc _ = Nothing+
+ src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.Measure (+ makeHaskellMeasures+ , makeHaskellInlines++ , makeMeasureSpec+ , makeMeasureSpec'++ , makeClassMeasureSpec+ , makeMeasureSelectors++ , strengthenHaskellMeasures++ , varMeasures+ ) where++import CoreSyn+import DataCon+import Id+import Name+import Type+import Var++import Control.Applicative ((<$>), (<*>))+import Control.Monad hiding (forM)+import Control.Monad.Error hiding (Error, forM)+import Control.Monad.State hiding (forM)+import Data.Bifunctor+import Data.Maybe+import Data.Monoid+import Data.Traversable (forM)+import Text.PrettyPrint.HughesPJ (text)+import Text.Parsec.Pos (SourcePos)++import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S++import Language.Fixpoint.Misc (hashMapMapKeys, mapFst, mapSnd, mlookup, sortNub)+import Language.Fixpoint.Names (dropModuleNames, dummySymbol)+import Language.Fixpoint.Types (Expr(..), Symbol, symbol)++import Language.Haskell.Liquid.CoreToLogic+import Language.Haskell.Liquid.GhcMisc (getSourcePos, sourcePosSrcSpan)+import Language.Haskell.Liquid.RefType (dataConSymbol, generalize, ofType, uRType)+import Language.Haskell.Liquid.Types++import qualified Language.Haskell.Liquid.Measure as Ms++import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Expand+import Language.Haskell.Liquid.Bare.Lookup+import Language.Haskell.Liquid.Bare.OfType+import Language.Haskell.Liquid.Bare.Resolve+import Language.Haskell.Liquid.Bare.RefToLogic++makeHaskellMeasures :: [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM (Ms.MSpec SpecType DataCon)+makeHaskellMeasures _ name' (name, _ ) | name /= name' + = return mempty+makeHaskellMeasures cbs _ (_ , spec) + = do lmap <- gets logicEnv+ Ms.mkMSpec' <$> mapM (makeMeasureDefinition lmap cbs') (S.toList $ Ms.hmeas spec)+ where + cbs' = concatMap unrec cbs+ unrec cb@(NonRec _ _) = [cb]+ unrec (Rec xes) = [NonRec x e | (x, e) <- xes]+++makeHaskellInlines :: [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM ()+makeHaskellInlines _ name' (name, _ ) | name /= name' + = return mempty+makeHaskellInlines cbs _ (_ , spec) + = do lmap <- gets logicEnv+ mapM_ (makeMeasureInline lmap cbs') (S.toList $ Ms.inlines spec) + where + cbs' = concatMap unrec cbs+ unrec cb@(NonRec _ _) = [cb]+ unrec (Rec xes) = [NonRec x e | (x, e) <- xes]+++makeMeasureInline :: LogicMap -> [CoreBind] -> LocSymbol -> BareM ()+makeMeasureInline lmap cbs x + = case (filter ((val x `elem`) . (map (dropModuleNames . simplesymbol)) . binders) cbs) of+ (NonRec v def:_) -> do {e <- coreToFun' x v def; updateInlines x e}+ (Rec [(v, def)]:_) -> do {e <- coreToFun' x v def; updateInlines x e}+ _ -> throwError $ mkError "Cannot inline haskell function"+ where+ binders (NonRec x _) = [x]+ binders (Rec xes) = fst <$> xes ++ coreToFun' x v def = case (runToLogic lmap mkError $ coreToFun x v def) of + Left (xs, e) -> return (TI xs e)+ Right e -> throwError e++ mkError :: String -> Error+ mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str) ++++updateInlines x v = modify $ \s -> let iold = M.insert (val x) v (inlines s) in + s{inlines = M.map (f iold) iold }+ where f imap = txRefToLogic mempty imap +++makeMeasureDefinition :: LogicMap -> [CoreBind] -> LocSymbol -> BareM (Measure SpecType DataCon)+makeMeasureDefinition lmap cbs x + = case (filter ((val x `elem`) . (map (dropModuleNames . simplesymbol)) . binders) cbs) of+ (NonRec v def:_) -> (Ms.mkM x (logicType $ varType v)) <$> coreToDef' x v def+ (Rec [(v, def)]:_) -> (Ms.mkM x (logicType $ varType v)) <$> coreToDef' x v def+ _ -> throwError $ mkError "Cannot extract measure from haskell function"+ where+ binders (NonRec x _) = [x]+ binders (Rec xes) = fst <$> xes ++ coreToDef' x v def = case (runToLogic lmap mkError $ coreToDef x v def) of + Left l -> return l+ Right e -> throwError e++ mkError :: String -> Error+ mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str) ++simplesymbol = symbol . getName++strengthenHaskellMeasures :: S.HashSet (Located Var) -> [(Var, Located SpecType)]+strengthenHaskellMeasures hmeas = (\v -> (val v, fmap strengthenResult v)) <$> (S.toList hmeas)++makeMeasureSelectors :: (DataCon, Located DataConP) -> [Measure SpecType DataCon]+makeMeasureSelectors (dc, (Loc loc (DataConP _ vs _ _ _ xts r))) = go <$> zip (reverse xts) [1..]+ where+ go ((x,t), i) = makeMeasureSelector (Loc loc x) (dty t) dc n i+ + dty t = foldr RAllT (RFun dummySymbol r (fmap mempty t) mempty) vs+ n = length xts++makeMeasureSelector x s dc n i = M {name = x, sort = s, eqns = [eqn]}+ where eqn = Def x dc (mkx <$> [1 .. n]) (E (EVar $ mkx i)) + mkx j = symbol ("xx" ++ show j)+++makeMeasureSpec :: (ModName, Ms.Spec BareType LocSymbol) -> BareM (Ms.MSpec SpecType DataCon)+makeMeasureSpec (mod,spec) = inModule mod mkSpec+ where+ mkSpec = mkMeasureDCon =<< mkMeasureSort =<< m+ m = Ms.mkMSpec <$> (mapM expandMeasure $ Ms.measures spec)+ <*> return (Ms.cmeasures spec)+ <*> (mapM expandMeasure $ Ms.imeasures spec)++makeMeasureSpec' = mapFst (mapSnd uRType <$>) . Ms.dataConTypes . first (mapReft ur_reft)++makeClassMeasureSpec (Ms.MSpec {..}) = tx <$> M.elems cmeasMap+ where+ tx (M n s _) = (n, CM n (mapReft ur_reft s) -- [(t,m) | (IM n' t m) <- imeas, n == n']+ )+++mkMeasureDCon :: Ms.MSpec t LocSymbol -> BareM (Ms.MSpec t DataCon)+mkMeasureDCon m = (forM (measureCtors m) $ \n -> (val n,) <$> lookupGhcDataCon n)+ >>= (return . mkMeasureDCon_ m)++mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(Symbol, DataCon)] -> Ms.MSpec t DataCon+mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}+ where + m' = fmap (tx.val) m+ cm' = hashMapMapKeys (tx' . tx) $ Ms.ctorMap m'+ tx = mlookup (M.fromList ndcs)+ tx' = dataConSymbol++measureCtors :: Ms.MSpec t LocSymbol -> [LocSymbol]+measureCtors = sortNub . fmap ctor . concat . M.elems . Ms.ctorMap++-- mkMeasureSort :: (PVarable pv, Reftable r) => Ms.MSpec (BRType pv r) bndr-> BareM (Ms.MSpec (RRType pv r) bndr)+mkMeasureSort (Ms.MSpec c mm cm im)+ = Ms.MSpec c <$> forM mm tx <*> forM cm tx <*> forM im tx+ where+ tx m = liftM (\s' -> m {sort = s'}) (ofMeaSort (sort m))++++varMeasures vars = [ (symbol v, varSpecType v) | v <- vars, isDataConWorkId v, isSimpleType $ varType v ]+varSpecType v = Loc (getSourcePos v) (ofType $ varType v)+isSimpleType t = null tvs && isNothing (splitFunTy_maybe tb) where (tvs, tb) = splitForAllTys t ++++--------------------------------------------------------------------------------+-- Expand Measures -------------------------------------------------------------+--------------------------------------------------------------------------------++expandMeasure m+ = do eqns <- sequence $ expandMeasureDef <$> (eqns m)+ return $ m { sort = generalize (sort m)+ , eqns = eqns }++expandMeasureDef :: Def LocSymbol -> BareM (Def LocSymbol)+expandMeasureDef d+ = do body <- expandMeasureBody (loc $ measure d) $ body d+ return $ d { body = body }++expandMeasureBody :: SourcePos -> Body -> BareM Body+expandMeasureBody l (P p) = P <$> (resolve l =<< expandPred p)+expandMeasureBody l (R x p) = R x <$> (resolve l =<< expandPred p)+expandMeasureBody l (E e) = E <$> resolve l e+
+ src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -0,0 +1,134 @@+module Language.Haskell.Liquid.Bare.Misc (+ makeSymbols++ , joinVar++ , mkVarExpr++ , MapTyVarST(..)+ , initMapSt+ , runMapTyVars+ , mapTyVars++ , symbolRTyVar+ ) where++import Id+import Type+import TypeRep+import Var++import Control.Applicative ((<$>))+import Control.Monad.Error (throwError)+import Control.Monad.State+import Data.Maybe (isNothing)++import qualified Data.List as L++import Language.Fixpoint.Misc (sortDiff, sortNub)+import Language.Fixpoint.Types (Expr(..), Reft(..), Reftable(..), emptySEnv, memberSEnv, symbol, syms, toReft)++import Language.Haskell.Liquid.GhcMisc (showPpr)+import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.Types++import Language.Haskell.Liquid.Bare.Env++-- TODO: This is where unsorted stuff is for now. Find proper places for what follows.++-- WTF does this function do?+makeSymbols vs xs' xts yts ivs+ = do svs <- gets varEnv+ return [ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)]+ where+ xs = sortNub $ zs ++ zs' ++ zs''+ zs = concatMap freeSymbols (snd <$> xts) `sortDiff` xs'+ zs' = concatMap freeSymbols (snd <$> yts) `sortDiff` xs'+ zs'' = concatMap freeSymbols ivs `sortDiff` xs'+ +freeSymbols ty = sortNub $ concat $ efoldReft (\_ _ -> []) (\ _ -> ()) f (\_ -> id) emptySEnv [] (val ty)+ where + f γ _ r xs = let Reft (v, _) = toReft r in + [ x | x <- syms r, x /= v, not (x `memberSEnv` γ)] : xs+++-------------------------------------------------------------------------------+-- Renaming Type Variables in Haskell Signatures ------------------------------+-------------------------------------------------------------------------------++data MapTyVarST = MTVST { vmap :: [(Var, RTyVar)]+ , errmsg :: Error + }++initMapSt = MTVST []++-- TODO: Maybe don't expose this; instead, roll this in with mapTyVar and export a+-- single "clean" function as the API.+runMapTyVars :: StateT MapTyVarST (Either Error) () -> MapTyVarST -> Either Error MapTyVarST+runMapTyVars x s = execStateT x s++mapTyVars :: (PPrint r, Reftable r) => Type -> RRType r -> StateT MapTyVarST (Either Error) ()+mapTyVars τ (RAllT _ t) + = mapTyVars τ t+mapTyVars (ForAllTy _ τ) t + = mapTyVars τ t+mapTyVars (FunTy τ τ') (RFun _ t t' _) + = mapTyVars τ t >> mapTyVars τ' t'+mapTyVars (TyConApp _ τs) (RApp _ ts _ _) + = zipWithM_ mapTyVars τs ts+mapTyVars (TyVarTy α) (RVar a _) + = do s <- get+ s' <- mapTyRVar α a s+ put s'+mapTyVars τ (RAllP _ t) + = mapTyVars τ t +mapTyVars τ (RAllS _ t) + = mapTyVars τ t +mapTyVars τ (RAllE _ _ t) + = mapTyVars τ t +mapTyVars τ (RRTy _ _ _ t)+ = mapTyVars τ t+mapTyVars τ (REx _ _ t)+ = mapTyVars τ t +mapTyVars _ (RExprArg _)+ = return ()+mapTyVars (AppTy τ τ') (RAppTy t t' _) + = do mapTyVars τ t + mapTyVars τ' t' +mapTyVars _ (RHole _)+ = return ()+mapTyVars _ _+ = throwError =<< errmsg <$> get++mapTyRVar α a s@(MTVST αas err)+ = case lookup α αas of+ Just a' | a == a' -> return s+ | otherwise -> throwError err+ Nothing -> return $ MTVST ((α,a):αas) err+++++mkVarExpr v + | isFunVar v = EApp (varFunSymbol v) []+ | otherwise = EVar (symbol v)++varFunSymbol = dummyLoc . dataConSymbol . idDataCon ++isFunVar v = isDataConWorkId v && not (null αs) && isNothing tf+ where+ (αs, t) = splitForAllTys $ varType v + tf = splitFunTy_maybe t++-- the Vars we lookup in GHC don't always have the same tyvars as the Vars+-- we're given, so return the original var when possible.+-- see tests/pos/ResolvePred.hs for an example+joinVar :: [Var] -> (Var, s, t) -> (Var, s, t)+joinVar vs (v,s,t) = case L.find ((== showPpr v) . showPpr) vs of+ Just v' -> (v',s,t)+ Nothing -> (v,s,t)+++++
+ src/Language/Haskell/Liquid/Bare/OfType.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.OfType (+ ofBareType+ , ofMeaSort+ , ofBSort++ , ofBPVar++ , mkSpecType+ , mkSpecType'+ ) where++import BasicTypes+import TyCon+import Type (expandTypeSynonyms)+import TysWiredIn++import Control.Applicative+import Control.Monad.Reader hiding (forM)+import Control.Monad.State hiding (forM)+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Traversable (forM)+import Text.Parsec.Pos+import Text.Printf++import qualified Control.Exception as Ex +import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Misc (errorstar)+import Language.Fixpoint.Types (Expr(..), Reftable, Symbol, meet, mkSubst, subst, symbol)++import Language.Haskell.Liquid.GhcMisc (sourcePosSrcSpan)+import Language.Haskell.Liquid.Misc (secondM)+import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.Types++import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Expand+import Language.Haskell.Liquid.Bare.Lookup+import Language.Haskell.Liquid.Bare.Resolve+-- import Language.Haskell.Liquid.Bare.RefToLogic++--------------------------------------------------------------------------------++ofBareType :: SourcePos -> BareType -> BareM SpecType+ofBareType l+ = ofBRType expandRTAliasApp (resolve l <=< expandReft)++ofMeaSort :: BareType -> BareM SpecType+ofMeaSort+ = ofBRType failRTAliasApp return++ofBSort :: BSort -> BareM RSort+ofBSort+ = ofBRType failRTAliasApp return ++--------------------------------------------------------------------------------++ofBPVar :: BPVar -> BareM RPVar+ofBPVar+ = mapM_pvar ofBSort++mapM_pvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b)+mapM_pvar f (PV x t v txys) + = do t' <- forM t f + txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys + return $ PV x t' v txys'++--------------------------------------------------------------------------------++mkSpecType :: SourcePos -> BareType -> BareM SpecType+mkSpecType l t+ = mkSpecType' l (ty_preds $ toRTypeRep t) t++mkSpecType' :: SourcePos -> [PVar BSort] -> BareType -> BareM SpecType+mkSpecType' l πs t+ = ofBRType expandRTAliasApp resolveReft t+ where+ resolveReft+ = (resolve l <=< expandReft) . txParam subvUReft (uPVar <$> πs) t+++txParam f πs t = f (txPvar (predMap πs t))++txPvar :: M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar +txPvar m π = π { pargs = args' }+ where args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)+ | otherwise = pargs π'+ π' = fromMaybe (errorstar err) $ M.lookup (pname π) m+ err = "Bare.replaceParams Unbound Predicate Variable: " ++ show π++predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]++rtypePredBinds = map uPVar . ty_preds . toRTypeRep++--------------------------------------------------------------------------------++ofBRType :: (PPrint r, Reftable r)+ => (SourcePos -> RTAlias RTyVar SpecType -> [BRType r] -> r -> BareM (RRType r))+ -> (r -> BareM r)+ -> BRType r+ -> BareM (RRType r)+ofBRType appRTAlias resolveReft+ = go+ where+ go (RApp lc@(Loc l c) ts rs r)+ = do env <- gets (typeAliases.rtEnv)+ r' <- resolveReft r+ case M.lookup c env of+ Just rta ->+ appRTAlias l rta ts r'+ Nothing ->+ do c' <- matchTyCon lc (length ts)+ bareTCApp r' c' <$> mapM go_ref rs <*> mapM go ts++ go (RAppTy t1 t2 r)+ = RAppTy <$> go t1 <*> go t2 <*> resolveReft r+ go (RFun x t1 t2 _)+ = rFun x <$> go t1 <*> go t2+ go (RVar a r)+ = RVar (symbolRTyVar a) <$> resolveReft r+ go (RAllT a t)+ = RAllT (symbolRTyVar a) <$> go t+ go (RAllP a t)+ = RAllP <$> ofBPVar a <*> go t+ go (RAllS x t)+ = RAllS x <$> go t+ go (RAllE x t1 t2)+ = RAllE x <$> go t1 <*> go t2+ go (REx x t1 t2)+ = REx x <$> go t1 <*> go t2+ go (RRTy e r o t)+ = RRTy <$> mapM (secondM go) e <*> resolveReft r <*> pure o <*> go t+ go (RHole r)+ = RHole <$> resolveReft r+ go (RExprArg e)+ = return $ RExprArg e++ go_ref (RPropP ss r)+ = RPropP <$> mapM go_syms ss <*> resolveReft r+ go_ref (RProp ss t)+ = RProp <$> mapM go_syms ss <*> go t+ go_ref (RHProp _ _)+ = errorstar "TODO:EFFECTS:ofBRType"++ go_syms+ = secondM ofBSort++matchTyCon :: LocSymbol -> Int -> BareM TyCon+matchTyCon lc@(Loc _ c) arity+ | isList c && arity == 1+ = return listTyCon+ | isTuple c+ = return $ tupleTyCon BoxedTuple arity+ | otherwise+ = lookupGhcTyCon lc++--------------------------------------------------------------------------------++failRTAliasApp :: SourcePos -> RTAlias RTyVar SpecType -> [BRType r] -> r -> BareM (RRType r)+failRTAliasApp l rta _ _+ = Ex.throw err+ where+ err :: Error+ err = ErrIllegalAliasApp (sourcePosSrcSpan l) (pprint $ rtName rta) (sourcePosSrcSpan $ rtPos rta)+++expandRTAliasApp :: SourcePos -> RTAlias RTyVar SpecType -> [BareType] -> RReft -> BareM SpecType+expandRTAliasApp l rta args r+ | length args == length αs + length εs+ = do args' <- mapM (ofBareType l) args+ let ts = take (length αs) args'+ αts = zipWith (\α t -> (α, toRSort t, t)) αs ts+ return $ subst su . (`strengthen` r) . subsTyVars_meet αts $ rtBody rta+ | otherwise+ = Ex.throw err+ where+ su = mkSubst $ zip (symbol <$> εs) es+ αs = rtTArgs rta + εs = rtVArgs rta+ es_ = drop (length αs) args+ es = map (exprArg $ show err) es_+ err :: Error+ err = ErrAliasApp (sourcePosSrcSpan l) (length args) (pprint $ rtName rta) (sourcePosSrcSpan $ rtPos rta) (length αs + length εs) ++-- | exprArg converts a tyVar to an exprVar because parser cannot tell +-- HORRIBLE HACK To allow treating upperCase X as value variables X+-- e.g. type Matrix a Row Col = List (List a Row) Col++exprArg _ (RExprArg e) + = e+exprArg _ (RVar x _) + = EVar (symbol x)+exprArg _ (RApp x [] [] _) + = EVar (symbol x)+exprArg msg (RApp f ts [] _) + = EApp (symbol <$> f) (exprArg msg <$> ts)+exprArg msg (RAppTy (RVar f _) t _) + = EApp (dummyLoc $ symbol f) [exprArg msg t]+exprArg msg z + = errorstar $ printf "Unexpected expression parameter: %s in %s" (show z) msg ++--------------------------------------------------------------------------------++bareTCApp r c rs ts | Just (SynonymTyCon rhs) <- synTyConRhs_maybe c+ = tyApp (subsTyVars_meet su $ ofType rhs) (drop nts ts) rs r + where tvs = tyConTyVars c+ su = zipWith (\a t -> (rTyVar a, toRSort t, t)) tvs ts+ nts = length tvs++-- TODO expandTypeSynonyms here to+bareTCApp r c rs ts | isFamilyTyCon c && isTrivial t+ = expandRTypeSynonyms $ t `strengthen` r + where t = rApp c ts rs mempty++bareTCApp r c rs ts + = rApp c ts rs r++tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `meet` r')+tyApp t [] [] r = t `strengthen` r+tyApp _ _ _ _ = errorstar $ "Bare.Type.tyApp on invalid inputs"++expandRTypeSynonyms :: (PPrint r, Reftable r) => RRType r -> RRType r+expandRTypeSynonyms = ofType . expandTypeSynonyms . toType+
+ src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.Plugged (+ makePluggedSigs+ , makePluggedAsmSigs+ , makePluggedDataCons+ ) where++import DataCon+import Module+import Name+import NameSet+import TyCon+import Type (expandTypeSynonyms)+import Var++import Control.Applicative ((<$>), (<*>))+import Control.Monad+import Control.Monad.Error+import Data.Generics.Aliases (mkT)+import Data.Generics.Schemes (everywhere)+import Data.Monoid+import Text.PrettyPrint.HughesPJ+import Text.Printf++import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Names (dummySymbol)+import Language.Fixpoint.Types (Reft(..), TCEmb)++import Language.Haskell.Liquid.GhcMisc (sourcePosSrcSpan)+import Language.Haskell.Liquid.RefType (addTyConInfo, ofType, rVar, rTyVar, subts, toType, uReft)+import Language.Haskell.Liquid.Types++import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Misc++makePluggedSigs name embs tcEnv exports sigs+ = forM sigs $ \(x,t) -> do+ let τ = expandTypeSynonyms $ varType x+ let r = maybeTrue x name exports+ (x,) <$> plugHoles embs tcEnv x r τ t++makePluggedAsmSigs embs tcEnv sigs+ = forM sigs $ \(x,t) -> do+ let τ = expandTypeSynonyms $ varType x+ let r = killHoles+ (x,) <$> plugHoles embs tcEnv x r τ t++makePluggedDataCons embs tcEnv dcs+ = forM dcs $ \(dc, Loc l dcp) -> do+ let (das, _, dts, dt) = dataConSig dc+ tyArgs <- zipWithM (\t1 (x,t2) -> + (x,) . val <$> plugHoles embs tcEnv (dataConName dc) killHoles t1 (Loc l t2)) + dts (reverse $ tyArgs dcp)+ tyRes <- val <$> plugHoles embs tcEnv (dataConName dc) killHoles dt (Loc l (tyRes dcp))+ return (dc, Loc l dcp { freeTyVars = map rTyVar das+ , freePred = map (subts (zip (freeTyVars dcp) (map (rVar :: TyVar -> RSort) das))) (freePred dcp)+ , tyArgs = reverse tyArgs+ , tyRes = tyRes})+++plugHoles tce tyi x f t (Loc l st) + = do tyvsmap <- case runMapTyVars (mapTyVars (toType rt') st'') initvmap of+ Left e -> throwError e+ Right s -> return $ vmap s+ let su = [(y, rTyVar x) | (x, y) <- tyvsmap]+ st''' = subts su st''+ ps' = fmap (subts su') <$> ps+ su' = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]+ Loc l . mkArrow αs ps' (ls1 ++ ls2) [] . pushCls cs' <$> go rt' st'''+ where+ (αs, _, ls1, rt) = bkUniv (ofType t :: SpecType)+ (cs, rt') = bkClass rt++ (_, ps, ls2, st') = bkUniv st+ (_, st'') = bkClass st'+ cs' = [(dummySymbol, RApp c t [] mempty) | (c,t) <- cs]+ initvmap = initMapSt $ ErrMismatch (sourcePosSrcSpan l) (pprint x) t st++ go :: SpecType -> SpecType -> BareM SpecType+ go t (RHole r) = return $ (addHoles t') { rt_reft = f r }+ where+ t' = everywhere (mkT $ addRefs tce tyi) t+ addHoles = fmap (const $ f $ uReft ("v", [hole]))+ go (RVar _ _) v@(RVar _ _) = return v+ go (RFun _ i o _) (RFun x i' o' r) = RFun x <$> go i i' <*> go o o' <*> return r+ go (RAllT _ t) (RAllT a t') = RAllT a <$> go t t'+ go (RAllT a t) t' = RAllT a <$> go t t'+ go t (RAllE b a t') = RAllE b a <$> go t t'+ go t (REx b x t') = REx b x <$> go t t'+ go t (RRTy e r o t') = RRTy e r o <$> go t t'+ go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy <$> go t1 t1' <*> go t2 t2' <*> return r+ go (RApp _ t _ _) (RApp c t' p r) = RApp c <$> (zipWithM go t t') <*> return p <*> return r+ go t st = throwError err+ where+ err = errOther $ text $ printf "plugHoles: unhandled case!\nt = %s\nst = %s\n" (showpp t) (showpp st)++ pushCls cs (RRTy e r o t) = RRTy e r o (pushCls cs t)+ pushCls cs t = foldr (uncurry rFun) t cs ++addRefs :: TCEmb TyCon+ -> M.HashMap TyCon RTyCon+ -> SpecType+ -> SpecType+addRefs tce tyi (RApp c ts _ r) = RApp c' ts ps r+ where+ RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r)+addRefs _ _ t = t+++maybeTrue :: NamedThing a => a -> ModName -> NameSet -> RReft -> RReft+maybeTrue x target exports r+ | isInternalName name || inTarget && notExported+ = r+ | otherwise+ = killHoles r+ where+ inTarget = moduleName (nameModule name) == getModName target+ name = getName x+ notExported = not $ getName x `elemNameSet` exports++killHoles r@(U (Reft (v,rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) }+
+ src/Language/Haskell/Liquid/Bare/RTEnv.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.RTEnv (+ makeRTEnv+ ) where++import Control.Applicative ((<$>))+import Data.Graph hiding (Graph)+import Data.Maybe++import qualified Control.Exception as Ex+import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Misc (errorstar, fst3)+import Language.Fixpoint.Types (Expr(..), Pred(..), Symbol)++import Language.Haskell.Liquid.GhcMisc (sourcePosSrcSpan)+import Language.Haskell.Liquid.Misc (ordNub)+import Language.Haskell.Liquid.RefType (symbolRTyVar)+import Language.Haskell.Liquid.Types++import qualified Language.Haskell.Liquid.Measure as Ms++import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Expand+import Language.Haskell.Liquid.Bare.OfType+import Language.Haskell.Liquid.Bare.Resolve++--------------------------------------------------------------------------------++makeRTEnv specs+ = do makeREAliases ets+ makeRPAliases pts+ makeRTAliases rts+ where+ rts = (concat [(m,) <$> Ms.aliases s | (m, s) <- specs])+ pts = (concat [(m,) <$> Ms.paliases s | (m, s) <- specs])+ ets = (concat [(m,) <$> Ms.ealiases s | (m, s) <- specs])+++makeRTAliases+ = graphExpand buildTypeEdges expBody+ where+ expBody (mod, xt)+ = inModule mod $ + do let l = rtPos xt+ body <- withVArgs l (rtVArgs xt) $ ofBareType l $ rtBody xt+ setRTAlias (rtName xt) $ mapRTAVars symbolRTyVar $ xt { rtBody = body}++makeRPAliases+ = graphExpand buildPredEdges expBody+ where + expBody (mod, xt)+ = inModule mod $+ do let l = rtPos xt+ body <- withVArgs l (rtVArgs xt) $ resolve l =<< (expandPred $ rtBody xt)+ setRPAlias (rtName xt) $ xt { rtBody = body }++makeREAliases+ = graphExpand buildExprEdges expBody+ where + expBody (mod, xt)+ = inModule mod $+ do let l = rtPos xt+ body <- withVArgs l (rtVArgs xt) $ resolve l =<< (expandExpr $ rtBody xt)+ setREAlias (rtName xt) $ xt { rtBody = body }+++graphExpand buildEdges expBody xts+ = do let table = buildAliasTable xts+ graph = buildAliasGraph (buildEdges table) (map snd xts)+ checkCyclicAliases table graph++ mapM_ expBody $ genExpandOrder table graph++--------------------------------------------------------------------------------++type AliasTable t = M.HashMap Symbol (ModName, RTAlias Symbol t)++buildAliasTable :: [(ModName, RTAlias Symbol t)] -> AliasTable t+buildAliasTable+ = M.fromList . map (\(mod, rta) -> (rtName rta, (mod, rta)))++fromAliasSymbol :: AliasTable t -> Symbol -> (ModName, RTAlias Symbol t)+fromAliasSymbol table sym+ = fromMaybe err $ M.lookup sym table+ where+ err = errorstar $ "fromAliasSymbol: Dangling alias symbol: " ++ show sym+++type Graph t = [Node t]+type Node t = (t, t, [t])++buildAliasGraph :: (t -> [Symbol]) -> [RTAlias Symbol t] -> Graph Symbol+buildAliasGraph buildEdges+ = map (buildAliasNode buildEdges)++buildAliasNode :: (t -> [Symbol]) -> RTAlias Symbol t -> Node Symbol+buildAliasNode buildEdges alias+ = (rtName alias, rtName alias, buildEdges $ rtBody alias)+++checkCyclicAliases :: AliasTable t -> Graph Symbol -> BareM ()+checkCyclicAliases table graph+ = case mapMaybe go $ stronglyConnComp graph of+ [] ->+ return ()+ sccs ->+ Ex.throw $ map err sccs+ where+ go (AcyclicSCC _)+ = Nothing+ go (CyclicSCC vs)+ = Just vs++ err :: [Symbol] -> Error+ err scc@(rta:_)+ = ErrAliasCycle { pos = fst $ locate rta+ , acycle = map locate scc+ }+ err []+ = errorstar "Bare.RTEnv.checkCyclicAliases: No type aliases in reported cycle"++ locate sym+ = ( sourcePosSrcSpan $ rtPos $ snd $ fromAliasSymbol table sym+ , pprint sym+ )+++genExpandOrder :: AliasTable t -> Graph Symbol -> [(ModName, RTAlias Symbol t)]+genExpandOrder table graph + = map (fromAliasSymbol table) symOrder+ where+ (digraph, lookupVertex, _)+ = graphFromEdges graph+ symOrder+ = map (fst3 . lookupVertex) $ reverse $ topSort digraph++--------------------------------------------------------------------------------++buildTypeEdges :: AliasTable BareType -> BareType -> [Symbol]+buildTypeEdges table+ = ordNub . go+ where go :: BareType -> [Symbol]+ go (RApp (Loc _ c) ts rs _)+ = go_alias c ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)++ go (RFun _ t1 t2 _)+ = go t1 ++ go t2+ go (RAppTy t1 t2 _)+ = go t1 ++ go t2+ go (RAllE _ t1 t2)+ = go t1 ++ go t2+ go (REx _ t1 t2)+ = go t1 ++ go t2+ go (RAllT _ t)+ = go t+ go (RAllP _ t)+ = go t+ go (RAllS _ t)+ = go t++ go (RVar _ _)+ = []+ go (RExprArg _)+ = []+ go (RHole _)+ = []++ go (RRTy env _ _ t)+ = concatMap (go . snd) env ++ go t++ go_alias c+ = case M.lookup c table of+ Just _ -> [c]+ Nothing -> [ ]++ go_ref (RPropP _ _) = Nothing+ go_ref (RProp _ t) = Just t+ go_ref (RHProp _ _) = errorstar "TODO:EFFECTS:buildTypeEdges"++buildPredEdges :: AliasTable Pred -> Pred -> [Symbol]+buildPredEdges table+ = ordNub . go+ where go :: Pred -> [Symbol]+ go (PBexp (EApp (Loc _ f) _))+ = case M.lookup f table of+ Just _ -> [f]+ Nothing -> [ ]+ go (PBexp _)+ = []++ go (PAnd ps)+ = concatMap go ps+ go (POr ps)+ = concatMap go ps++ go (PNot p)+ = go p++ go (PImp p q)+ = go p ++ go q+ go (PIff p q)+ = go p ++ go q++ go (PAll _ p)+ = go p++ go (PAtom _ _ _)+ = []++ go PTrue+ = []+ go PFalse+ = []+ go PTop+ = []++buildExprEdges table+ = ordNub . go+ where go :: Expr -> [Symbol]+ go (EApp (Loc _ f) es)+ = go_alias f ++ concatMap go es++ go (EBin _ e1 e2)+ = go e1 ++ go e2+ go (EIte _ e1 e2)+ = go e1 ++ go e2++ go (ECst e _)+ = go e++ go (ELit _ _)+ = []+ go (ESym _)+ = []+ go (ECon _)+ = []+ go (EVar _)+ = []++ go EBot+ = []++ go_alias f+ = case M.lookup f table of+ Just _ -> [f]+ Nothing -> [ ]+
+ src/Language/Haskell/Liquid/Bare/RefToLogic.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.Liquid.Bare.RefToLogic (+ txRefToLogic, Transformable+ ) where++import Language.Haskell.Liquid.Types+++import Language.Haskell.Liquid.Bare.Env++import Language.Fixpoint.Types hiding (Def, R) +import Language.Fixpoint.Misc +import Language.Fixpoint.Names (dropModuleNames)++import qualified Data.HashMap.Strict as M++import Control.Applicative ((<$>))++txRefToLogic :: (Transformable r) => LogicMap -> InlnEnv -> r -> r+txRefToLogic lmap imap t = tx' lmap imap t+++class Transformable a where+ tx :: Symbol -> (Either LMap TInline) -> a -> a ++ tx' :: LogicMap -> InlnEnv -> a -> a+ tx' lmap imap x = M.foldrWithKey tx x limap+ where limap = M.fromList ((mapSnd Left <$> M.toList lmap) ++ (mapSnd Right <$> M.toList imap)) +++instance (Transformable a) => (Transformable [a]) where+ tx s m xs = tx s m <$> xs ++instance Transformable DataConP where+ tx s m x = x{ tyConsts = tx s m (tyConsts x)+ , tyArgs = mapSnd (tx s m) <$> (tyArgs x)+ , tyRes = tx s m (tyRes x)+ }++instance Transformable TInline where+ tx s m (TI xs e) = TI xs (tx s m e) ++instance (Transformable r) => Transformable (RType c v r) where + tx s m = fmap (tx s m)++instance Transformable RReft where + tx s m = fmap (tx s m)++instance Transformable Reft where + tx s m (Reft(v, refas))+ = if v == s + then errorstar "Transformable: this should not happen"+ else Reft(v, tx s m <$> refas)++instance Transformable Refa where+ tx s m (RConc p) = RConc $ tx s m p + tx _ _ (RKvar x sub) = RKvar x sub++instance (Transformable a, Transformable b) => Transformable (Either a b) where+ tx s m (Left x) = Left (tx s m x)+ tx s m (Right x) = Right (tx s m x)++instance Transformable Pred where+ tx _ _ PTrue = PTrue+ tx _ _ PFalse = PFalse+ tx _ _ PTop = PTop+ tx s m (PAnd ps) = PAnd (tx s m <$> ps)+ tx s m (POr ps) = POr (tx s m <$> ps)+ tx s m (PNot p) = PNot (tx s m p)+ tx s m (PImp p1 p2) = PImp (tx s m p1) (tx s m p2)+ tx s m (PIff p1 p2) = PIff (tx s m p1) (tx s m p2)+ tx s m (PBexp (EApp f es)) = txPApp (s, m) f es+ tx s m (PBexp e) = PBexp (tx s m e)+ tx s m (PAtom r e1 e2) = PAtom r (tx s m e1) (tx s m e2)+ tx s m (PAll xss p) + = if (s `elem` (fst <$> xss)) + then errorstar "Transformable.tx on Pred: this should not happen" + else PAll xss (tx s m p) ++instance Transformable Expr where+ tx s m (EVar s') + | cmpSymbol s s' = mexpr m+ | otherwise = EVar s'+ tx s m (EApp f es) = txEApp (s, m) f es+ tx _ _ (ESym c) = ESym c+ tx _ _ (ECon c) = ECon c+ tx _ _ (ELit l s') = ELit l s'+ tx s m (EBin o e1 e2) = EBin o (tx s m e1) (tx s m e2)+ tx s m (EIte p e1 e2) = EIte (tx s m p) (tx s m e1) (tx s m e2)+ tx s m (ECst e s') = ECst (tx s m e) s'+ tx _ _ EBot = EBot++instance Transformable (Measure t c) where+ tx s m x = x{eqns = tx s m <$> (eqns x)}++instance Transformable (Def c) where+ tx s m x = x{body = tx s m (body x)} ++instance Transformable Body where+ tx s m (E e) = E $ tx s m e+ tx s m (P p) = P $ tx s m p+ tx s m (R v p) = R v $ tx s m p++mexpr (Left (LMap _ _ e)) = e+mexpr (Right (TI _ (Right e))) = e+mexpr _ = errorstar "mexpr"++txEApp (s, (Left (LMap _ xs e))) f es + | cmpSymbol s (val f) + = subst (mkSubst $ zip xs es) e+ | otherwise + = EApp f es++txEApp (s, (Right (TI xs (Right e)))) f es + | cmpSymbol s (val f) + = subst (mkSubst $ zip xs es) e+ | otherwise + = EApp f es+++txEApp (s, (Right (TI _ (Left _)))) f es + | cmpSymbol s (val f) + = errorstar "txEApp: deep internal error"+ | otherwise + = EApp f es+++txPApp (s, (Right (TI xs (Left e)))) f es + | cmpSymbol s (val f) + = subst (mkSubst $ zip xs es) e+ | otherwise + = PBexp $ EApp f es++txPApp (s, m) f es = PBexp $ txEApp (s, m) f es++cmpSymbol s1 {- symbol in Core -} s2 {- logical Symbol-}+ = (dropModuleNames s1) == s2
+ src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-} ++module Language.Haskell.Liquid.Bare.Resolve (+ Resolvable(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad.State+import Data.Char (isUpper)+import Text.Parsec.Pos++import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Names (prims)+import Language.Fixpoint.Types (Expr(..), Pred(..), Qualifier(..), Refa(..), Reft(..), Sort(..), Symbol, fTyconSymbol, symbol, symbolFTycon, symbolText)++import Language.Haskell.Liquid.Misc (secondM, third3M)+import Language.Haskell.Liquid.Types++import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Lookup++class Resolvable a where+ resolve :: SourcePos -> a -> BareM a++instance Resolvable a => Resolvable [a] where+ resolve = mapM . resolve++instance Resolvable Qualifier where+ resolve _ (Q n ps b l) = Q n <$> mapM (secondM (resolve l)) ps <*> resolve l b <*> return l++instance Resolvable Pred where+ resolve l (PAnd ps) = PAnd <$> resolve l ps+ resolve l (POr ps) = POr <$> resolve l ps+ resolve l (PNot p) = PNot <$> resolve l p+ resolve l (PImp p q) = PImp <$> resolve l p <*> resolve l q+ resolve l (PIff p q) = PIff <$> resolve l p <*> resolve l q+ resolve l (PBexp b) = PBexp <$> resolve l b+ resolve l (PAtom r e1 e2) = PAtom r <$> resolve l e1 <*> resolve l e2+ resolve l (PAll vs p) = PAll <$> mapM (secondM (resolve l)) vs <*> resolve l p+ resolve _ p = return p++instance Resolvable Expr where+ resolve l (EVar s) = EVar <$> resolve l s+ resolve l (EApp s es) = EApp <$> resolve l s <*> resolve l es+ resolve l (EBin o e1 e2) = EBin o <$> resolve l e1 <*> resolve l e2+ resolve l (EIte p e1 e2) = EIte <$> resolve l p <*> resolve l e1 <*> resolve l e2+ resolve l (ECst x s) = ECst <$> resolve l x <*> resolve l s+ resolve _ x = return x++instance Resolvable LocSymbol where+ resolve _ ls@(Loc l s)+ | s `elem` prims + = return ls+ | otherwise + = do env <- gets (typeAliases . rtEnv)+ case M.lookup s env of+ Nothing | isCon s -> do v <- lookupGhcVar $ Loc l s+ let qs = symbol v+ addSym (qs,v)+ return $ Loc l qs+ _ -> return ls++addSym x = modify $ \be -> be { varEnv = (varEnv be) `L.union` [x] }++isCon c + | Just (c,_) <- T.uncons $ symbolText c = isUpper c+ | otherwise = False++instance Resolvable Symbol where+ resolve l x = fmap val $ resolve l $ Loc l x ++instance Resolvable Sort where+ resolve _ FInt = return FInt+ resolve _ FReal = return FReal+ resolve _ FNum = return FNum+ resolve _ s@(FObj _) = return s --FObj . S <$> lookupName env m s+ resolve _ s@(FVar _) = return s+ resolve l (FFunc i ss) = FFunc i <$> resolve l ss+ resolve _ (FApp tc ss)+ | tcs' `elem` prims = FApp tc <$> ss'+ | otherwise = FApp <$> (symbolFTycon.Loc l.symbol <$> lookupGhcTyCon tcs) <*> ss'+ where+ tcs@(Loc l tcs') = fTyconSymbol tc+ ss' = resolve l ss++instance Resolvable (UReft Reft) where+ resolve l (U r p s) = U <$> resolve l r <*> resolve l p <*> return s++instance Resolvable Reft where+ resolve l (Reft (s, ras)) = Reft . (s,) <$> mapM resolveRefa ras+ where+ resolveRefa (RConc p) = RConc <$> resolve l p+ resolveRefa kv = return kv++instance Resolvable Predicate where+ resolve l (Pr pvs) = Pr <$> resolve l pvs++instance (Resolvable t) => Resolvable (PVar t) where+ resolve l (PV n t v as) = PV n t v <$> mapM (third3M (resolve l)) as++instance Resolvable () where+ resolve _ = return +
+ src/Language/Haskell/Liquid/Bare/Spec.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.Spec (+ makeClasses+ , makeQualifiers+ + , makeHints+ , makeLVar+ , makeLazy+ , makeHIMeas+ , makeTExpr++ , makeTargetVars+ , makeAssertSpec+ , makeAssumeSpec+ , makeDefaultMethods++ , makeIAliases+ , makeInvariants++ , makeSpecDictionaries+ ) where++import TyCon+import Var++import Control.Applicative ((<$>))+import Control.Monad.State+import Data.Maybe+import Data.Monoid++import qualified Data.List as L+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M++import Language.Fixpoint.Misc (concatMapM, group, mapFst, snd3)+import Language.Fixpoint.Names (dropModuleNames, dropSym, isPrefixOfSym, qualifySymbol, symbolString, takeModuleNames)+import Language.Fixpoint.Types (Qualifier(..), symbol)++import Language.Haskell.Liquid.Dictionaries+import Language.Haskell.Liquid.GhcMisc (getSourcePos, showPpr, symbolTyVar)+import Language.Haskell.Liquid.Misc (addFst3, fourth4)+import Language.Haskell.Liquid.RefType (generalize, rVar, symbolRTyVar)+import Language.Haskell.Liquid.Types++import qualified Language.Haskell.Liquid.Measure as Ms++import Language.Haskell.Liquid.Bare.Check (checkDefAsserts)+import Language.Haskell.Liquid.Bare.Env+import Language.Haskell.Liquid.Bare.Existential+import Language.Haskell.Liquid.Bare.Lookup+import Language.Haskell.Liquid.Bare.Misc (joinVar)+import Language.Haskell.Liquid.Bare.OfType+import Language.Haskell.Liquid.Bare.Resolve+import Language.Haskell.Liquid.Bare.SymSort++makeClasses cfg vs (mod, spec) = inModule mod $ mapM mkClass $ Ms.classes spec+ where+ --FIXME: cleanup this code+ unClass = snd . bkClass . fourth4 . bkUniv+ mkClass (RClass c ss as ms)+ = do let l = loc c + tc <- lookupGhcTyCon c+ ss' <- mapM (mkSpecType l) ss+ let (dc:_) = tyConDataCons tc+ let αs = map symbolRTyVar as+ let as' = [rVar $ symbolTyVar a | a <- as ]+ let ms' = [ (s, rFun "" (RApp c (flip RVar mempty <$> as) [] mempty) t) | (s, t) <- ms]+ vts <- makeSpec cfg vs ms'+ let sts = [(val s, unClass $ val t) | (s, _) <- ms+ | (_, _, t) <- vts]+ let t = rCls tc as'+ let dcp = DataConP l αs [] [] ss' (reverse sts) t+ return ((dc,dcp),vts)++makeQualifiers (mod,spec) = inModule mod mkQuals+ where+ mkQuals = mapM (\q -> resolve (q_pos q) q) $ Ms.qualifiers spec++makeHints vs spec = varSymbols id vs $ Ms.decr spec+makeLVar vs spec = fmap fst <$> (varSymbols id vs $ [(v, ()) | v <- Ms.lvars spec])+makeLazy vs spec = fmap fst <$> (varSymbols id vs $ [(v, ()) | v <- S.toList $ Ms.lazy spec])+makeHIMeas vs spec = fmap (uncurry $ flip Loc) <$> (varSymbols id vs $ [(v, loc v) | v <- (S.toList $ Ms.hmeas spec) ++ (S.toList $ Ms.inlines spec)])+makeTExpr vs spec = varSymbols id vs $ Ms.termexprs spec++varSymbols :: ([Var] -> [Var]) -> [Var] -> [(LocSymbol, a)] -> BareM [(Var, a)]+varSymbols f vs = concatMapM go+ where lvs = M.map L.sort $ group [(sym v, locVar v) | v <- vs]+ sym = dropModuleNames . symbol . showPpr+ locVar v = (getSourcePos v, v)+ go (s, ns) = case M.lookup (val s) lvs of + Just lvs -> return ((, ns) <$> varsAfter f s lvs)+ Nothing -> ((:[]).(,ns)) <$> lookupGhcVar s++varsAfter f s lvs + | eqList (fst <$> lvs) = f (snd <$> lvs)+ | otherwise = map snd $ takeEqLoc $ dropLeLoc lvs+ where+ takeEqLoc xs@((l, _):_) = L.takeWhile ((l==) . fst) xs+ takeEqLoc [] = []+ dropLeLoc = L.dropWhile ((loc s >) . fst)+ eqList [] = True+ eqList (x:xs) = all (==x) xs+++------------------------------------------------------------------+-- | API: Bare Refinement Types ----------------------------------+------------------------------------------------------------------++makeTargetVars :: ModName -> [Var] -> [String] -> BareM [Var]+makeTargetVars name vs ss+ = do env <- gets hscEnv+ ns <- liftIO $ concatMapM (lookupName env name . dummyLoc . prefix) ss+ return $ filter ((`elem` ns) . varName) vs+ where+ prefix s = qualifySymbol (symbol name) (symbol s)+++makeAssertSpec cmod cfg vs lvs (mod,spec)+ | cmod == mod+ = makeLocalSpec cfg cmod vs lvs (grepClassAsserts (Ms.rinstance spec)) (Ms.sigs spec ++ Ms.localSigs spec)+ | otherwise+ = inModule mod $ makeSpec cfg vs $ Ms.sigs spec++makeAssumeSpec cmod cfg vs lvs (mod,spec)+ | cmod == mod+ = makeLocalSpec cfg cmod vs lvs [] $ Ms.asmSigs spec+ | otherwise+ = inModule mod $ makeSpec cfg vs $ Ms.asmSigs spec++grepClassAsserts = concatMap go + where+ go = map goOne . risigs+ goOne = mapFst (fmap (symbol . (".$c" ++ ) . symbolString))+++makeDefaultMethods :: [Var] -> [(ModName,Var,Located SpecType)]+ -> [(ModName,Var,Located SpecType)]+makeDefaultMethods defVs sigs+ = [ (m,dmv,t)+ | dmv <- defVs+ , let dm = symbol $ showPpr dmv+ , "$dm" `isPrefixOfSym` (dropModuleNames dm)+ , let mod = takeModuleNames dm+ , let method = qualifySymbol mod $ dropSym 3 (dropModuleNames dm)+ , let mb = L.find ((method `isPrefixOfSym`) . symbol . snd3) sigs+ , isJust mb+ , let Just (m,_,t) = mb+ ]++makeLocalSpec :: Config -> ModName -> [Var] -> [Var] -> [(LocSymbol, BareType)] -> [(LocSymbol, BareType)]+ -> BareM [(ModName, Var, Located SpecType)]+makeLocalSpec cfg mod vs lvs cbs xbs+ = do env <- get+ vbs1 <- fmap expand3 <$> varSymbols fchoose lvs (dupSnd <$> xbs1)+ unless (noCheckUnknown cfg) $ checkDefAsserts env vbs1 xbs1+ vts1 <- map (addFst3 mod) <$> mapM mkVarSpec vbs1+ vts2 <- makeSpec cfg vs xbs2+ return $ vts1 ++ vts2+ where+ xbs1 = xbs1' ++ cbs+ (xbs1', xbs2) = L.partition (modElem mod . fst) xbs+ dupSnd (x, y) = (dropMod x, (x, y))+ expand3 (x, (y, w)) = (x, y, w)+ dropMod = fmap (dropModuleNames . symbol)+ fchoose ls = maybe ls (:[]) $ L.find (`elem` vs) ls+ modElem n x = (takeModuleNames $ val x) == (symbol n)++makeSpec :: Config -> [Var] -> [(LocSymbol, BareType)]+ -> BareM [(ModName, Var, Located SpecType)]+makeSpec cfg vs xbs+ = do vbs <- map (joinVar vs) <$> lookupIds xbs+ env@(BE { modName = mod}) <- get+ unless (noCheckUnknown cfg) $ checkDefAsserts env vbs xbs+ map (addFst3 mod) <$> mapM mkVarSpec vbs+++lookupIds = mapM lookup+ where+ lookup (s, t) = (,s,t) <$> lookupGhcVar s++mkVarSpec :: (Var, LocSymbol, BareType) -> BareM (Var, Located SpecType)+mkVarSpec (v, Loc l _, b) = tx <$> mkSpecType l b+ where+ tx = (v,) . Loc l . generalize+++makeIAliases (mod, spec)+ = inModule mod $ makeIAliases' $ Ms.ialiases spec++makeIAliases' :: [(Located BareType, Located BareType)] -> BareM [(Located SpecType, Located SpecType)]+makeIAliases' ts = mapM mkIA ts+ where + mkIA (t1, t2) = liftM2 (,) (mkI t1) (mkI t2)+ mkI (Loc l t) = (Loc l) . generalize <$> mkSpecType l t++makeInvariants (mod,spec)+ = inModule mod $ makeInvariants' $ Ms.invariants spec++makeInvariants' :: [Located BareType] -> BareM [Located SpecType]+makeInvariants' ts = mapM mkI ts+ where + mkI (Loc l t) = (Loc l) . generalize <$> mkSpecType l t+++makeSpecDictionaries embs vars specs sp+ = do ds <- (dfromList . concat) <$> mapM (makeSpecDictionary embs vars) specs+ return $ sp {dicts = ds}++makeSpecDictionary embs vars (_, spec) + = mapM (makeSpecDictionaryOne embs vars) (Ms.rinstance spec)++makeSpecDictionaryOne embs vars (RI x t xts) + = do t' <- mkTy t+ tyi <- gets tcEnv+ ts' <- (map (txRefSort tyi embs . txExpToBind)) <$> mapM mkTy' ts+ let (d, dts) = makeDictionary $ RI x t' $ zip xs ts'+ let v = lookupName d + return (v, dts)+ where + mkTy t = mkSpecType (loc x) t+ mkTy' t = generalize <$> mkTy t+ (xs, ts) = unzip xts+ lookupName x + = case filter ((==x) . fst) ((\x -> (dropModuleNames $ symbol $ show x, x)) <$> vars) of + [(_, x)] -> x+ _ -> head vars -- HACK, but since it is not imported, + -- the dictionary cannot be used+ -- errorstar ("makeSpecDictionary: " ++ show x ++ "\tnot in\n" ++ show vars)+
+ src/Language/Haskell/Liquid/Bare/SymSort.hs view
@@ -0,0 +1,82 @@+module Language.Haskell.Liquid.Bare.SymSort (+ txRefSort+ ) where++import Control.Applicative ((<$>))++import qualified Data.List as L++import Language.Fixpoint.Misc (errorstar, safeZip, fst3, snd3)+import Language.Fixpoint.Types (meet)++import Language.Haskell.Liquid.RefType (appRTyCon, strengthen)+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Misc (safeZipWithError, intToString)++-- TODO: Rename, "Sort" isn't a good name for this module++-- EFFECTS: TODO is this the SAME as addTyConInfo? No. `txRefSort`+-- (1) adds the _real_ sorts to RProp,+-- (2) gathers _extra_ RProp at turnst them into refinements,+-- e.g. tests/pos/multi-pred-app-00.hs+txRefSort tyi tce = mapBot (addSymSort tce tyi)++addSymSort tce tyi (RApp rc@(RTyCon _ _ _) ts rs r) + = RApp rc ts (zipWith3 (addSymSortRef rc) pvs rargs [1..]) r'+ where+ rc' = appRTyCon tce tyi rc ts+ pvs = rTyConPVs rc' + (rargs, rrest) = splitAt (length pvs) rs+ r' = L.foldl' go r rrest+ go r (RPropP _ r') = r' `meet` r+ go _ (RHProp _ _ ) = errorstar "TODO:EFFECTS:addSymSort"+ go _ _ = errorstar "YUCKER" -- r++addSymSort _ _ t + = t++addSymSortRef _ _ (RHProp _ _) _ = errorstar "TODO:EFFECTS:addSymSortRef"+addSymSortRef rc p r i | isPropPV p = addSymSortRef' rc i p r + | otherwise = errorstar "addSymSortRef: malformed ref application"+++addSymSortRef' _ _ p (RProp s (RVar v r)) | isDummy v+ = RProp xs t+ where+ t = ofRSort (pvType p) `strengthen` r+ xs = spliceArgs "addSymSortRef 1" s p++addSymSortRef' _ _ p (RProp s t) + = RProp xs t+ where+ xs = spliceArgs "addSymSortRef 2" s p++-- EFFECTS: why can't we replace the next two equations with (breaks many tests)+--+-- EFFECTS: addSymSortRef' (PV _ (PVProp t) _ ptxs) (RPropP s r@(U _ (Pr [up]) _)) +-- EFFECTS: = RProp xts $ (ofRSort t) `strengthen` r+-- EFFECTS: where+-- EFFECTS: xts = safeZip "addRefSortMono" xs ts+-- EFFECTS: xs = snd3 <$> pargs up+-- EFFECTS: ts = fst3 <$> ptxs+-- +-- EFFECTS: addSymSortRef' (PV _ (PVProp t) _ _) (RPropP s r)+-- EFFECTS: = RProp s $ (ofRSort t) `strengthen` r++addSymSortRef' rc i p (RPropP _ r@(U _ (Pr [up]) _)) + = RProp xts ((ofRSort $ pvType p) `strengthen` r)+ where+ xts = safeZipWithError msg xs ts+ xs = snd3 <$> pargs up+ ts = fst3 <$> pargs p+ msg = intToString i ++ " argument of " ++ show rc ++ " is " ++ show (pname up) + ++ " that expects " ++ show (length ts) ++ " arguments, but it has " ++ show (length xs)++addSymSortRef' _ _ _ (RPropP s r)+ = RPropP s r++addSymSortRef' _ _ _ _+ = errorstar "TODO:EFFECTS:addSymSortRef'"++spliceArgs msg s p = safeZip msg (fst <$> s) (fst3 <$> pargs p) +
src/Language/Haskell/Liquid/CTags.hs view
@@ -22,12 +22,11 @@ import Var import CoreSyn --- import qualified Data.List as L import qualified Data.HashSet as S import qualified Data.HashMap.Strict as M import qualified Data.Graph as G -import Language.Fixpoint.Misc (mapSnd, traceShow)+import Language.Fixpoint.Misc (mapSnd) import Language.Fixpoint.Types (Tag) import Language.Haskell.Liquid.GhcInterface (freeVars)
src/Language/Haskell/Liquid/CmdLine.hs view
@@ -27,36 +27,27 @@ ) where import Control.Applicative ((<$>))-import Control.DeepSeq import Control.Monad -import qualified Data.HashMap.Strict as M-import Data.List (foldl', nub)-import Data.Maybe+import Data.List (nub) import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.IO as TIO import System.Console.CmdArgs hiding (Loud)-import System.Console.CmdArgs.Verbosity (whenLoud) import System.Directory (doesDirectoryExist, canonicalizePath, getCurrentDirectory) import System.Environment (lookupEnv, withArgs) import System.FilePath (dropFileName, isAbsolute, takeDirectory, (</>)) -import Language.Fixpoint.Config hiding (Config, config,- real)+import Language.Fixpoint.Config hiding (Config, real) import Language.Fixpoint.Files import Language.Fixpoint.Misc import Language.Fixpoint.Names (dropModuleNames)-import Language.Fixpoint.Types hiding (config)+import Language.Fixpoint.Types import Language.Haskell.Liquid.Annotate import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.PrettyPrint import Language.Haskell.Liquid.Types hiding (config, name, typ) -import Name-import SrcLoc (SrcSpan) import Text.Parsec.Pos (newPos) import Text.PrettyPrint.HughesPJ @@ -288,7 +279,7 @@ where tidy = if shortErrors cfg then Lossy else Full writeDoc c (i, d) = writeBlock c i $ lines $ render d- writeBlock c _ [] = return ()+ writeBlock _ _ [] = return () writeBlock c 0 ss = forM_ ss (colorPhaseLn c "") writeBlock _ _ ss = forM_ ("\n" : ss) putStrLn
− src/Language/Haskell/Liquid/Constraint.hs
@@ -1,1956 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}---- | This module defines the representation of Subtyping and WF Constraints, and --- the code for syntax-directed constraint generation. --module Language.Haskell.Liquid.Constraint (- - -- * Constraint information output by generator - CGInfo (..)- - -- * Function that does the actual generation- , generateConstraints- - -- * Project Constraints to Fixpoint Format- , cgInfoFInfo , cgInfoFInfoBot, cgInfoFInfoKvars- - -- * KVars in constraints, for debug/profile purposes- -- , kvars, kvars'- ) where--import CoreSyn-import SrcLoc -import Type -- (coreEqType)-import PrelNames-import qualified TyCon as TC-import qualified DataCon as DC--import TypeRep -import Class (Class, className)-import Var-import Id-import Name -import NameSet-import Text.PrettyPrint.HughesPJ hiding (first)--import Control.Monad.State--import Control.Applicative ((<$>))-import Control.Exception.Base--import Data.Monoid (mconcat, mempty, mappend)-import Data.Maybe (fromJust, isJust, fromMaybe, catMaybes)-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import qualified Data.List as L-import qualified Data.Text as T-import Data.Bifunctor-import Data.List (foldl')--import Text.Printf--import qualified Language.Haskell.Liquid.CTags as Tg-import qualified Language.Fixpoint.Types as F-import Language.Fixpoint.Names (dropModuleNames)-import Language.Fixpoint.Sort (pruneUnsortedReft)--import Language.Haskell.Liquid.Fresh--import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)-import Language.Haskell.Liquid.Bare-import Language.Haskell.Liquid.Strata-import Language.Haskell.Liquid.Annotate-import Language.Haskell.Liquid.GhcInterface-import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.PredType hiding (freeTyVars) -import Language.Haskell.Liquid.PrettyPrint-import Language.Haskell.Liquid.GhcMisc (isInternal, collectArguments, getSourcePos, pprDoc, tickSrcSpan, hasBaseTypeVar, showPpr)-import Language.Haskell.Liquid.Misc-import Language.Fixpoint.Misc-import Language.Haskell.Liquid.Qualifier-import Control.DeepSeq--import Debug.Trace (trace)-import IdInfo-------------------------------------------------------------------------------------- Constraint Generation: Toplevel ---------------------------------------------------------------------------------------------------generateConstraints :: GhcInfo -> CGInfo-generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info- where - act = consAct info- cfg = config $ spec info---consAct info- = do γ <- initEnv info- sflag <- scheck <$> get- tflag <- trustghc <$> get- let trustBinding x = if tflag - then (x `elem` (derVars info) || isInternal x) - else False - foldM_ (consCBTop trustBinding) γ (cbs info)- hcs <- hsCs <$> get - hws <- hsWfs <$> get- scss <- sCs <$> get- annot <- annotMap <$> get- scs <- if sflag then concat <$> mapM splitS (hcs ++ scss)- else return []- let smap = if sflag then solveStrata scs else []- let hcs' = if sflag then subsS smap hcs else hcs- fcs <- concat <$> mapM splitC (subsS smap hcs') - fws <- concat <$> mapM splitW hws- let annot' = if sflag then (\t -> subsS smap t) <$> annot else annot- modify $ \st -> st { fixCs = fcs } { fixWfs = fws } {annotMap = annot'}---------------------------------------------------------------------------------------initEnv :: GhcInfo -> CG CGEnv --------------------------------------------------------------------------------------initEnv info - = do let tce = tcEmbeds sp- let fVars = impVars info ++ filter isConLikeId (snd <$> freeSyms sp)- defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x)- tyi <- tyConInfo <$> get - (hs,f0) <- refreshHoles $ grty info -- asserted refinements (for defined vars)- f0'' <- refreshArgs' =<< grtyTop info -- default TOP reftype (for exported vars without spec)- let f0' = if notruetypes $ config sp then [] else f0''- f1 <- refreshArgs' $ defaults -- default TOP reftype (for all vars)- f2 <- refreshArgs' $ assm info -- assumed refinements (for imported vars)- f3 <- refreshArgs' $ vals asmSigs sp -- assumed refinedments (with `assume`)- f4 <- refreshArgs' $ vals ctors sp -- constructor refinements (for measures)- sflag <- scheck <$> get- let senv = if sflag then f2 else []- let tx = mapFst F.symbol . addRInv ialias . strataUnify senv . predsUnify sp- let bs = (tx <$> ) <$> [f0 ++ f0', f1, f2, f3, f4]- lts <- lits <$> get- let tcb = mapSnd (rTypeSort tce) <$> concat bs- let γ0 = measEnv sp (head bs) (cbs info) (tcb ++ lts) (bs!!3) hs- foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat $ tail bs]- where- sp = spec info- ialias = mkRTyConIAl $ ialiases sp - vals f = map (mapSnd val) . f--refreshHoles vts = first catMaybes . unzip . map extract <$> mapM refreshHoles' vts-refreshHoles' (x,t)- | noHoles t = return (Nothing,x,t)- | otherwise = (Just $ F.symbol x,x,) <$> mapReftM tx t- where- tx r | hasHole r = refresh r- | otherwise = return r-extract (a,b,c) = (a,(b,c))- -refreshArgs' = mapM (mapSndM refreshArgs)--strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType)-strataUnify senv (x, t) = (x, maybe t (mappend t) pt)- where- pt = (fmap (\(U r p l) -> U mempty mempty l)) <$> L.lookup x senv----- | TODO: All this *should* happen inside @Bare@ but appears--- to happen after certain are signatures are @fresh@-ed,--- which is why they are here.-predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@- . unifyts penv -- needed to match up some @TyVars@- where- tce = tcEmbeds sp - tyi = tyconEnv sp- penv = predEnv sp- -predEnv :: GhcSpec -> F.SEnv PrType-predEnv sp = F.fromListSEnv bs- where- bs = mapFst F.symbol <$> (dcs ++ assms)- dcs = concatMap mkDataConIdsTy pcs- pcs = [(x, dcPtoPredTy x y) | (x, y) <- dconsP sp]- assms = mapSnd (mapReft ur_pred . val) <$> tySigs sp- dcPtoPredTy :: DC.DataCon -> DataConP -> PrType- dcPtoPredTy dc = fmap ur_pred . dataConPSpecType dc--unifyts penv (x, t) = (x, unify pt t)- where- pt = F.lookupSEnv x' penv- x' = F.symbol x------------------------------------------------------------------------------------------measEnv sp xts cbs lts asms hs- = CGE { loc = noSrcSpan- , renv = fromListREnv $ second val <$> meas sp- , syenv = F.fromListSEnv $ freeSyms sp- , fenv = initFEnv $ lts ++ (second (rTypeSort tce . val) <$> meas sp)- , recs = S.empty - , invs = mkRTyConInv $ invariants sp- , ial = mkRTyConIAl $ ialiases sp- , grtys = fromListREnv xts- , assms = fromListREnv asms- , emb = tce - , tgEnv = Tg.makeTagEnv cbs- , tgKey = Nothing- , trec = Nothing- , lcb = M.empty- , holes = fromListHEnv hs- } - where- tce = tcEmbeds sp--assm = assm_grty impVars-grty = assm_grty defVars--assm_grty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ] - where - xs = S.fromList $ f info - sigs = tySigs $ spec info --grtyTop info = forM topVs $ \v -> (v,) <$> (trueTy $ varType v) -- val $ varSpecType v) | v <- defVars info, isTop v]- where- topVs = filter isTop $ defVars info- isTop v = isExportedId v && not (v `S.member` sigVs)- isExportedId = flip elemNameSet (exports $ spec info) . getName- sigVs = S.fromList $ [v | (v,_) <- (tySigs $ spec info)- ++ (asmSigs $ spec info)]------------------------------------------------------------------------------ | Helpers: Reading/Extending Environment Bindings ----------------------------------------------------------------------------------------------data FEnv = FE { fe_binds :: !F.IBindEnv -- ^ Integer Keys for Fixpoint Environment- , fe_env :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment- }--insertFEnv (FE benv env) ((x, t), i)- = FE (F.insertsIBindEnv [i] benv) (F.insertSEnv x t env)--insertsFEnv = L.foldl' insertFEnv--initFEnv init = FE F.emptyIBindEnv $ F.fromListSEnv (wiredSortedSyms ++ init)--data CGEnv - = CGE { loc :: !SrcSpan -- ^ Location in original source file- , renv :: !REnv -- ^ SpecTypes for Bindings in scope- , syenv :: !(F.SEnv Var) -- ^ Map from free Symbols (e.g. datacons) to Var- -- , penv :: !(F.SEnv PrType) -- ^ PrTypes for top-level bindings (merge with renv) - , fenv :: !FEnv -- ^ Fixpoint Environment- , recs :: !(S.HashSet Var) -- ^ recursive defs being processed (for annotations)- , invs :: !RTyConInv -- ^ Datatype invariants - , ial :: !RTyConIAl -- ^ Datatype checkable invariants - , grtys :: !REnv -- ^ Top-level variables with (assert)-guarantees to verify- , assms :: !REnv -- ^ Top-level variables with assumed types- , emb :: F.TCEmb TC.TyCon -- ^ How to embed GHC Tycons into fixpoint sorts- , tgEnv :: !Tg.TagEnv -- ^ Map from top-level binders to fixpoint tag- , tgKey :: !(Maybe Tg.TagKey) -- ^ Current top-level binder- , trec :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints- , lcb :: !(M.HashMap F.Symbol CoreExpr) -- ^ Let binding that have not been checked- , holes :: !HEnv -- ^ Types with holes, will need refreshing- } -- deriving (Data, Typeable)--instance PPrint CGEnv where- pprint = pprint . renv--instance Show CGEnv where- show = showpp--getTag :: CGEnv -> F.Tag-getTag γ = maybe Tg.defaultTag (`Tg.getTag` (tgEnv γ)) (tgKey γ)--setLoc :: CGEnv -> SrcSpan -> CGEnv-γ `setLoc` src - | isGoodSrcSpan src = γ { loc = src } - | otherwise = γ--withRecs :: CGEnv -> [Var] -> CGEnv -withRecs γ xs = γ { recs = foldl' (flip S.insert) (recs γ) xs }--withTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'}- where γ' = γ `withRecs` (fst <$> xts)- trec' = fromMaybe M.empty $ trec γ- xts' = mapFst F.symbol <$> xts--setBind :: CGEnv -> Tg.TagKey -> CGEnv -setBind γ k - | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }- | otherwise = γ---isGeneric :: RTyVar -> SpecType -> Bool-isGeneric α t = all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t)- where classConstrs t = [(c, α') | (c, ts) <- tyClasses t- , t' <- ts- , α' <- freeTyVars t']- isOrd = (ordClassName ==) . className- isEq = (eqClassName ==) . className---------------------------------------------------------------------------------------- Constraints: Types ----------------------------------------------------------------------------------------------data SubC = SubC { senv :: !CGEnv- , lhs :: !SpecType- , rhs :: !SpecType - }- | SubR { senv :: !CGEnv- , oblig :: !Oblig- , ref :: !RReft- }--data WfC = WfC !CGEnv !SpecType - -- deriving (Data, Typeable)--type FixSubC = F.SubC Cinfo-type FixWfC = F.WfC Cinfo--instance PPrint SubC where- pprint c = pprint (senv c)- $+$ ((text " |- ") <+> ( (pprint (lhs c)) - $+$ text "<:" - $+$ (pprint (rhs c))))--instance PPrint WfC where- pprint (WfC w r) = pprint w <> text " |- " <> pprint r --instance SubStratum SubC where- subS su (SubC γ t1 t2) = SubC γ (subS su t1) (subS su t2)- subS _ c = c---------------------------------------------------------------------------------- Constraint Splitting ----------------------------------------------------------------------------------splitW :: WfC -> CG [FixWfC]--splitW (WfC γ t@(RFun x t1 t2 _)) - = do ws <- bsplitW γ t- ws' <- splitW (WfC γ t1) - γ' <- (γ, "splitW") += (x, t1)- ws'' <- splitW (WfC γ' t2)- return $ ws ++ ws' ++ ws''--splitW (WfC γ t@(RAppTy t1 t2 _)) - = do ws <- bsplitW γ t- ws' <- splitW (WfC γ t1) - ws'' <- splitW (WfC γ t2)- return $ ws ++ ws' ++ ws''--splitW (WfC γ (RAllT _ r)) - = splitW (WfC γ r)--splitW (WfC γ (RAllP _ r)) - = splitW (WfC γ r)--splitW (WfC γ t@(RVar _ _))- = bsplitW γ t --splitW (WfC γ t@(RApp _ ts rs _))- = do ws <- bsplitW γ t - γ' <- γ `extendEnvWithVV` t - ws' <- concat <$> mapM splitW (map (WfC γ') ts)- ws'' <- concat <$> mapM (rsplitW γ) rs- return $ ws ++ ws' ++ ws''--splitW (WfC γ (RAllE x tx t))- = do ws <- splitW (WfC γ tx) - γ' <- (γ, "splitW") += (x, tx)- ws' <- splitW (WfC γ' t)- return $ ws ++ ws'--splitW (WfC γ (REx x tx t))- = do ws <- splitW (WfC γ tx) - γ' <- (γ, "splitW") += (x, tx)- ws' <- splitW (WfC γ' t)- return $ ws ++ ws'--splitW (WfC _ t) - = errorstar $ "splitW cannot handle: " ++ showpp t--rsplitW _ (RPropP _ _) - = errorstar "Constrains: rsplitW for RPropP"-rsplitW γ (RProp ss t0) - = do γ' <- foldM (++=) γ [("rsplitC", x, ofRSort s) | (x, s) <- ss]- splitW $ WfC γ' t0--bsplitW :: CGEnv -> SpecType -> CG [FixWfC]-bsplitW γ t = pruneRefs <$> get >>= return . bsplitW' γ t--bsplitW' γ t pflag- | F.isNonTrivialSortedReft r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci] - | otherwise = []- where - r' = rTypeSortedReft' pflag γ t- ci = Ci (loc γ) Nothing--mkSortedReft tce = F.RR . rTypeSort tce---------------------------------------------------------------splitS :: SubC -> CG [([Stratum], [Stratum])]-bsplitS :: SpecType -> SpecType -> CG [([Stratum], [Stratum])]---------------------------------------------------------------splitS (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2- = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (REx x tx t2)) - = splitS (SubC γ t1 t2)--splitS (SubC γ (REx x tx t1) t2) - = splitS (SubC γ t1 t2)--splitS (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2- = splitS (SubC γ t1 t2)--splitS (SubC γ (RAllE x tx t1) t2)- = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (RAllE x tx t2))- = splitS (SubC γ t1 t2)--splitS (SubC γ (RRTy e r o t1) t2) - = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e - c1 <- splitS (SubR γ' o r)- c2 <- splitS (SubC γ t1 t2)- return $ c1 ++ c2--splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) - = do cs <- bsplitS t1 t2 - cs' <- splitS (SubC γ r2 r1) - γ' <- (γ, "splitC") += (x2, r2) - let r1x2' = r1' `F.subst1` (x1, F.EVar x2) - cs'' <- splitS (SubC γ' r1x2' r2') - return $ cs ++ cs' ++ cs''--splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) - = do cs <- bsplitS t1 t2 - cs' <- splitS (SubC γ r1 r2) - cs'' <- splitS (SubC γ r1' r2') - cs''' <- splitS (SubC γ r2' r1') - return $ cs ++ cs' ++ cs'' ++ cs'''--splitS (SubC γ t1 (RAllP p t))- = splitS $ SubC γ t1 t'- where t' = fmap (replacePredsWithRefs su) t- su = (uPVar p, pVartoRConc p)--splitS (SubC _ t1@(RAllP _ _) t2) - = errorstar $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2--splitS (SubC γ (RAllT α1 t1) (RAllT α2 t2))- | α1 == α2 - = splitS $ SubC γ t1 t2- | otherwise - = splitS $ SubC γ t1 t2' - where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2--splitS (SubC γ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2 - = return []---splitS (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))- = do (t1',t2') <- unifyVV t1 t2- cs <- bsplitS t1' t2'- γ' <- γ `extendEnvWithVV` t1' - let RApp c t1s r1s _ = t1'- let RApp c' t2s r2s _ = t2'- let tyInfo = rtc_info c- cscov <- splitSIndexed γ' t1s t2s $ covariantTyArgs tyInfo- cscon <- splitSIndexed γ' t2s t1s $ contravariantTyArgs tyInfo- cscov' <- rsplitSIndexed γ' r1s r2s $ covariantPsArgs tyInfo- cscon' <- rsplitSIndexed γ' r2s r1s $ contravariantPsArgs tyInfo- return $ cs ++ cscov ++ cscon ++ cscov' ++ cscon'--splitS (SubC γ t1@(RVar a1 _) t2@(RVar a2 _)) - | a1 == a2- = bsplitS t1 t2--splitS c@(SubC _ t1 t2) - = errorstar $ "(Another Broken Test!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2--splitS (SubR _ _ _)- = return []--splitSIndexed γ t1s t2s indexes - = concatMapM splitS (zipWith (SubC γ) t1s' t2s')- where t1s' = catMaybes $ (!?) t1s <$> indexes- t2s' = catMaybes $ (!?) t2s <$> indexes--rsplitSIndexed γ t1s t2s indexes - = concatMapM (rsplitS γ) (safeZip "rsplitC" t1s' t2s')- where t1s' = catMaybes $ (!?) t1s <$> indexes- t2s' = catMaybes $ (!?) t2s <$> indexes--bsplitS t1 t2 - = return $ [(s1, s2)] - where [s1, s2] = getStrata <$> [t1, t2]--rsplitCS _ (RPropP _ _, RPropP _ _) - = errorstar "RefTypes.rsplitC on RPropP"--rsplitS γ (t1@(RProp s1 r1), t2@(RProp s2 r2))- = splitS (SubC γ (F.subst su r1) r2)- where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]--rsplitS _ _ - = errorstar "rspliS Rpoly - RPropP"---------------------------------------------------------------splitC :: SubC -> CG [FixSubC]---------------------------------------------------------------splitC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2- = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)--splitC (SubC γ t1 (REx x tx t2)) - = do γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)- let xs = grapBindsWithType tx γ- let t2' = splitExistsCases x xs tx t2- splitC (SubC γ' t1 t2')---- existential at the left hand side is treated like forall-splitC z@(SubC γ (REx x tx t1) t2) - = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx - γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)--splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2- = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)---splitC (SubC γ (RAllE x tx t1) t2)- = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)--splitC (SubC γ t1 (RAllE x tx t2))- = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)--splitC (SubC γ (RRTy e r o t1) t2) - = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e - c1 <- splitC (SubR γ' o r )- c2 <- splitC (SubC γ t1 t2)- return $ c1 ++ c2--splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) - = do cs <- bsplitC γ t1 t2 - cs' <- splitC (SubC γ r2 r1) - γ' <- (γ, "splitC") += (x2, r2) - let r1x2' = r1' `F.subst1` (x1, F.EVar x2) - cs'' <- splitC (SubC γ' r1x2' r2') - return $ cs ++ cs' ++ cs''--splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) - = do cs <- bsplitC γ t1 t2 - cs' <- splitC (SubC γ r1 r2) - cs'' <- splitC (SubC γ r1' r2') - cs''' <- splitC (SubC γ r2' r1') - return $ cs ++ cs' ++ cs'' ++ cs'''--splitC (SubC γ t1 (RAllP p t))- = splitC $ SubC γ t1 t'- where t' = fmap (replacePredsWithRefs su) t- su = (uPVar p, pVartoRConc p)--splitC (SubC _ t1@(RAllP _ _) t2) - = errorstar $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2--splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2))- | α1 == α2 - = splitC $ SubC γ t1 t2- | otherwise - = splitC $ SubC γ t1 t2' - where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2---splitC (SubC γ t1@(RApp c1 _ _ _) t2@(RApp c2 _ _ _)) | isClass c1 && c1 == c2- = return []--splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))- = do (t1',t2') <- unifyVV t1 t2- cs <- bsplitC γ t1' t2'- γ' <- γ `extendEnvWithVV` t1' - let RApp c t1s r1s _ = t1'- let RApp c' t2s r2s _ = t2'- let tyInfo = rtc_info c- cscov <- splitCIndexed γ' t1s t2s $ covariantTyArgs tyInfo- cscon <- splitCIndexed γ' t2s t1s $ contravariantTyArgs tyInfo- cscov' <- rsplitCIndexed γ' r1s r2s $ covariantPsArgs tyInfo- cscon' <- rsplitCIndexed γ' r2s r1s $ contravariantPsArgs tyInfo- return $ cs ++ cscov ++ cscon ++ cscov' ++ cscon'--splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _)) - | a1 == a2- = bsplitC γ t1 t2--splitC c@(SubC _ t1 t2) - = errorstar $ "(Another Broken Test!!!) splitc unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2--splitC (SubR γ o r)- = do fg <- pruneRefs <$> get - let r1' = if fg then pruneUnsortedReft γ'' r1 else r1- return $ F.subC γ' F.PTrue r1' r2 Nothing tag ci- where- γ'' = fe_env $ fenv γ- γ' = fe_binds $ fenv γ- r1 = F.RR s $ F.toReft r- r2 = F.RR s $ F.Reft (vv, [F.RConc $ F.PBexp $ F.EVar vv])- vv = "vvRec"- s = F.FApp F.boolFTyCon []- ci = Ci src err- err = Just $ ErrAssType src o (text $ show o ++ "type error") r- tag = getTag γ- src = loc γ --splitCIndexed γ t1s t2s indexes - = concatMapM splitC (zipWith (SubC γ) t1s' t2s')- where- t1s' = catMaybes $ (!?) t1s <$> indexes- t2s' = catMaybes $ (!?) t2s <$> indexes--rsplitCIndexed γ t1s t2s indexes - = concatMapM (rsplitC γ) (safeZip "rsplitC" t1s'' t2s'')- where- t1s' = catMaybes $ (!?) t1s <$> indexes- t2s' = catMaybes $ (!?) t2s <$> indexes- (t1s'', t2s'') = pad "rsplitCIndexed" F.top t1s' t2s'---bsplitC γ t1 t2- = checkStratum γ t1 t2 >> pruneRefs <$> get >>= return . bsplitC' γ t1 t2--checkStratum γ t1 t2- | s1 <:= s2 = return ()- | otherwise = addWarning wrn- where [s1, s2] = getStrata <$> [t1, t2]- wrn = ErrOther (loc γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2) --bsplitC' γ t1 t2 pflag- | F.isFunctionSortedReft r1' && F.isNonTrivialSortedReft r2'- = F.subC γ' F.PTrue (r1' {F.sr_reft = mempty}) r2' Nothing tag ci- | F.isNonTrivialSortedReft r2'- = F.subC γ' F.PTrue r1' r2' Nothing tag ci- | otherwise- = []- where - γ' = fe_binds $ fenv γ- r1' = rTypeSortedReft' pflag γ t1- r2' = rTypeSortedReft' pflag γ t2- ci = Ci src err- tag = getTag γ- err = Just $ ErrSubType src (text "subtype") g t1 t2 - src = loc γ- REnv g = renv γ ----unifyVV t1@(RApp c1 _ _ _) t2@(RApp c2 _ _ _)- = do vv <- (F.vv . Just) <$> fresh- return $ (shiftVV t1 vv, (shiftVV t2 vv) ) -- {rt_pargs = r2s'})--rsplitC _ (RPropP _ _, RPropP _ _) - = errorstar "RefTypes.rsplitC on RPropP"--rsplitC γ (t1@(RProp s1 r1), t2@(RProp s2 r2))- = do γ' <- foldM (++=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2]- splitC (SubC γ' (F.subst su r1) r2)- where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]--rsplitC _ _ - = errorstar "rsplit Rpoly - RPropP"----------------------------------------------------------------------------------- Generation: Types ----------------------------------------------------------------------------------data CGInfo = CGInfo { hsCs :: ![SubC] -- ^ subtyping constraints over RType- , hsWfs :: ![WfC] -- ^ wellformedness constraints over RType- , sCs :: ![SubC] -- ^ additional stratum constrains for let bindings- , fixCs :: ![FixSubC] -- ^ subtyping over Sort (post-splitting)- , isBind :: ![Bool] -- ^ tracks constraints that come from let-bindings - , fixWfs :: ![FixWfC] -- ^ wellformedness constraints over Sort (post-splitting)- , globals :: !F.FEnv -- ^ ? global measures- , freshIndex :: !Integer -- ^ counter for generating fresh KVars- , binds :: !F.BindEnv -- ^ set of environment binders- , annotMap :: !(AnnInfo (Annot SpecType)) -- ^ source-position annotation map- , tyConInfo :: !(M.HashMap TC.TyCon RTyCon) -- ^ information about type-constructors- , specQuals :: ![F.Qualifier] -- ^ ? qualifiers in source files- , specDecr :: ![(Var, [Int])] -- ^ ? FIX THIS- , termExprs :: !(M.HashMap Var [F.Expr]) -- ^ Terminating Metrics for Recursive functions- , specLVars :: !(S.HashSet Var) -- ^ Set of variables to ignore for termination checking- , specLazy :: !(S.HashSet Var) -- ^ ? FIX THIS- , tyConEmbed :: !(F.TCEmb TC.TyCon) -- ^ primitive Sorts into which TyCons should be embedded- , kuts :: !(F.Kuts) -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)- , lits :: ![(F.Symbol, F.Sort)] -- ^ ? FIX THIS - , tcheck :: !Bool -- ^ Check Termination (?) - , scheck :: !Bool -- ^ Check Strata (?)- , trustghc :: !Bool -- ^ Trust ghc auto generated bindings- , pruneRefs :: !Bool -- ^ prune unsorted refinements- , logErrors :: ![TError SpecType] -- ^ Errors during coontraint generation- , kvProf :: !KVProf -- ^ Profiling distribution of KVars - , recCount :: !Int -- ^ number of recursive functions seen (for benchmarks)- } -- deriving (Data, Typeable)--instance PPrint CGInfo where - pprint cgi = {-# SCC "ppr_CGI" #-} ppr_CGInfo cgi--ppr_CGInfo cgi - = (text "*********** Constraint Information ***********")- -- -$$ (text "*********** Haskell SubConstraints ***********")- -- -$$ (pprintLongList $ hsCs cgi)- -- -$$ (text "*********** Haskell WFConstraints ************")- -- -$$ (pprintLongList $ hsWfs cgi)- -- -$$ (text "*********** Fixpoint SubConstraints **********")- -- -$$ (F.toFix $ fixCs cgi)- -- -$$ (text "*********** Fixpoint WFConstraints ************")- -- -$$ (F.toFix $ fixWfs cgi)- -- -$$ (text "*********** Fixpoint Kut Variables ************")- -- -$$ (F.toFix $ kuts cgi)- -- -$$ (text "*********** Literals in Source ************")- -- -$$ (pprint $ lits cgi)- -- -$$ (text "*********** KVar Distribution *****************")- -- -$$ (pprint $ kvProf cgi)- -- -$$ (text "Recursive binders:" <+> pprint (recCount cgi))--type CG = State CGInfo--initCGI cfg info = CGInfo {- hsCs = [] - , sCs = [] - , hsWfs = [] - , fixCs = []- , isBind = []- , fixWfs = [] - , globals = globs- , freshIndex = 0- , binds = F.emptyBindEnv- , annotMap = AI M.empty- , tyConInfo = tyi- , specQuals = qualifiers spc ++ specificationQualifiers (maxParams cfg) (info {spec = spec'})- , tyConEmbed = tce - , kuts = F.ksEmpty - , lits = coreBindLits tce info - , termExprs = M.fromList $ texprs spc- , specDecr = decr spc- , specLVars = lvars spc- , specLazy = lazy spc- , tcheck = not $ notermination cfg- , scheck = strata cfg- , trustghc = trustinternals cfg- , pruneRefs = not $ noPrune cfg- , logErrors = []- , kvProf = emptyKVProf- , recCount = 0- } - where - tce = tcEmbeds spc - spc = spec info- spec' = spc { tySigs = [ (x, addTyConInfo tce tyi <$> t) | (x, t) <- tySigs spc]- , asmSigs = [ (x, addTyConInfo tce tyi <$> t) | (x, t) <- asmSigs spc]}- tyi = tyconEnv spc -- EFFECTS HEREHEREHERE makeTyConInfo (tconsP spc)- globs = F.fromListSEnv . map mkSort $ meas spc- mkSort = mapSnd (rTypeSortedReft tce . val)--coreBindLits tce info- = sortNub $ [ (val x, so) | (_, Just (F.ELit x so)) <- lconsts]- ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons]- where - lconsts = literalConst tce <$> literals (cbs info)- dcons = filter isDCon $ impVars info- dconToSort = typeSort tce . expandTypeSynonyms . varType - dconToSym = dataConSymbol . idDataCon- isDCon x = isDataConWorkId x && not (hasBaseTypeVar x)--extendEnvWithVV γ t - | F.isNontrivialVV vv- = (γ, "extVV") += (vv, t)- | otherwise- = return γ- where vv = rTypeValueVar t--{- see tests/pos/polyfun for why you need everything in fixenv -} -addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-addCGEnv tx γ (_, x, t') - = do idx <- fresh- let t = tx $ normalize γ {-x-} idx t' - let γ' = γ { renv = insertREnv x t (renv γ) } - pflag <- pruneRefs <$> get- is <- if isBase t - then liftM2 (++) (liftM single $ addBind x $ rTypeSortedReft' pflag γ' t) (addClassBind t)- else return [] -- addClassBind t - return $ γ' { fenv = insertsFEnv (fenv γ) is }--(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-(++=) γ = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ --addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ--rTypeSortedReft' pflag γ - | pflag- = pruneUnsortedReft (fe_env $ fenv γ) . f- | otherwise- = f - where f = rTypeSortedReft (emb γ)--(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv--(γ, msg) +++= (x, e, t) = (γ{lcb = M.insert x e (lcb γ)}, "+++=") += (x, t)--(+=) :: (CGEnv, String) -> (F.Symbol, SpecType) -> CG CGEnv-(γ, msg) += (x, r)- | x == F.dummySymbol- = return γ- | x `memberREnv` (renv γ)- = err - | otherwise- = γ ++= (msg, x, r) - where err = errorstar $ msg ++ " Duplicate binding for " - ++ F.symbolString x - ++ "\n New: " ++ showpp r- ++ "\n Old: " ++ showpp (x `lookupREnv` (renv γ))- -γ -= x = γ {renv = deleteREnv x (renv γ), lcb = M.delete x (lcb γ)}--(??=) :: CGEnv -> F.Symbol -> CG SpecType-γ ??= x - = case M.lookup x (lcb γ) of- Just e -> consE (γ-=x) e- Nothing -> refreshTy $ γ ?= x--(?=) :: CGEnv -> F.Symbol -> SpecType -γ ?= x = fromMaybe err $ lookupREnv x (renv γ)- where err = errorstar $ "EnvLookup: unknown " - ++ showpp x - ++ " in renv " - ++ showpp (renv γ)--normalize' γ x idx t = addRTyConInv (M.unionWith mappend (invs γ) (ial γ)) $ normalize γ idx t--normalize γ idx - = normalizeVV idx - . normalizePds--normalizeVV idx t@(RApp _ _ _ _)- | not (F.isNontrivialVV (rTypeValueVar t))- = shiftVV t (F.vv $ Just idx)--normalizeVV _ t - = t ---addBind :: F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)-addBind x r - = do st <- get- let (i, bs') = F.insertBindEnv x r (binds st)- put $ st { binds = bs' }- return ((x, F.sr_sort r), i) -- traceShow ("addBind: " ++ showpp x) i--addClassBind :: SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]-addClassBind = mapM (uncurry addBind) . classBinds---- RJ: What is this `isBind` business?-pushConsBind act- = do modify $ \s -> s { isBind = False : isBind s }- z <- act- modify $ \s -> s { isBind = tail (isBind s) }- return z--addC :: SubC -> String -> CG () -addC !c@(SubC γ t1 t2) _msg - = do -- trace ("addC at " ++ show (loc γ) ++ _msg++ showpp t1 ++ "\n <: \n" ++ showpp t2 ) $- modify $ \s -> s { hsCs = c : (hsCs s) }- bflag <- safeHead True . isBind <$> get- sflag <- scheck <$> get - if bflag && sflag- then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) }- else return ()- where - safeHead a [] = a- safeHead _ (x:xs) = x---addC !c _msg - = modify $ \s -> s { hsCs = c : (hsCs s) }--addPost γ (RRTy e r OInv t) - = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e - addC (SubR γ' OInv r) "precondition" >> return t--addPost γ (RRTy e r o t) - = do γ' <- foldM (\γ (x, t) -> γ ++= ("addPost", x,t)) γ e - addC (SubR γ' o r) "precondition" >> return t-addPost _ t - = return t--addW :: WfC -> CG () -addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) }--addWarning :: TError SpecType -> CG () -addWarning w = modify $ \s -> s { logErrors = w : (logErrors s) }---- | Used for annotation binders (i.e. at binder sites)--addIdA :: Var -> Annot SpecType -> CG ()-addIdA !x !t = modify $ \s -> s { annotMap = upd $ annotMap s }- where - loc = getSrcSpan x- upd m@(AI z) = if boundRecVar loc m then m else addA loc (Just x) t m- -- loc = traceShow ("addIdA: " ++ show x ++ " :: " ++ showpp t ++ " at ") $ getSrcSpan x--boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]----- | Used for annotating reads (i.e. at Var x sites) --addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()-addLocA !xo !l !t - = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }---- | Used to update annotations for a location, due to (ghost) predicate applications--updateLocA (_:_) (Just l) t = addLocA Nothing l (AnnUse t)-updateLocA _ _ _ = return () --addA !l xo@(Just _) !t (AI m)- | isGoodSrcSpan l - = AI $ inserts l (T.pack . showPpr <$> xo, t) m-addA !l xo@Nothing !t (AI m)- | l `M.member` m -- only spans known to be variables- = AI $ inserts l (T.pack . showPpr <$> xo, t) m-addA _ _ _ !a - = a---------------------------------------------------------------------------------------------- Generation: Freshness -------------------------------------------------------------------------------------------- | Right now, we generate NO new pvars. Rather than clutter code --- with `uRType` calls, put it in one place where the above --- invariant is /obviously/ enforced.--- Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@--freshTy_type :: KVKind -> CoreExpr -> Type -> CG SpecType -freshTy_type k e τ = freshTy_reftype k $ ofType τ--freshTy_expr :: KVKind -> CoreExpr -> Type -> CG SpecType -freshTy_expr k e _ = freshTy_reftype k $ exprRefType e--freshTy_reftype :: KVKind -> SpecType -> CG SpecType --- freshTy_reftype k t = do t <- refresh =<< fixTy t --- addKVars k t--- return t- -freshTy_reftype k t = (fixTy t >>= refresh) =>> addKVars k---- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive--- definitions, and also to update the KVar profile.--addKVars :: KVKind -> SpecType -> CG ()-addKVars !k !t = do when (True) $ modify $ \s -> s { kvProf = updKVProf k kvars (kvProf s) }- when (isKut k) $ modify $ \s -> s { kuts = F.ksUnion kvars (kuts s) }- where- kvars = sortNub $ specTypeKVars t--isKut :: KVKind -> Bool-isKut RecBindE = True-isKut _ = False--specTypeKVars :: SpecType -> [F.Symbol]-specTypeKVars = foldReft ((++) . (F.reftKVars . ur_reft)) []--trueTy :: Type -> CG SpecType-trueTy = ofType' >=> true--ofType' :: Type -> CG SpecType-ofType' = fixTy . ofType- -fixTy :: SpecType -> CG SpecType-fixTy t = do tyi <- tyConInfo <$> get- tce <- tyConEmbed <$> get- return $ addTyConInfo tce tyi t--refreshArgsTop :: (Var, SpecType) -> CG SpecType-refreshArgsTop (x, t) - = do (t', su) <- refreshArgsSub t- modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}- return t'- -refreshArgs :: SpecType -> CG SpecType-refreshArgs t - = fst <$> refreshArgsSub t--refreshArgsSub :: SpecType -> CG (SpecType, F.Subst)-refreshArgsSub t - = do ts <- mapM refreshArgs ts_u- xs' <- mapM (\_ -> fresh) xs- let sus = F.mkSubst <$> (L.inits $ zip xs (F.EVar <$> xs'))- let su = last sus - let ts' = zipWith F.subst sus ts- let t' = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = F.subst su tbd}- return (t', su)- where- trep = toRTypeRep t- xs = ty_binds trep- ts_u = ty_args trep- tbd = ty_res trep--instance Freshable CG Integer where- fresh = do s <- get- let n = freshIndex s- put $ s { freshIndex = n + 1 }- return n- --------------------------------------------------------------------------------------------------------- TERMINATION TYPE ------------------------------------------------------------------------------------------------------------------------makeDecrIndex :: (Var, SpecType)-> CG [Int]-makeDecrIndex (x, t) - = do spDecr <- specDecr <$> get- hint <- checkHint' (L.lookup x $ spDecr)- case dindex of- Nothing -> addWarning msg >> return []- Just i -> return $ fromMaybe [i] hint- where- ts = ty_args $ toRTypeRep t- checkHint' = checkHint x ts isDecreasing- dindex = L.findIndex isDecreasing ts- msg = ErrTermin [x] (getSrcSpan x) (text "No decreasing parameter") --recType ((_, []), (_, [], t))- = t--recType ((vs, indexc), (x, index, t))- = makeRecType t v dxt index - where v = (vs !!) <$> indexc- dxt = (xts !!) <$> index- loc = showPpr (getSrcSpan x)- xts = zip (ty_binds trep) (ty_args trep) - trep = toRTypeRep t- msg' = printf "%s: No decreasing argument on %s with %s" - msg = printf "%s: No decreasing parameter" loc- loc (showPpr x) (showPpr vs)--checkIndex (x, vs, t, index)- = do mapM_ (safeLogIndex msg' vs) index- mapM (safeLogIndex msg ts) index- where- loc = getSrcSpan x- ts = ty_args $ toRTypeRep t- msg' = ErrTermin [x] loc (text $ "No decreasing argument on " ++ (showPpr x) ++ " with " ++ (showPpr vs))- msg = ErrTermin [x] loc (text "No decreasing parameter")--makeRecType t vs dxs is- = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}- where- (xs', ts') = unzip $ replaceN (last is) (makeDecrType vdxs) xts- vdxs = zip vs dxs- xts = zip (ty_binds trep) (ty_args trep)- trep = toRTypeRep t--safeLogIndex err ls n- | n >= length ls = addWarning err >> return Nothing- | otherwise = return $ Just $ ls !! n--checkHint _ _ _ Nothing - = return Nothing--checkHint x ts f (Just ns) | L.sort ns /= ns- = addWarning (ErrTermin [x] loc (text "The hints should be increasing")) >> return Nothing- where loc = getSrcSpan x--checkHint x ts f (Just ns) - = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes)--checkValidHint x ts f n- | n < 0 || n >= length ts = addWarning err >> return Nothing- | f (ts L.!! n) = return $ Just n- | otherwise = addWarning err >> return Nothing- where err = ErrTermin [x] loc (text $ "Invalid Hint " ++ show (n+1) ++ " for " ++ (showPpr x) ++ "\nin\n" ++ show (ts))- loc = getSrcSpan x------------------------------------------------------------------------------------------ Generation: Corebind ----------------------------------------------------------------------------------------------consCBTop :: (Var -> Bool) -> CGEnv -> CoreBind -> CG CGEnv -consCBLet :: CGEnv -> CoreBind -> CG CGEnv ----------------------------------------------------------------------consCBLet γ cb- = do oldtcheck <- tcheck <$> get- strict <- specLazy <$> get- let tflag = oldtcheck- let isStr = tcond cb strict- modify $ \s -> s{tcheck = tflag && isStr}- γ' <- consCB (tflag && isStr) isStr γ cb- modify $ \s -> s{tcheck = oldtcheck}- return γ'--consCBTop trustBinding γ cb | all trustBinding xs- = do ts <- mapM trueTy (varType <$> xs)- foldM (\γ xt -> (γ, "derived") += xt) γ (zip xs' ts)- where xs = bindersOf cb- xs' = F.symbol <$> xs--consCBTop _ γ cb- = do oldtcheck <- tcheck <$> get- strict <- specLazy <$> get- let tflag = oldtcheck- let isStr = tcond cb strict- modify $ \s -> s{tcheck = tflag && isStr}- γ' <- consCB (tflag && isStr) isStr γ cb- modify $ \s -> s{tcheck = oldtcheck}- return γ'--tcond cb strict- = not $ any (\x -> S.member x strict || isInternal x) (binds cb)- where binds (NonRec x _) = [x]- binds (Rec xes) = fst $ unzip xes----------------------------------------------------------------------consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv ----------------------------------------------------------------------consCBSizedTys tflag γ (Rec xes)- = do xets'' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))- sflag <- scheck <$> get- let cmakeFinType = if sflag then makeFinType else id- let cmakeFinTy = if sflag then makeFinTy else snd- let xets = mapThd3 (fmap cmakeFinType) <$> xets''- ts' <- mapM refreshArgs $ (fromAsserted . thd3 <$> xets)- let vs = zipWith collectArgs ts' es- is <- mapM makeDecrIndex (zip xs ts') >>= checkSameLens- let ts = cmakeFinTy <$> zip is ts'- let xeets = (\vis -> [(vis, x) | x <- zip3 xs is ts]) <$> (zip vs is)- (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes- let rts = (recType <$>) <$> xeets- let xts = zip xs (Asserted <$> ts)- γ' <- foldM extender γ xts- let γs = [γ' `withTRec` (zip xs rts') | rts' <- rts]- let xets' = zip3 xs es (Asserted <$> ts)- mapM_ (uncurry $ consBind True) (zip γs xets')- return γ'- where- dmapM f = sequence . (mapM f <$>)- (xs, es) = unzip xes- collectArgs = collectArguments . length . ty_binds . toRTypeRep- checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]- checkEqTypes x = mapM (checkAll err1 toRSort) (catMaybes <$> x)- checkSameLens = checkAll err2 length- err1 = ErrTermin xs loc $ text "The decreasing parameters should be of same type"- err2 = ErrTermin xs loc $ text "All Recursive functions should have the same number of decreasing parameters"- loc = getSrcSpan (head xs)-- checkAll _ _ [] = return []- checkAll err f (x:xs) - | all (==(f x)) (f <$> xs) = return (x:xs)- | otherwise = addWarning err >> return [] --consCBWithExprs γ (Rec xes) - = do xets' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))- texprs <- termExprs <$> get- let xtes = catMaybes $ (`lookup` texprs) <$> xs- sflag <- scheck <$> get- let cmakeFinType = if sflag then makeFinType else id- let cmakeFinTy = if sflag then makeFinTy else snd- let xets = mapThd3 (fmap cmakeFinType) <$> xets'- let ts = safeFromAsserted err . thd3 <$> xets- ts' <- mapM refreshArgs ts- let xts = zip xs (Asserted <$> ts')- γ' <- foldM extender γ xts- let γs = makeTermEnvs γ' xtes xes ts ts'- let xets' = zip3 xs es (Asserted <$> ts')- mapM_ (uncurry $ consBind True) (zip γs xets')- return γ'- where (xs, es) = unzip xes- lookup k m | Just x <- M.lookup k m = Just (k, x)- | otherwise = Nothing- err = "Constant: consCBWithExprs"--makeFinTy (ns, t) = fromRTypeRep $ trep {ty_args = args'}- where trep = toRTypeRep t- args' = mapNs ns makeFinType $ ty_args trep---makeTermEnvs γ xtes xes ts ts' = withTRec γ . zip xs <$> rts- where- vs = zipWith collectArgs ts es- ys = (fst3 . bkArrowDeep) <$> ts - ys' = (fst3 . bkArrowDeep) <$> ts'- sus' = zipWith mkSub ys ys'- sus = zipWith mkSub ys ((F.symbol <$>) <$> vs)- ess = (\x -> (safeFromJust (err x) $ (x `L.lookup` xtes))) <$> xs- tes = zipWith (\su es -> F.subst su <$> es) sus ess - tes' = zipWith (\su es -> F.subst su <$> es) sus' ess - rss = zipWith makeLexRefa tes' <$> (repeat <$> tes)- rts = zipWith addTermCond ts' <$> rss- (xs, es) = unzip xes- mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']- collectArgs = collectArguments . length . ty_binds . toRTypeRep- err x = "Constant: makeTermEnvs: no terminating expression for " ++ showPpr x --- -consCB tflag _ γ (Rec xes) | tflag - = do texprs <- termExprs <$> get- modify $ \i -> i { recCount = recCount i + length xes }- let xxes = catMaybes $ (`lookup` texprs) <$> xs- if null xxes - then consCBSizedTys tflag γ (Rec xes)- else check xxes <$> consCBWithExprs γ (Rec xes)- where xs = fst $ unzip xes- check ys r | length ys == length xs = r- | otherwise = errorstar err- err = printf "%s: Termination expressions should be provided for ALL mutual recursive functions" loc- loc = showPpr $ getSrcSpan (head xs)- lookup k m | Just x <- M.lookup k m = Just (k, x)- | otherwise = Nothing--consCB _ str γ (Rec xes) | not str- = do xets' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))- sflag <- scheck <$> get- let cmakeDivType = if sflag then makeDivType else id- let xets = mapThd3 (fmap cmakeDivType) <$> xets'- modify $ \i -> i { recCount = recCount i + length xes }- let xts = [(x, to) | (x, _, to) <- xets]- γ' <- foldM extender (γ `withRecs` (fst <$> xts)) xts- mapM_ (consBind True γ') xets- return γ' --consCB _ _ γ (Rec xes) - = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))- modify $ \i -> i { recCount = recCount i + length xes }- let xts = [(x, to) | (x, _, to) <- xets]- γ' <- foldM extender (γ `withRecs` (fst <$> xts)) xts- mapM_ (consBind True γ') xets- return γ' --consCB _ _ γ (NonRec x e)- = do to <- varTemplate γ (x, Nothing) - to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)- extender γ (x, to')--consBind isRec γ (x, e, Asserted spect) - = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x- (_,πs,_,_) = bkUniv spect- γπ <- foldM addPToEnv γ' πs- cconsE γπ e spect- when (F.symbol x `elemHEnv` holes γ) $- -- have to add the wf constraint here for HOLEs so we have the proper env- addW $ WfC γπ $ fmap killSubst spect- addIdA x (defAnn isRec spect)- return $ Asserted spect -- Nothing--consBind isRec γ (x, e, Assumed spect) - = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x- γπ <- foldM addPToEnv γ' πs- cconsE γπ e =<< true spect- addIdA x (defAnn isRec spect)- return $ Asserted spect -- Nothing- where πs = ty_preds $ toRTypeRep spect--consBind isRec γ (x, e, Unknown)- = do t <- consE (γ `setBind` x) e- addIdA x (defAnn isRec t)- return $ Asserted t--noHoles = and . foldReft (\r bs -> not (hasHole r) : bs) []--killSubst :: RReft -> RReft-killSubst = fmap tx- where- tx (F.Reft (s, rs)) = F.Reft (s, map f rs)- f (F.RKvar k _) = F.RKvar k mempty- f (F.RConc p) = F.RConc p--defAnn True = AnnRDf-defAnn False = AnnDef--addPToEnv γ π- = do γπ <- γ ++= ("addSpec1", pname π, pvarRType π)- foldM (++=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π]--extender γ (x, Asserted t) = γ ++= ("extender", F.symbol x, t)-extender γ (x, Assumed t) = γ ++= ("extender", F.symbol x, t)-extender γ _ = return γ--addBinders γ0 x' cbs = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs]--data Template a = Asserted a | Assumed a | Unknown deriving (Functor)--deriving instance (Show a) => (Show (Template a))---addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t-addPostTemplate γ (Assumed t) = Assumed <$> addPost γ t-addPostTemplate γ Unknown = return Unknown --fromAsserted (Asserted t) = t-safeFromAsserted msg (Asserted t) = t---- | @varTemplate@ is only called with a `Just e` argument when the `e`--- corresponds to the body of a @Rec@ binder.-varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)-varTemplate γ (x, eo)- = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ)) of- (_, Just t, _) -> Asserted <$> refreshArgsTop (x, t)- (_, _, Just t) -> Assumed <$> refreshArgsTop (x, t)- (Just e, _, _) -> do t <- freshTy_expr RecBindE e (exprType e)- addW (WfC γ t)- Asserted <$> refreshArgsTop (x, t)- (_, _, _) -> return Unknown------------------------------------------------------------------------------------------ Generation: Expression -------------------------------------------------------------------------------------------------------------------- Type Checking ------------------------------cconsE :: CGEnv -> Expr Var -> SpecType -> CG () ---------------------------------------------------------------------cconsE γ e@(Let b@(NonRec x _) ee) t- = do sp <- specLVars <$> get- if (x `S.member` sp) || isDefLazyVar x - then cconsLazyLet γ e t - else do γ' <- consCBLet γ b- cconsE γ' ee t- where- isDefLazyVar = L.isPrefixOf "fail" . showPpr--cconsE γ (Let b e) t - = do γ' <- consCBLet γ b- cconsE γ' e t --cconsE γ (Case e x _ cases) t - = do γ' <- consCBLet γ (NonRec x e)- forM_ cases $ cconsCase γ' x t nonDefAlts - where - nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]--cconsE γ (Lam α e) (RAllT α' t) | isTyVar α - = cconsE γ e $ subsTyVar_meet' (α', rVar α) t --cconsE γ (Lam x e) (RFun y ty t _) - | not (isTyVar x) - = do γ' <- (γ, "cconsE") += (F.symbol x, ty)- cconsE γ' e (t `F.subst1` (y, F.EVar $ F.symbol x))- addIdA x (AnnDef ty) --cconsE γ (Tick tt e) t - = cconsE (γ `setLoc` tickSrcSpan tt) e t--cconsE γ e@(Cast e' _) t - = do t' <- castTy γ (exprType e) e'- addC (SubC γ t' t) ("cconsE Cast" ++ showPpr e) --cconsE γ e (RAllP p t)- = cconsE γ e t'- where- t' = replacePredsWithRefs su <$> t- su = (uPVar p, pVartoRConc p)--cconsE γ e t- = do te <- consE γ e- te' <- instantiatePreds γ e te >>= addPost γ- addC (SubC γ te' t) ("cconsE" ++ showPpr e)------------------------------------------------------------------------- | @instantiatePreds@ peels away the universally quantified @PVars@--- of a @RType@, generates fresh @Ref@ for them and substitutes them--- in the body.- -instantiatePreds γ e t0@(RAllP π t)- = do r <- freshPredRef γ e π- let πZZ = {- traceShow ("instantiatePreds 1") -} π- let tZZ = {- traceShow ("instantiatePreds 2") -} t- let rZZ = {- traceShow ("instantiatePreds 3") -} r- let t' = replacePreds "consE" tZZ [(πZZ, rZZ)]- instantiatePreds γ e t'--instantiatePreds _ _ t0- = return t0------------------------------------------------------------------------ | @instantiateStrata@ generates fresh @Strata@ vars and substitutes--- them inside the body of the type.--instantiateStrata ls t = substStrata t ls <$> mapM (\_ -> fresh) ls--substStrata t ls ls' = F.substa f t- where- f x = fromMaybe x $ L.lookup x su- su = zip ls ls'-----------------------------------------------------------------------cconsLazyLet γ (Let (NonRec x ex) e) t- = do tx <- trueTy (varType x)- γ' <- (γ, "Let NonRec") +++= (x', ex, tx)- cconsE γ' e t- where- xr = singletonReft x- x' = F.symbol x------------------------------------------------------------------------- | Type Synthesis --------------------------------------------------------------------------------------------------------------------consE :: CGEnv -> Expr Var -> CG SpecType ----------------------------------------------------------------------consE γ (Var x) - = do t <- varRefType γ x- addLocA (Just x) (loc γ) (varAnn γ x t)- return t--consE γ (Lit c) - = refreshVV $ uRType $ literalFRefType (emb γ) c--consE γ e'@(App e (Type τ)) - = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e- t <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ- addW $ WfC γ t- t' <- refreshVV t- instantiatePreds γ e' $ subsTyVar_meet' (α, t') te--consE γ e'@(App e a) - = do ([], πs, ls, te) <- bkUniv <$> consE γ e- te0 <- instantiatePreds γ e' $ foldr RAllP te πs - te' <- instantiateStrata ls te0- (γ', te'') <- dropExists γ te'- updateLocA πs (exprLoc e) te'' - let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''- pushConsBind $ cconsE γ' a tx - addPost γ' $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a)--consE γ (Lam α e) | isTyVar α - = liftM (RAllT (rTyVar α)) (consE γ e) --consE γ e@(Lam x e1) - = do tx <- freshTy_type LamE (Var x) τx - γ' <- ((γ, "consE") += (F.symbol x, tx))- t1 <- consE γ' e1- addIdA x $ AnnDef tx - addW $ WfC γ tx - return $ rFun (F.symbol x) tx t1- where- FunTy τx _ = exprType e ---- EXISTS-BASED CONSTRAINTS HEREHEREHEREHERE--- Currently suppressed because they break all sorts of invariants,--- e.g. for `unfoldR`...--- consE γ e@(Let b@(NonRec x _) e')--- = do γ' <- consCBLet γ b--- consElimE γ' [F.symbol x] e'--- --- consE γ (Case e x _ [(ac, ys, ce)]) --- = do γ' <- consCBLet γ (NonRec x e)--- γ'' <- caseEnv γ' x [] ac ys--- consElimE γ'' (F.symbol <$> (x:ys)) ce --consE γ e@(Let _ _) - = cconsFreshE LetE γ e--consE γ e@(Case _ _ _ _) - = cconsFreshE CaseE γ e--consE γ (Tick tt e)- = do t <- consE (γ `setLoc` l) e- addLocA Nothing l (AnnUse t)- return t- where l = tickSrcSpan tt--consE γ e@(Cast e' _) - = castTy γ (exprType e) e'--consE γ e@(Coercion _)- = trueTy $ exprType e--consE _ e - = errorstar $ "consE cannot handle " ++ showPpr e --castTy _ τ (Var x)- = do t <- trueTy τ - return $ t `strengthen` (uTop $ F.uexprReft $ F.expr x)--castTy γ τ e- = do t <- trueTy (exprType e)- cconsE γ e t- trueTy τ --singletonReft = uTop . F.symbolReft . F.symbol ---- | @consElimE@ is used to *synthesize* types by **existential elimination** --- instead of *checking* via a fresh template. That is, assuming--- γ |- e1 ~> t1--- we have--- γ |- let x = e1 in e2 ~> Ex x t1 t2 --- where--- γ, x:t1 |- e2 ~> t2--- instead of the earlier case where we generate a fresh template `t` and check--- γ, x:t1 |- e <~ t--consElimE γ xs e- = do t <- consE γ e- xts <- forM xs $ \x -> (x,) <$> (γ ??= x)- return $ rEx xts t---- | @consFreshE@ is used to *synthesize* types with a **fresh template** when--- the above existential elimination is not easy (e.g. at joins, recursive binders)--cconsFreshE kvkind γ e- = do t <- freshTy_type kvkind e $ exprType e- addW $ WfC γ t- cconsE γ e t- return t--checkUnbound γ e x t - | x `notElem` (F.syms t) = t- | otherwise = errorstar $ "consE: cannot handle App " ++ showPpr e ++ " at " ++ showPpr (loc γ)--dropExists γ (REx x tx t) = liftM (, t) $ (γ, "dropExists") += (x, tx)-dropExists γ t = return (γ, t)----------------------------------------------------------------------------------------cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG ()---------------------------------------------------------------------------------------cconsCase γ x t acs (ac, ys, ce)- = do cγ <- caseEnv γ x acs ac ys - cconsE cγ ce t--refreshTy t = refreshVV t >>= refreshArgs--refreshVV (RAllT a t) = liftM (RAllT a) (refreshVV t)-refreshVV (RAllP p t) = liftM (RAllP p) (refreshVV t)--refreshVV (REx x t1 t2)- = do [t1', t2'] <- mapM refreshVV [t1, t2]- liftM (shiftVV (REx x t1' t2')) fresh--refreshVV (RFun x t1 t2 r)- = do [t1', t2'] <- mapM refreshVV [t1, t2]- liftM (shiftVV (RFun x t1' t2' r)) fresh--refreshVV (RAppTy t1 t2 r)- = do [t1', t2'] <- mapM refreshVV [t1, t2]- liftM (shiftVV (RAppTy t1' t2' r)) fresh--refreshVV (RApp c ts rs r)- = do ts' <- mapM refreshVV ts- rs' <- mapM refreshVVRef rs- liftM (shiftVV (RApp c ts' rs' r)) fresh--refreshVV t - = return t---refreshVVRef (RProp ss t) - = do xs <- mapM (\_ -> fresh) (fst <$> ss)- let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs)- liftM (RProp (zip xs (snd <$> ss)) . F.subst su) (refreshVV t)-refreshVVRef (RPropP ss r) - = return $ RPropP ss r------------------------------------------------------------------------------------------caseEnv :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> CG CGEnv ---------------------------------------------------------------------------------------caseEnv γ x _ (DataAlt c) ys- = do let (x' : ys') = F.symbol <$> (x:ys)- xt0 <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x'- tdc <- γ ??= (dataConSymbol c) >>= refreshVV- let (rtd, yts, _) = unfoldR c tdc (shiftVV xt0 x') ys- let r1 = dataConReft c ys' - let r2 = dataConMsReft rtd ys'- let xt = xt0 `strengthen` (uTop (r1 `F.meet` r2))- let cbs = safeZip "cconsCase" (x':ys') (xt0:yts)- cγ' <- addBinders γ x' cbs- cγ <- addBinders cγ' x' [(x', xt)]- return cγ --caseEnv γ x acs a _ - = do let x' = F.symbol x- xt' <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x')- cγ <- addBinders γ x' [(x', xt')]- return cγ---- cconsCase γ x t _ (DataAlt c, ys, ce) --- = do xt0 <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x'--- tdc <- γ ??= (dataConSymbol c)--- let (rtd, yts, _) = unfoldR c tdc (shiftVV xt0 x') ys--- let r1 = dataConReft c ys' --- let r2 = dataConMsReft rtd ys'--- let xt = xt0 `strengthen` (uTop (r1 `F.meet` r2))--- let cbs = safeZip "cconsCase" (x':ys') (xt0:yts)--- cγ' <- addBinders γ x' cbs--- cγ <- addBinders cγ' x' [(x', xt)]--- cconsE cγ ce t--- where --- (x':ys') = F.symbol <$> (x:ys)--- --- --- cconsCase γ x t acs (a, _, ce) --- cconsE cγ ce t--altReft γ _ (LitAlt l) = literalFReft (emb γ) l-altReft γ acs DEFAULT = mconcat [notLiteralReft l | LitAlt l <- acs]- where notLiteralReft = maybe mempty F.notExprReft . snd . literalConst (emb γ)-altReft _ _ _ = error "Constraint : altReft"--unfoldR dc td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)- where - tbody = instantiatePvs (instantiateTys td ts) $ reverse rs- (ys0, yts', rt) = safeBkArrow $ instantiateTys tbody tvs'- yts'' = zipWith F.subst sus (yts'++[rt])- (t3,yts) = (last yts'', init yts'')- sus = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])- (αs, ys') = mapSnd (F.symbol <$>) $ L.partition isTyVar ys- tvs' = rVar <$> αs- tvys = ofType . varType <$> αs--unfoldR _ _ _ _ = error "Constraint.hs : unfoldR"--instantiateTys = foldl' go- where go (RAllT α tbody) t = subsTyVar_meet' (α, t) tbody- go _ _ = errorstar "Constraint.instanctiateTy" --instantiatePvs = foldl' go - where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]- go _ _ = errorstar "Constraint.instanctiatePv" --instance Show CoreExpr where- show = showPpr--checkTyCon _ t@(RApp _ _ _ _) = t-checkTyCon x t = checkErr x t --errorstar $ showPpr x ++ "type: " ++ showPpr t---- checkRPred _ t@(RAll _ _) = t--- checkRPred x t = checkErr x t--checkFun _ t@(RFun _ _ _ _) = t-checkFun x t = checkErr x t--checkAll _ t@(RAllT _ _) = t-checkAll x t = checkErr x t--checkErr (msg, e) t = errorstar $ msg ++ showPpr e ++ ", type: " ++ showpp t--varAnn γ x t - | x `S.member` recs γ- = AnnLoc (getSrcSpan' x) - | otherwise - = AnnUse t--getSrcSpan' x - | loc == noSrcSpan- = loc- | otherwise- = loc- where loc = getSrcSpan x---------------------------------------------------------------------------- | Helpers: Creating Fresh Refinement ---------------------------------------------------------------------------------------------------------freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp-freshPredRef γ e (PV n (PVProp τ) _ as)- = do t <- freshTy_type PredInstE e (toType τ)- args <- mapM (\_ -> fresh) as- let targs = [(x, s) | (x, (s, y, z)) <- zip args as, (F.EVar y) == z ]- γ' <- foldM (++=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]- addW $ WfC γ' t- return $ RProp targs t--freshPredRef _ _ (PV _ PVHProp _ _)- = errorstar "TODO:EFFECTS:freshPredRef"------------------------------------------------------------------------------------ Helpers: Creating Refinement Types For Various Things --------------------------------------------------------------------------------argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr-argExpr _ (Var vy) = Just $ F.eVar vy-argExpr γ (Lit c) = snd $ literalConst (emb γ) c-argExpr γ (Tick _ e) = argExpr γ e-argExpr _ e = errorstar $ "argExpr: " ++ showPpr e---varRefType γ x = liftM (varRefType' γ x) (γ ??= F.symbol x)--varRefType' γ x t'- | Just tys <- trec γ, Just tr <- M.lookup x' tys - = tr `strengthen` xr- | otherwise- = t- where t = t' `strengthen` xr- xr = singletonReft x -- uTop $ F.symbolReft $ F.symbol x- x' = F.symbol x---- TODO: should only expose/use subt. Not subsTyVar_meet-subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t)----------------------------------------------------------------------------------------- Forcing Strictness --------------------------------------------------------------------------------------------------------------instance NFData CGEnv where- rnf (CGE x1 x2 x3 x5 x6 x7 x8 x9 _ _ x10 x11 _ _ _)- = x1 `seq` rnf x2 `seq` seq x3 `seq` rnf x5 `seq` - rnf x6 `seq` x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10--instance NFData FEnv where- rnf (FE x1 _) = rnf x1--instance NFData SubC where- rnf (SubC x1 x2 x3) - = rnf x1 `seq` rnf x2 `seq` rnf x3- rnf (SubR x1 _ x2) - = rnf x1 `seq` rnf x2--instance NFData Class where- rnf _ = ()--instance NFData RTyCon where- rnf _ = ()--instance NFData Type where - rnf _ = ()--instance NFData WfC where- rnf (WfC x1 x2) - = rnf x1 `seq` rnf x2--instance NFData CGInfo where- rnf x = ({-# SCC "CGIrnf1" #-} rnf (hsCs x)) `seq` - ({-# SCC "CGIrnf2" #-} rnf (hsWfs x)) `seq` - ({-# SCC "CGIrnf3" #-} rnf (fixCs x)) `seq` - ({-# SCC "CGIrnf4" #-} rnf (fixWfs x)) `seq` - ({-# SCC "CGIrnf5" #-} rnf (globals x)) `seq` - ({-# SCC "CGIrnf6" #-} rnf (freshIndex x)) `seq`- ({-# SCC "CGIrnf7" #-} rnf (binds x)) `seq`- ({-# SCC "CGIrnf8" #-} rnf (annotMap x)) `seq`- ({-# SCC "CGIrnf9" #-} rnf (specQuals x)) `seq`- ({-# SCC "CGIrnf10" #-} rnf (kuts x)) `seq`- ({-# SCC "CGIrnf10" #-} rnf (lits x)) `seq`- ({-# SCC "CGIrnf10" #-} rnf (kvProf x)) ------------------------------------------------------------------------------------------------------- Reftypes from F.Fixpoint Expressions --------------------------------------------------------------------------------------------------------forallExprRefType :: CGEnv -> SpecType -> SpecType-forallExprRefType γ t = t `strengthen` (uTop r') - where r' = fromMaybe mempty $ forallExprReft γ r - r = F.sr_reft $ rTypeSortedReft (emb γ) t--forallExprReft γ r - = do e <- F.isSingletonReft r- r' <- forallExprReft_ γ e- return r'--forallExprReft_ γ e@(F.EApp f es) - = case forallExprReftLookup γ (val f) of- Just (xs,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in- Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t- Nothing -> Nothing -- F.exprReft e--forallExprReft_ γ e@(F.EVar x) - = case forallExprReftLookup γ x of - Just (_,_,t) -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t - Nothing -> Nothing -- F.exprReft e--forallExprReft_ _ e = Nothing -- F.exprReft e --forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)- where - snap = mapThd3 ignoreOblig . bkArrow . fourth4 . bkUniv . (γ ?=) . F.symbol--grapBindsWithType tx γ - = fst <$> toListREnv (filterREnv ((== toRSort tx) . toRSort) (renv γ))--splitExistsCases z xs tx- = fmap $ fmap (exrefAddEq z xs tx)--exrefAddEq z xs t (F.Reft(s, rs))- = F.Reft(s, [F.RConc (F.POr [ pand x | x <- xs])])- where tref = fromMaybe mempty $ stripRTypeBase t- pand x = F.PAnd $ (substzx x) (fFromRConc <$> rs)- ++ exrefToPred x tref- substzx x = F.subst (F.mkSubst [(z, F.EVar x)])--exrefToPred x uref- = F.subst (F.mkSubst [(v, F.EVar x)]) ((fFromRConc <$> r))- where (F.Reft(v, r)) = ur_reft uref-fFromRConc (F.RConc p) = p-fFromRConc _ = errorstar "can not hanlde existential type with kvars"------------------------------------------------------------------------------------------------------ Cleaner Signatures For Rec-bindings --------------------------------------------------------------------------------------------------------exprLoc :: CoreExpr -> Maybe SrcSpan--exprLoc (Tick tt _) = Just $ tickSrcSpan tt-exprLoc (App e a) | isType a = exprLoc e-exprLoc _ = Nothing--isType (Type _) = True-isType a = eqType (exprType a) predType---exprRefType :: CoreExpr -> SpecType -exprRefType = exprRefType_ M.empty --exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType -exprRefType_ γ (Let b e) - = exprRefType_ (bindRefType_ γ b) e--exprRefType_ γ (Lam α e) | isTyVar α- = RAllT (rTyVar α) (exprRefType_ γ e)--exprRefType_ γ (Lam x e) - = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)--exprRefType_ γ (Tick _ e)- = exprRefType_ γ e--exprRefType_ γ (Var x) - = M.lookupDefault (ofType $ varType x) x γ--exprRefType_ _ e- = ofType $ exprType e--bindRefType_ γ (Rec xes)- = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes]--bindRefType_ γ (NonRec x e)- = extendγ γ [(x, exprRefType_ γ e)]--extendγ γ xts- = foldr (\(x,t) m -> M.insert x t m) γ xts-------------------------------------------------------------------------- | Strengthening Binders with TyCon Invariants ----------------------------------------------------------------------------------------type RTyConInv = M.HashMap RTyCon [SpecType]-type RTyConIAl = M.HashMap RTyCon [SpecType]---- mkRTyConInv :: [Located SpecType] -> RTyConInv -mkRTyConInv ts = group [ (c, t) | t@(RApp c _ _ _) <- strip <$> ts]- where - strip = fourth4 . bkUniv . val --mkRTyConIAl = mkRTyConInv . fmap snd--addRTyConInv :: RTyConInv -> SpecType -> SpecType-addRTyConInv m t@(RApp c _ _ _)- = case M.lookup c m of- Nothing -> t- Just ts -> foldl' conjoinInvariant' t ts-addRTyConInv _ t - = t --addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType)-addRInv m (x, t) - | x `elem` ids , (RApp c _ _ _) <- res t, Just invs <- M.lookup c m- = (x, addInvCond t (mconcat $ catMaybes (stripRTypeBase <$> invs))) - | otherwise - = (x, t)- where- ids = [id | tc <- M.keys m- , dc <- TC.tyConDataCons $ rtc_tc tc- , id <- DC.dataConImplicitIds dc]- res = ty_res . toRTypeRep- xs = ty_args $ toRTypeRep t--conjoinInvariant' t1 t2 - = conjoinInvariantShift t1 t2--conjoinInvariantShift t1 t2 - = conjoinInvariant t1 (shiftVV t2 (rTypeValueVar t1)) --conjoinInvariant (RApp c ts rs r) (RApp ic its _ ir) - | (c == ic && length ts == length its)- = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir)--conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir) - = t { rt_reft = r `F.meet` ir }--conjoinInvariant t@(RVar _ r) (RVar _ ir) - = t { rt_reft = r `F.meet` ir }--conjoinInvariant t _ - = t----------------------------------------------------------------------- Refinement Type Environments ----------------------------------------------------------------------------------------------instance NFData REnv where- rnf (REnv _) = () -- rnf m--toListREnv (REnv env) = M.toList env-filterREnv f (REnv env) = REnv $ M.filter f env-fromListREnv = REnv . M.fromList-deleteREnv x (REnv env) = REnv (M.delete x env)-insertREnv x y (REnv env) = REnv (M.insert x y env)-lookupREnv x (REnv env) = M.lookup x env-memberREnv x (REnv env) = M.member x env--- domREnv (REnv env) = M.keys env--- emptyREnv = REnv M.empty--cgInfoFInfoBot cgi = cgInfoFInfo cgi { specQuals = [] }--cgInfoFInfoKvars cgi kvars = cgInfoFInfo cgi{fixCs = fixCs' ++ trueCs}- where - fixCs' = concatMap (updateCs kvars) (fixCs cgi) - trueCs = concatMap (`F.trueSubCKvar` (Ci noSrcSpan Nothing)) kvars--cgInfoFInfo cgi- = F.FI { F.cm = M.fromList $ F.addIds $ fixCs cgi- , F.ws = fixWfs cgi - , F.bs = binds cgi - , F.gs = globals cgi - , F.lits = lits cgi - , F.kuts = kuts cgi - , F.quals = specQuals cgi- }--updateCs kvars cs- | null lhskvars || F.isFalse rhs- = [cs] - | all (`elem` kvars) lhskvars && null lhsconcs- = []- | any (`elem` kvars) lhskvars- = [F.removeLhsKvars cs kvars]- | otherwise - = [cs]- where lhskvars = F.reftKVars lhs- rhskvars = F.reftKVars rhs- lhs = F.lhsCs cs- rhs = F.rhsCs cs- F.Reft(_, lhspds) = lhs- lhsconcs = [p | F.RConc p <- lhspds]--newtype HEnv = HEnv (S.HashSet F.Symbol)--fromListHEnv = HEnv . S.fromList-elemHEnv x (HEnv s) = x `S.member` s
+ src/Language/Haskell/Liquid/Constraint/Constraint.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.Liquid.Constraint.Constraint where++import Data.Monoid+import Data.Maybe+import Control.Applicative ++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Constraint.Types++import Language.Fixpoint.Types +++instance Monoid LConstraint where+ mempty = LC []+ mappend (LC cs1) (LC cs2) = LC (cs1 ++ cs2) ++typeToConstraint t = LC [t]+++addConstraints t γ = γ {lcs = mappend (typeToConstraint t) (lcs γ)}++constraintToLogic γ (LC ts) = pAnd (constraintToLogicOne γ <$> ts)++constraintToLogicOne γ t+ = pAnd [subConstraintToLogicOne (zip xs xts) (last xs, (last $ (fst <$> xts), r)) | xts <- xss]+ where rep = toRTypeRep t+ ts = ty_args rep+ r = ty_res rep + xs = ty_binds rep + xss = combinations ((\t -> [(x, t) | x <- grapBindsWithType t γ]) <$> ts)++subConstraintToLogicOne xts (x', (x, t)) = PImp (pAnd rs) r+ where+ (rs , su) = foldl go ([], []) xts+ ([r], _ ) = go ([], su) (x', (x, t))+ go (acc, su) (x', (x, t)) = let (Reft(v, rr)) = toReft (fromMaybe mempty (stripRTypeBase t)) in+ let su' = (x', EVar x):(v, EVar x):su in+ (subst (mkSubst su') (pAnd [p | RConc p <- rr]):acc, su')++++combinations :: [[a]] -> [[a]]+combinations [] = [[]]+combinations ([]:_) = []+combinations ((y:ys):yss) = [y:xs | xs <- combinations yss] ++ combinations (ys:yss)+
+ src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -0,0 +1,1764 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module defines the representation of Subtyping and WF Constraints, and +-- the code for syntax-directed constraint generation. ++module Language.Haskell.Liquid.Constraint.Generate (+ + generateConstraints+ + ) where++import CoreUtils (exprType)++import CoreSyn+import SrcLoc +import Type+import PrelNames+import TypeRep +import Class (Class, className)+import Var+import Id+import Name +import NameSet+import Text.PrettyPrint.HughesPJ hiding (first)++import Control.Monad.State++import Control.Applicative ((<$>))++import Data.Monoid (mconcat, mempty, mappend)+import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.List as L+import qualified Data.Text as T+import Data.Bifunctor+import Data.List (foldl')++import Text.Printf++import qualified Language.Haskell.Liquid.CTags as Tg+import Language.Fixpoint.Sort (pruneUnsortedReft)++import Language.Haskell.Liquid.Fresh++import qualified Language.Fixpoint.Types as F++import Language.Haskell.Liquid.Dictionaries+import Language.Haskell.Liquid.Variance+import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)+import Language.Haskell.Liquid.Strata+import Language.Haskell.Liquid.GhcInterface+import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.PredType hiding (freeTyVars) +import Language.Haskell.Liquid.GhcMisc ( isInternal, collectArguments, tickSrcSpan+ , hasBaseTypeVar, showPpr)+import Language.Haskell.Liquid.Misc+import Language.Fixpoint.Misc+import Language.Haskell.Liquid.Literals+import Control.DeepSeq++import Language.Haskell.Liquid.Constraint.Types+import Language.Haskell.Liquid.Constraint.Constraint++-----------------------------------------------------------------------+------------- Constraint Generation: Toplevel -------------------------+-----------------------------------------------------------------------++generateConstraints :: GhcInfo -> CGInfo+generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info+ where + act = consAct info+ cfg = config $ spec info+++consAct info+ = do γ <- initEnv info+ sflag <- scheck <$> get+ tflag <- trustghc <$> get+ let trustBinding x = if tflag + then (x `elem` (derVars info) || isInternal x) + else False + foldM_ (consCBTop trustBinding) γ (cbs info)+ hcs <- hsCs <$> get + hws <- hsWfs <$> get+ scss <- sCs <$> get+ annot <- annotMap <$> get+ scs <- if sflag then concat <$> mapM splitS (hcs ++ scss)+ else return []+ let smap = if sflag then solveStrata scs else []+ let hcs' = if sflag then subsS smap hcs else hcs+ fcs <- concat <$> mapM splitC (subsS smap hcs') + fws <- concat <$> mapM splitW hws+ let annot' = if sflag then (\t -> subsS smap t) <$> annot else annot+ modify $ \st -> st { fixCs = fcs } { fixWfs = fws } {annotMap = annot'}++------------------------------------------------------------------------------------+initEnv :: GhcInfo -> CG CGEnv +------------------------------------------------------------------------------------+initEnv info + = do let tce = tcEmbeds sp+ let fVars = impVars info ++ filter isConLikeId (snd <$> freeSyms sp)+ defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x)+ (hs,f0) <- refreshHoles $ grty info -- asserted refinements (for defined vars)+ f0'' <- refreshArgs' =<< grtyTop info -- default TOP reftype (for exported vars without spec)+ let f0' = if notruetypes $ config sp then [] else f0''+ f1 <- refreshArgs' $ defaults -- default TOP reftype (for all vars)+ f2 <- refreshArgs' $ assm info -- assumed refinements (for imported vars)+ f3 <- refreshArgs' $ vals asmSigs sp -- assumed refinedments (with `assume`)+ f4 <- refreshArgs' $ vals ctors sp -- constructor refinements (for measures)+ sflag <- scheck <$> get+ let senv = if sflag then f2 else []+ let tx = mapFst F.symbol . addRInv ialias . strataUnify senv . predsUnify sp+ let bs = (tx <$> ) <$> [f0 ++ f0', f1, f2, f3, f4]+ lts <- lits <$> get+ let tcb = mapSnd (rTypeSort tce) <$> concat bs+ let γ0 = measEnv sp (head bs) (cbs info) (tcb ++ lts) (bs!!3) hs+ foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat $ tail bs]+ where+ sp = spec info+ ialias = mkRTyConIAl $ ialiases sp + vals f = map (mapSnd val) . f++refreshHoles vts = first catMaybes . unzip . map extract <$> mapM refreshHoles' vts+refreshHoles' (x,t)+ | noHoles t = return (Nothing,x,t)+ | otherwise = (Just $ F.symbol x,x,) <$> mapReftM tx t+ where+ tx r | hasHole r = refresh r+ | otherwise = return r+extract (a,b,c) = (a,(b,c))+ +refreshArgs' = mapM (mapSndM refreshArgs)++strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType)+strataUnify senv (x, t) = (x, maybe t (mappend t) pt)+ where+ pt = (fmap (\(U _ _ l) -> U mempty mempty l)) <$> L.lookup x senv+++-- | TODO: All this *should* happen inside @Bare@ but appears+-- to happen after certain are signatures are @fresh@-ed,+-- which is why they are here.++-- NV : still some sigs do not get TyConInfo++predsUnify :: GhcSpec -> (Var, RRType RReft) -> (Var, RRType RReft)+predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@+ + where+ tce = tcEmbeds sp + tyi = tyconEnv sp+ + ---------------------------------------------------------------------------------------+ ---------------------------------------------------------------------------------------+ ---------------------------------------------------------------------------------------++measEnv sp xts cbs lts asms hs+ = CGE { loc = noSrcSpan+ , renv = fromListREnv $ second val <$> meas sp+ , syenv = F.fromListSEnv $ freeSyms sp+ , fenv = initFEnv $ lts ++ (second (rTypeSort tce . val) <$> meas sp)+ , denv = dicts sp+ , recs = S.empty + , invs = mkRTyConInv $ invariants sp+ , ial = mkRTyConIAl $ ialiases sp+ , grtys = fromListREnv xts+ , assms = fromListREnv asms+ , emb = tce + , tgEnv = Tg.makeTagEnv cbs+ , tgKey = Nothing+ , trec = Nothing+ , lcb = M.empty+ , holes = fromListHEnv hs+ , lcs = mempty+ } + where+ tce = tcEmbeds sp++assm = assm_grty impVars+grty = assm_grty defVars++assm_grty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ] + where + xs = S.fromList $ f info + sigs = tySigs $ spec info ++grtyTop info = forM topVs $ \v -> (v,) <$> (trueTy $ varType v) -- val $ varSpecType v) | v <- defVars info, isTop v]+ where+ topVs = filter isTop $ defVars info+ isTop v = isExportedId v && not (v `S.member` sigVs)+ isExportedId = flip elemNameSet (exports $ spec info) . getName+ sigVs = S.fromList $ [v | (v,_) <- (tySigs $ spec info)+ ++ (asmSigs $ spec info)]+++------------------------------------------------------------------------+-- | Helpers: Reading/Extending Environment Bindings -------------------+------------------------------------------------------------------------++++getTag :: CGEnv -> F.Tag+getTag γ = maybe Tg.defaultTag (`Tg.getTag` (tgEnv γ)) (tgKey γ)++setLoc :: CGEnv -> SrcSpan -> CGEnv+γ `setLoc` src + | isGoodSrcSpan src = γ { loc = src } + | otherwise = γ++withRecs :: CGEnv -> [Var] -> CGEnv +withRecs γ xs = γ { recs = foldl' (flip S.insert) (recs γ) xs }++withTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'}+ where γ' = γ `withRecs` (fst <$> xts)+ trec' = fromMaybe M.empty $ trec γ+ xts' = mapFst F.symbol <$> xts++setBind :: CGEnv -> Tg.TagKey -> CGEnv +setBind γ k + | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }+ | otherwise = γ+++isGeneric :: RTyVar -> SpecType -> Bool+isGeneric α t = all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t)+ where classConstrs t = [(c, α') | (c, ts) <- tyClasses t+ , t' <- ts+ , α' <- freeTyVars t']+ isOrd = (ordClassName ==) . className+ isEq = (eqClassName ==) . className+++------------------------------------------------------------+------------------- Constraint Splitting -------------------+------------------------------------------------------------++splitW :: WfC -> CG [FixWfC]++splitW (WfC γ t@(RFun x t1 t2 _)) + = do ws <- bsplitW γ t+ ws' <- splitW (WfC γ t1) + γ' <- (γ, "splitW") += (x, t1)+ ws'' <- splitW (WfC γ' t2)+ return $ ws ++ ws' ++ ws''++splitW (WfC γ t@(RAppTy t1 t2 _)) + = do ws <- bsplitW γ t+ ws' <- splitW (WfC γ t1) + ws'' <- splitW (WfC γ t2)+ return $ ws ++ ws' ++ ws''++splitW (WfC γ (RAllT _ r)) + = splitW (WfC γ r)++splitW (WfC γ (RAllP _ r)) + = splitW (WfC γ r)++splitW (WfC γ t@(RVar _ _))+ = bsplitW γ t ++splitW (WfC γ t@(RApp _ ts rs _))+ = do ws <- bsplitW γ t + γ' <- γ `extendEnvWithVV` t + ws' <- concat <$> mapM splitW (map (WfC γ') ts)+ ws'' <- concat <$> mapM (rsplitW γ) rs+ return $ ws ++ ws' ++ ws''++splitW (WfC γ (RAllE x tx t))+ = do ws <- splitW (WfC γ tx) + γ' <- (γ, "splitW") += (x, tx)+ ws' <- splitW (WfC γ' t)+ return $ ws ++ ws'++splitW (WfC γ (REx x tx t))+ = do ws <- splitW (WfC γ tx) + γ' <- (γ, "splitW") += (x, tx)+ ws' <- splitW (WfC γ' t)+ return $ ws ++ ws'++splitW (WfC _ t) + = errorstar $ "splitW cannot handle: " ++ showpp t++rsplitW _ (RPropP _ _) + = errorstar "Constrains: rsplitW for RPropP"+rsplitW γ (RProp ss t0) + = do γ' <- foldM (++=) γ [("rsplitC", x, ofRSort s) | (x, s) <- ss]+ splitW $ WfC γ' t0+rsplitW _ (RHProp _ _)+ = errorstar "TODO: EFFECTS"++bsplitW :: CGEnv -> SpecType -> CG [FixWfC]+bsplitW γ t = pruneRefs <$> get >>= return . bsplitW' γ t++bsplitW' γ t pflag+ | F.isNonTrivialSortedReft r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci] + | otherwise = []+ where + r' = rTypeSortedReft' pflag γ t+ ci = Ci (loc γ) Nothing++------------------------------------------------------------+splitS :: SubC -> CG [([Stratum], [Stratum])]+bsplitS :: SpecType -> SpecType -> CG [([Stratum], [Stratum])]+------------------------------------------------------------++splitS (SubC γ (REx x _ t1) (REx x2 _ t2)) | x == x2+ = splitS (SubC γ t1 t2)++splitS (SubC γ t1 (REx _ _ t2)) + = splitS (SubC γ t1 t2)++splitS (SubC γ (REx _ _ t1) t2) + = splitS (SubC γ t1 t2)++splitS (SubC γ (RAllE x _ t1) (RAllE x2 _ t2)) | x == x2+ = splitS (SubC γ t1 t2)++splitS (SubC γ (RAllE _ _ t1) t2)+ = splitS (SubC γ t1 t2)++splitS (SubC γ t1 (RAllE _ _ t2))+ = splitS (SubC γ t1 t2)++splitS (SubC γ (RRTy _ _ _ t1) t2) + = splitS (SubC γ t1 t2)++splitS (SubC γ t1 (RRTy _ _ _ t2)) + = splitS (SubC γ t1 t2)++splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) + = do cs <- bsplitS t1 t2 + cs' <- splitS (SubC γ r2 r1) + γ' <- (γ, "splitC") += (x2, r2) + let r1x2' = r1' `F.subst1` (x1, F.EVar x2) + cs'' <- splitS (SubC γ' r1x2' r2') + return $ cs ++ cs' ++ cs''++splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) + = do cs <- bsplitS t1 t2 + cs' <- splitS (SubC γ r1 r2) + cs'' <- splitS (SubC γ r1' r2') + cs''' <- splitS (SubC γ r2' r1') + return $ cs ++ cs' ++ cs'' ++ cs'''++splitS (SubC γ t1 (RAllP p t))+ = splitS $ SubC γ t1 t'+ where t' = fmap (replacePredsWithRefs su) t+ su = (uPVar p, pVartoRConc p)++splitS (SubC _ t1@(RAllP _ _) t2) + = errorstar $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2++splitS (SubC γ (RAllT α1 t1) (RAllT α2 t2))+ | α1 == α2 + = splitS $ SubC γ t1 t2+ | otherwise + = splitS $ SubC γ t1 t2' + where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2++splitS (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2 + = return []+++splitS (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))+ = do (t1',t2') <- unifyVV t1 t2+ cs <- bsplitS t1' t2'+ γ' <- γ `extendEnvWithVV` t1' + let RApp c t1s r1s _ = t1'+ let RApp _ t2s r2s _ = t2'+ let tyInfo = rtc_info c+ csvar <- splitsSWithVariance γ' t1s t2s $ varianceTyArgs tyInfo+ csvar' <- rsplitsSWithVariance γ' r1s r2s $ variancePsArgs tyInfo+ return $ cs ++ csvar ++ csvar'++splitS (SubC _ t1@(RVar a1 _) t2@(RVar a2 _)) + | a1 == a2+ = bsplitS t1 t2++splitS (SubC _ t1 t2) + = errorstar $ "(Another Broken Test!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2++splitS (SubR _ _ _)+ = return []++splitsSWithVariance γ t1s t2s variants + = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitS (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants)++rsplitsSWithVariance γ t1s t2s variants + = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitS γ) t1 t2 v) (zip3 t1s t2s variants)++bsplitS t1 t2 + = return $ [(s1, s2)] + where [s1, s2] = getStrata <$> [t1, t2]++rsplitS γ (RProp s1 r1) (RProp s2 r2)+ = splitS (SubC γ (F.subst su r1) r2)+ where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]++rsplitS _ _ _+ = errorstar "rspliS Rpoly - RPropP"+ +++splitfWithVariance f t1 t2 Invariant = liftM2 (++) (f t1 t2) (f t2 t1) -- return []+splitfWithVariance f t1 t2 Bivariant = liftM2 (++) (f t1 t2) (f t2 t1)+splitfWithVariance f t1 t2 Covariant = f t1 t2+splitfWithVariance f t1 t2 Contravariant = f t2 t1+++------------------------------------------------------------+splitC :: SubC -> CG [FixSubC]+------------------------------------------------------------++splitC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2+ = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)+ splitC (SubC γ' t1 t2)++splitC (SubC γ t1 (REx x tx t2)) + = do γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)+ let xs = grapBindsWithType tx γ+ let t2' = splitExistsCases x xs tx t2+ splitC (SubC γ' t1 t2')++-- existential at the left hand side is treated like forall+splitC (SubC γ (REx x tx t1) t2) + = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx + γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)+ splitC (SubC γ' t1 t2)++splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2+ = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)+ splitC (SubC γ' t1 t2)+++splitC (SubC γ (RAllE x tx t1) t2)+ = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)+ splitC (SubC γ' t1 t2)++splitC (SubC γ t1 (RAllE x tx t2))+ = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)+ splitC (SubC γ' t1 t2)++splitC (SubC γ (RRTy [(_, t)] _ OCons t1) t2)+ = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ (zip xs ts)+ c1 <- splitC (SubC γ' t1' t2')+ c2 <- splitC (SubC γ t1 t2 )+ return $ c1 ++ c2+ where+ trep = toRTypeRep t+ xs = init $ ty_binds trep+ ts = init $ ty_args trep+ t2' = ty_res trep+ t1' = last $ ty_args trep++++splitC (SubC γ (RRTy e r o t1) t2) + = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e + c1 <- splitC (SubR γ' o r )+ c2 <- splitC (SubC γ t1 t2)+ return $ c1 ++ c2++splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) + = do cs <- bsplitC γ t1 t2 + cs' <- splitC (SubC γ r2 r1) + γ' <- (γ, "splitC") += (x2, r2) + let r1x2' = r1' `F.subst1` (x1, F.EVar x2) + cs'' <- splitC (SubC γ' r1x2' r2') + return $ cs ++ cs' ++ cs''++splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) + = do cs <- bsplitC γ t1 t2 + cs' <- splitC (SubC γ r1 r2) + cs'' <- splitC (SubC γ r1' r2') + cs''' <- splitC (SubC γ r2' r1') + return $ cs ++ cs' ++ cs'' ++ cs'''++splitC (SubC γ t1 (RAllP p t))+ = splitC $ SubC γ t1 t'+ where t' = fmap (replacePredsWithRefs su) t+ su = (uPVar p, pVartoRConc p)++splitC (SubC _ t1@(RAllP _ _) t2) + = errorstar $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2++splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2))+ | α1 == α2 + = splitC $ SubC γ t1 t2+ | otherwise + = splitC $ SubC γ t1 t2' + where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2+++splitC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2+ = return []++splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))+ = do (t1',t2') <- unifyVV t1 t2+ cs <- bsplitC γ t1' t2'+ γ' <- γ `extendEnvWithVV` t1' + let RApp c t1s r1s _ = t1'+ let RApp _ t2s r2s _ = t2'+ let tyInfo = rtc_info c+ csvar <- splitsCWithVariance γ' t1s t2s $ varianceTyArgs tyInfo+ csvar' <- rsplitsCWithVariance γ' r1s r2s $ variancePsArgs tyInfo+ return $ cs ++ csvar ++ csvar'++splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _)) + | a1 == a2+ = bsplitC γ t1 t2++splitC (SubC _ t1 t2) + = errorstar $ "(Another Broken Test!!!) splitc unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2++splitC (SubR γ o r)+ = do fg <- pruneRefs <$> get + let r1' = if fg then pruneUnsortedReft γ'' r1 else r1+ return $ F.subC γ' F.PTrue r1' r2 Nothing tag ci+ where+ γ'' = fe_env $ fenv γ+ γ' = fe_binds $ fenv γ+ r1 = F.RR s $ F.toReft r+ r2 = F.RR s $ F.Reft (vv, [F.RConc $ F.PBexp $ F.EVar vv])+ vv = "vvRec"+ s = F.FApp F.boolFTyCon []+ ci = Ci src err+ err = Just $ ErrAssType src o (text $ show o ++ "type error") r+ tag = getTag γ+ src = loc γ +++splitsCWithVariance γ t1s t2s variants + = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> (splitC (SubC γ s1 s2))) t1 t2 v) (zip3 t1s t2s variants)++rsplitsCWithVariance γ t1s t2s variants + = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants)++++bsplitC γ t1 t2+ = do checkStratum γ t1 t2 + pflag <- pruneRefs <$> get+ γ' <- γ ++= ("bsplitC", v, t1) + let r = (mempty :: UReft F.Reft){ur_reft = F.Reft (F.dummySymbol, [F.RConc $ constraintToLogic γ' (lcs γ')])}+ let t1' = t1 `strengthen` r+ return $ bsplitC' γ' t1' t2 pflag+ where+ F.Reft(v, _) = ur_reft (fromMaybe mempty (stripRTypeBase t1))++checkStratum γ t1 t2+ | s1 <:= s2 = return ()+ | otherwise = addWarning wrn+ where [s1, s2] = getStrata <$> [t1, t2]+ wrn = ErrOther (loc γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2) ++bsplitC' γ t1 t2 pflag+ | F.isFunctionSortedReft r1' && F.isNonTrivialSortedReft r2'+ = F.subC γ' grd (r1' {F.sr_reft = mempty}) r2' Nothing tag ci+ | F.isNonTrivialSortedReft r2'+ = F.subC γ' grd r1' r2' Nothing tag ci+ | otherwise+ = []+ where + γ' = fe_binds $ fenv γ+ r1' = rTypeSortedReft' pflag γ t1+ r2' = rTypeSortedReft' pflag γ t2+ ci = Ci src err+ tag = getTag γ+ err = Just $ ErrSubType src (text "subtype") g t1 t2 + src = loc γ+ REnv g = renv γ + grd = F.PTrue++++unifyVV t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)+ = do vv <- (F.vv . Just) <$> fresh+ return $ (shiftVV t1 vv, (shiftVV t2 vv) ) -- {rt_pargs = r2s'})++unifyVV _ _ + = errorstar $ "Constraint.Generate.unifyVV called on invalid inputs"++rsplitC _ (RPropP _ _) (RPropP _ _) + = errorstar "RefTypes.rsplitC on RPropP"++rsplitC γ (RProp s1 r1) (RProp s2 r2)+ = do γ' <- foldM (++=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2]+ splitC (SubC γ' (F.subst su r1) r2)+ where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]++rsplitC _ _ _ + = errorstar "rsplit Rpoly - RPropP"+++type CG = State CGInfo++initCGI cfg info = CGInfo {+ hsCs = [] + , sCs = [] + , hsWfs = [] + , fixCs = []+ , isBind = []+ , fixWfs = [] + , freshIndex = 0+ , binds = F.emptyBindEnv+ , annotMap = AI M.empty+ , tyConInfo = tyi+ , tyConEmbed = tce + , kuts = F.ksEmpty + , lits = coreBindLits tce info + , termExprs = M.fromList $ texprs spc+ , specDecr = decr spc+ , specLVars = lvars spc+ , specLazy = lazy spc+ , tcheck = not $ notermination cfg+ , scheck = strata cfg+ , trustghc = trustinternals cfg+ , pruneRefs = not $ noPrune cfg+ , logErrors = []+ , kvProf = emptyKVProf+ , recCount = 0+ } + where + tce = tcEmbeds spc + spc = spec info+ tyi = tyconEnv spc -- EFFECTS HEREHEREHERE makeTyConInfo (tconsP spc)++coreBindLits tce info+ = sortNub $ [ (val x, so) | (_, Just (F.ELit x so)) <- lconsts]+ ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons]+ where + lconsts = literalConst tce <$> literals (cbs info)+ dcons = filter isDCon $ impVars info+ dconToSort = typeSort tce . expandTypeSynonyms . varType + dconToSym = dataConSymbol . idDataCon+ isDCon x = isDataConWorkId x && not (hasBaseTypeVar x)++extendEnvWithVV γ t + | F.isNontrivialVV vv+ = (γ, "extVV") += (vv, t)+ | otherwise+ = return γ+ where vv = rTypeValueVar t++{- see tests/pos/polyfun for why you need everything in fixenv -} +addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+addCGEnv tx γ (_, x, t') + = do idx <- fresh+ let t = tx $ normalize {-x-} idx t' + let γ' = γ { renv = insertREnv x t (renv γ) } + pflag <- pruneRefs <$> get+ is <- if isBase t + then liftM2 (++) (liftM single $ addBind x $ rTypeSortedReft' pflag γ' t) (addClassBind t)+ else return [] -- addClassBind t + return $ γ' { fenv = insertsFEnv (fenv γ) is }++(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+(++=) γ = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ ++addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ++rTypeSortedReft' pflag γ + | pflag+ = pruneUnsortedReft (fe_env $ fenv γ) . f+ | otherwise+ = f + where f = rTypeSortedReft (emb γ)++(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv++(γ, _) +++= (x, e, t) = (γ{lcb = M.insert x e (lcb γ)}, "+++=") += (x, t)++(+=) :: (CGEnv, String) -> (F.Symbol, SpecType) -> CG CGEnv+(γ, msg) += (x, r)+ | x == F.dummySymbol+ = return γ+ | x `memberREnv` (renv γ)+ = err + | otherwise+ = γ ++= (msg, x, r) + where err = errorstar $ msg ++ " Duplicate binding for " + ++ F.symbolString x + ++ "\n New: " ++ showpp r+ ++ "\n Old: " ++ showpp (x `lookupREnv` (renv γ))+ +γ -= x = γ {renv = deleteREnv x (renv γ), lcb = M.delete x (lcb γ)}++(??=) :: CGEnv -> F.Symbol -> CG SpecType+γ ??= x + = case M.lookup x (lcb γ) of+ Just e -> consE (γ-=x) e+ Nothing -> refreshTy $ γ ?= x++(?=) :: CGEnv -> F.Symbol -> SpecType +γ ?= x = fromMaybe err $ lookupREnv x (renv γ)+ where err = errorstar $ "EnvLookup: unknown " + ++ showpp x + ++ " in renv " + ++ showpp (renv γ)++normalize idx + = normalizeVV idx + . normalizePds++normalizeVV idx t@(RApp _ _ _ _)+ | not (F.isNontrivialVV (rTypeValueVar t))+ = shiftVV t (F.vv $ Just idx)++normalizeVV _ t + = t +++addBind :: F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)+addBind x r + = do st <- get+ let (i, bs') = F.insertBindEnv x r (binds st)+ put $ st { binds = bs' }+ return ((x, F.sr_sort r), i) -- traceShow ("addBind: " ++ showpp x) i++addClassBind :: SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]+addClassBind = mapM (uncurry addBind) . classBinds++-- RJ: What is this `isBind` business?+pushConsBind act+ = do modify $ \s -> s { isBind = False : isBind s }+ z <- act+ modify $ \s -> s { isBind = tail (isBind s) }+ return z++addC :: SubC -> String -> CG () +addC !c@(SubC γ t1 t2) _msg + = do -- trace ("addC at " ++ show (loc γ) ++ _msg++ showpp t1 ++ "\n <: \n" ++ showpp t2 ) $+ modify $ \s -> s { hsCs = c : (hsCs s) }+ bflag <- headDefault True . isBind <$> get+ sflag <- scheck <$> get + if bflag && sflag+ then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) }+ else return ()+ where + headDefault a [] = a+ headDefault _ (x:_) = x+++addC !c _msg + = modify $ \s -> s { hsCs = c : (hsCs s) }++addPost γ (RRTy e r OInv t) + = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e + addC (SubR γ' OInv r) "precondition" >> return t++addPost γ (RRTy e r OTerm t) + = do γ' <- foldM (\γ (x, t) -> γ ++= ("addPost", x,t)) γ e + addC (SubR γ' OTerm r) "precondition" >> return t++addPost _ (RRTy _ _ OCons t) + = return t++addPost _ t + = return t++addW :: WfC -> CG () +addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) }++addWarning :: TError SpecType -> CG () +addWarning w = modify $ \s -> s { logErrors = w : (logErrors s) }++-- | Used for annotation binders (i.e. at binder sites)++addIdA :: Var -> Annot SpecType -> CG ()+addIdA !x !t = modify $ \s -> s { annotMap = upd $ annotMap s }+ where + loc = getSrcSpan x+ upd m@(AI _) = if boundRecVar loc m then m else addA loc (Just x) t m++boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]+++-- | Used for annotating reads (i.e. at Var x sites) ++addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()+addLocA !xo !l !t + = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }++-- | Used to update annotations for a location, due to (ghost) predicate applications++updateLocA (_:_) (Just l) t = addLocA Nothing l (AnnUse t)+updateLocA _ _ _ = return () ++addA !l xo@(Just _) !t (AI m)+ | isGoodSrcSpan l + = AI $ inserts l (T.pack . showPpr <$> xo, t) m+addA !l xo@Nothing !t (AI m)+ | l `M.member` m -- only spans known to be variables+ = AI $ inserts l (T.pack . showPpr <$> xo, t) m+addA _ _ _ !a + = a++-------------------------------------------------------------------+------------------------ Generation: Freshness --------------------+-------------------------------------------------------------------++-- | Right now, we generate NO new pvars. Rather than clutter code +-- with `uRType` calls, put it in one place where the above +-- invariant is /obviously/ enforced.+-- Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@++freshTy_type :: KVKind -> CoreExpr -> Type -> CG SpecType +freshTy_type k _ τ = freshTy_reftype k $ ofType τ++freshTy_expr :: KVKind -> CoreExpr -> Type -> CG SpecType +freshTy_expr k e _ = freshTy_reftype k $ exprRefType e++freshTy_reftype :: KVKind -> SpecType -> CG SpecType +-- freshTy_reftype k t = do t <- refresh =<< fixTy t +-- addKVars k t+-- return t+ +freshTy_reftype k t = (fixTy t >>= refresh) =>> addKVars k++-- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive+-- definitions, and also to update the KVar profile.++addKVars :: KVKind -> SpecType -> CG ()+addKVars !k !t = do when (True) $ modify $ \s -> s { kvProf = updKVProf k kvars (kvProf s) }+ when (isKut k) $ modify $ \s -> s { kuts = F.ksUnion kvars (kuts s) }+ where+ kvars = sortNub $ specTypeKVars t++isKut :: KVKind -> Bool+isKut RecBindE = True+isKut _ = False++specTypeKVars :: SpecType -> [F.Symbol]+specTypeKVars = foldReft ((++) . (F.reftKVars . ur_reft)) []++trueTy :: Type -> CG SpecType+trueTy = ofType' >=> true++ofType' :: Type -> CG SpecType+ofType' = fixTy . ofType+ +fixTy :: SpecType -> CG SpecType+fixTy t = do tyi <- tyConInfo <$> get+ tce <- tyConEmbed <$> get+ return $ addTyConInfo tce tyi t++refreshArgsTop :: (Var, SpecType) -> CG SpecType+refreshArgsTop (x, t) + = do (t', su) <- refreshArgsSub t+ modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}+ return t'+ +refreshArgs :: SpecType -> CG SpecType+refreshArgs t + = fst <$> refreshArgsSub t++refreshArgsSub :: SpecType -> CG (SpecType, F.Subst)+refreshArgsSub t + = do ts <- mapM refreshArgs ts_u+ xs' <- mapM (\_ -> fresh) xs+ let sus = F.mkSubst <$> (L.inits $ zip xs (F.EVar <$> xs'))+ let su = last sus + let ts' = zipWith F.subst sus ts+ let t' = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = F.subst su tbd}+ return (t', su)+ where+ trep = toRTypeRep t+ xs = ty_binds trep+ ts_u = ty_args trep+ tbd = ty_res trep++instance Freshable CG Integer where+ fresh = do s <- get+ let n = freshIndex s+ put $ s { freshIndex = n + 1 }+ return n+ ++-------------------------------------------------------------------------------+----------------------- TERMINATION TYPE --------------------------------------+-------------------------------------------------------------------------------++makeDecrIndex :: (Var, SpecType)-> CG [Int]+makeDecrIndex (x, t) + = do spDecr <- specDecr <$> get+ hint <- checkHint' (L.lookup x $ spDecr)+ case dindex of+ Nothing -> addWarning msg >> return []+ Just i -> return $ fromMaybe [i] hint+ where+ ts = ty_args $ toRTypeRep t+ checkHint' = checkHint x ts isDecreasing+ dindex = L.findIndex isDecreasing ts+ msg = ErrTermin [x] (getSrcSpan x) (text "No decreasing parameter") ++recType ((_, []), (_, [], t))+ = t++recType ((vs, indexc), (_, index, t))+ = makeRecType t v dxt index + where v = (vs !!) <$> indexc+ dxt = (xts !!) <$> index+ xts = zip (ty_binds trep) (ty_args trep) + trep = toRTypeRep t++checkIndex (x, vs, t, index)+ = do mapM_ (safeLogIndex msg' vs) index+ mapM (safeLogIndex msg ts) index+ where+ loc = getSrcSpan x+ ts = ty_args $ toRTypeRep t+ msg' = ErrTermin [x] loc (text $ "No decreasing argument on " ++ (showPpr x) ++ " with " ++ (showPpr vs))+ msg = ErrTermin [x] loc (text "No decreasing parameter")++makeRecType t vs dxs is+ = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}+ where+ (xs', ts') = unzip $ replaceN (last is) (makeDecrType vdxs) xts+ vdxs = zip vs dxs+ xts = zip (ty_binds trep) (ty_args trep)+ trep = toRTypeRep t++safeLogIndex err ls n+ | n >= length ls = addWarning err >> return Nothing+ | otherwise = return $ Just $ ls !! n++checkHint _ _ _ Nothing + = return Nothing++checkHint x _ _ (Just ns) | L.sort ns /= ns+ = addWarning (ErrTermin [x] loc (text "The hints should be increasing")) >> return Nothing+ where loc = getSrcSpan x++checkHint x ts f (Just ns) + = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes)++checkValidHint x ts f n+ | n < 0 || n >= length ts = addWarning err >> return Nothing+ | f (ts L.!! n) = return $ Just n+ | otherwise = addWarning err >> return Nothing+ where err = ErrTermin [x] loc (text $ "Invalid Hint " ++ show (n+1) ++ " for " ++ (showPpr x) ++ "\nin\n" ++ show (ts))+ loc = getSrcSpan x++-------------------------------------------------------------------+-------------------- Generation: Corebind -------------------------+-------------------------------------------------------------------+consCBTop :: (Var -> Bool) -> CGEnv -> CoreBind -> CG CGEnv +consCBLet :: CGEnv -> CoreBind -> CG CGEnv +-------------------------------------------------------------------++consCBLet γ cb+ = do oldtcheck <- tcheck <$> get+ strict <- specLazy <$> get+ let tflag = oldtcheck+ let isStr = tcond cb strict+ modify $ \s -> s{tcheck = tflag && isStr}+ γ' <- consCB (tflag && isStr) isStr γ cb+ modify $ \s -> s{tcheck = oldtcheck}+ return γ'++consCBTop trustBinding γ cb | all trustBinding xs+ = do ts <- mapM trueTy (varType <$> xs)+ foldM (\γ xt -> (γ, "derived") += xt) γ (zip xs' ts)+ where xs = bindersOf cb+ xs' = F.symbol <$> xs++consCBTop _ γ cb+ = do oldtcheck <- tcheck <$> get+ strict <- specLazy <$> get+ let tflag = oldtcheck+ let isStr = tcond cb strict+ modify $ \s -> s{tcheck = tflag && isStr}+ γ' <- consCB (tflag && isStr) isStr γ cb+ modify $ \s -> s{tcheck = oldtcheck}+ return γ'++tcond cb strict+ = not $ any (\x -> S.member x strict || isInternal x) (binds cb)+ where binds (NonRec x _) = [x]+ binds (Rec xes) = fst $ unzip xes++-------------------------------------------------------------------+consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv +-------------------------------------------------------------------++consCBSizedTys γ xes+ = do xets'' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+ sflag <- scheck <$> get+ let cmakeFinType = if sflag then makeFinType else id+ let cmakeFinTy = if sflag then makeFinTy else snd+ let xets = mapThd3 (fmap cmakeFinType) <$> xets''+ ts' <- mapM refreshArgs $ (fromAsserted . thd3 <$> xets)+ let vs = zipWith collectArgs ts' es+ is <- mapM makeDecrIndex (zip xs ts') >>= checkSameLens+ let ts = cmakeFinTy <$> zip is ts'+ let xeets = (\vis -> [(vis, x) | x <- zip3 xs is ts]) <$> (zip vs is)+ (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes+ let rts = (recType <$>) <$> xeets+ let xts = zip xs (Asserted <$> ts)+ γ' <- foldM extender γ xts+ let γs = [γ' `withTRec` (zip xs rts') | rts' <- rts]+ let xets' = zip3 xs es (Asserted <$> ts)+ mapM_ (uncurry $ consBind True) (zip γs xets')+ return γ'+ where+ (xs, es) = unzip xes+ collectArgs = collectArguments . length . ty_binds . toRTypeRep+ checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]+ checkEqTypes x = mapM (checkAll err1 toRSort) (catMaybes <$> x)+ checkSameLens = checkAll err2 length+ err1 = ErrTermin xs loc $ text "The decreasing parameters should be of same type"+ err2 = ErrTermin xs loc $ text "All Recursive functions should have the same number of decreasing parameters"+ loc = getSrcSpan (head xs)++ checkAll _ _ [] = return []+ checkAll err f (x:xs) + | all (==(f x)) (f <$> xs) = return (x:xs)+ | otherwise = addWarning err >> return [] ++consCBWithExprs γ xes+ = do xets' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+ texprs <- termExprs <$> get+ let xtes = catMaybes $ (`lookup` texprs) <$> xs+ sflag <- scheck <$> get+ let cmakeFinType = if sflag then makeFinType else id+ let xets = mapThd3 (fmap cmakeFinType) <$> xets'+ let ts = safeFromAsserted err . thd3 <$> xets+ ts' <- mapM refreshArgs ts+ let xts = zip xs (Asserted <$> ts')+ γ' <- foldM extender γ xts+ let γs = makeTermEnvs γ' xtes xes ts ts'+ let xets' = zip3 xs es (Asserted <$> ts')+ mapM_ (uncurry $ consBind True) (zip γs xets')+ return γ'+ where (xs, es) = unzip xes+ lookup k m | Just x <- M.lookup k m = Just (k, x)+ | otherwise = Nothing+ err = "Constant: consCBWithExprs"++makeFinTy (ns, t) = fromRTypeRep $ trep {ty_args = args'}+ where trep = toRTypeRep t+ args' = mapNs ns makeFinType $ ty_args trep+++makeTermEnvs γ xtes xes ts ts' = withTRec γ . zip xs <$> rts+ where+ vs = zipWith collectArgs ts es+ ys = (fst3 . bkArrowDeep) <$> ts + ys' = (fst3 . bkArrowDeep) <$> ts'+ sus' = zipWith mkSub ys ys'+ sus = zipWith mkSub ys ((F.symbol <$>) <$> vs)+ ess = (\x -> (safeFromJust (err x) $ (x `L.lookup` xtes))) <$> xs+ tes = zipWith (\su es -> F.subst su <$> es) sus ess + tes' = zipWith (\su es -> F.subst su <$> es) sus' ess + rss = zipWith makeLexRefa tes' <$> (repeat <$> tes)+ rts = zipWith addTermCond ts' <$> rss+ (xs, es) = unzip xes+ mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']+ collectArgs = collectArguments . length . ty_binds . toRTypeRep+ err x = "Constant: makeTermEnvs: no terminating expression for " ++ showPpr x +++ +consCB tflag _ γ (Rec xes) | tflag + = do texprs <- termExprs <$> get+ modify $ \i -> i { recCount = recCount i + length xes }+ let xxes = catMaybes $ (`lookup` texprs) <$> xs+ if null xxes + then consCBSizedTys γ xes+ else check xxes <$> consCBWithExprs γ xes+ where xs = fst $ unzip xes+ check ys r | length ys == length xs = r+ | otherwise = errorstar err+ err = printf "%s: Termination expressions should be provided for ALL mutual recursive functions" loc+ loc = showPpr $ getSrcSpan (head xs)+ lookup k m | Just x <- M.lookup k m = Just (k, x)+ | otherwise = Nothing++consCB _ str γ (Rec xes) | not str+ = do xets' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+ sflag <- scheck <$> get+ let cmakeDivType = if sflag then makeDivType else id+ let xets = mapThd3 (fmap cmakeDivType) <$> xets'+ modify $ \i -> i { recCount = recCount i + length xes }+ let xts = [(x, to) | (x, _, to) <- xets]+ γ' <- foldM extender (γ `withRecs` (fst <$> xts)) xts+ mapM_ (consBind True γ') xets+ return γ' ++consCB _ _ γ (Rec xes) + = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+ modify $ \i -> i { recCount = recCount i + length xes }+ let xts = [(x, to) | (x, _, to) <- xets]+ γ' <- foldM extender (γ `withRecs` (fst <$> xts)) xts+ mapM_ (consBind True γ') xets+ return γ' ++-- | NV: Dictionaries are not checked, because +-- | class methods' preconditions are not satisfied+consCB _ _ γ (NonRec x _) | isDictionary x+ = do t <- trueTy (varType x)+ extender γ (x, Assumed t)+ where + isDictionary = isJust . dlookup (denv γ)+++consCB _ _ γ (NonRec x (App (Var w) (Type τ))) | isDictionary w+ = do t <- trueTy τ+ addW $ WfC γ t+ let xts = dmap (f t) $ safeFromJust (show w ++ "Not a dictionary" ) $ dlookup (denv γ) w+ let γ' = γ{denv = dinsert (denv γ) x xts }+ t <- trueTy (varType x)+ extender γ' (x, Assumed t)+ where f t' (RAllT α te) = subsTyVar_meet' (α, t') te+ f _ _ = error "consCB on Dictionary: this should not happen"+ isDictionary = isJust . dlookup (denv γ)++++consCB _ _ γ (NonRec x e)+ = do to <- varTemplate γ (x, Nothing) + to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)+ extender γ (x, to')++consBind isRec γ (x, e, Asserted spect) + = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x+ (_,πs,_,_) = bkUniv spect+ γπ <- foldM addPToEnv γ' πs+ cconsE γπ e spect+ when (F.symbol x `elemHEnv` holes γ) $+ -- have to add the wf constraint here for HOLEs so we have the proper env+ addW $ WfC γπ $ fmap killSubst spect+ addIdA x (defAnn isRec spect)+ return $ Asserted spect -- Nothing++consBind isRec γ (x, e, Assumed spect) + = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x+ γπ <- foldM addPToEnv γ' πs+ cconsE γπ e =<< true spect+ addIdA x (defAnn isRec spect)+ return $ Asserted spect -- Nothing+ where πs = ty_preds $ toRTypeRep spect++consBind isRec γ (x, e, Unknown)+ = do t <- consE (γ `setBind` x) e+ addIdA x (defAnn isRec t)+ return $ Asserted t++noHoles = and . foldReft (\r bs -> not (hasHole r) : bs) []++killSubst :: RReft -> RReft+killSubst = fmap tx+ where+ tx (F.Reft (s, rs)) = F.Reft (s, map f rs)+ f (F.RKvar k _) = F.RKvar k mempty+ f (F.RConc p) = F.RConc p++defAnn True = AnnRDf+defAnn False = AnnDef++addPToEnv γ π+ = do γπ <- γ ++= ("addSpec1", pname π, pvarRType π)+ foldM (++=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π]++extender γ (x, Asserted t) = γ ++= ("extender", F.symbol x, t)+extender γ (x, Assumed t) = γ ++= ("extender", F.symbol x, t)+extender γ _ = return γ++addBinders γ0 x' cbs = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs]++data Template a = Asserted a | Assumed a | Unknown deriving (Functor)++deriving instance (Show a) => (Show (Template a))+++addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t+addPostTemplate γ (Assumed t) = Assumed <$> addPost γ t+addPostTemplate _ Unknown = return Unknown ++fromAsserted (Asserted t) = t+fromAsserted _ = errorstar "Constraint.Generate.fromAsserted called on invalid inputs"++safeFromAsserted _ (Asserted t) = t+safeFromAsserted msg _ = errorstar $ "safeFromAsserted:" ++ msg ++-- | @varTemplate@ is only called with a `Just e` argument when the `e`+-- corresponds to the body of a @Rec@ binder.+varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)+varTemplate γ (x, eo)+ = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ)) of+ (_, Just t, _) -> Asserted <$> refreshArgsTop (x, t)+ (_, _, Just t) -> Assumed <$> refreshArgsTop (x, t)+ (Just e, _, _) -> do t <- freshTy_expr RecBindE e (exprType e)+ addW (WfC γ t)+ Asserted <$> refreshArgsTop (x, t)+ (_, _, _) -> return Unknown++-------------------------------------------------------------------+-------------------- Generation: Expression -----------------------+-------------------------------------------------------------------++----------------------- Type Checking -----------------------------+cconsE :: CGEnv -> Expr Var -> SpecType -> CG () +-------------------------------------------------------------------+cconsE γ e@(Let b@(NonRec x _) ee) t+ = do sp <- specLVars <$> get+ if (x `S.member` sp) || isDefLazyVar x + then cconsLazyLet γ e t + else do γ' <- consCBLet γ b+ cconsE γ' ee t+ where+ isDefLazyVar = L.isPrefixOf "fail" . showPpr++cconsE γ e (RAllP p t)+ = cconsE γ' e t''+ where+ t' = replacePredsWithRefs su <$> t+ su = (uPVar p, pVartoRConc p)+ (css, t'') = splitConstraints t'+ γ' = foldl (flip addConstraints) γ css +++-- cconsE γ e (RRTy [(_, cs)] _ OCons t)+-- = cconsE (addConstraints cs γ) e t++cconsE γ (Let b e) t + = do γ' <- consCBLet γ b+ cconsE γ' e t ++cconsE γ (Case e x _ cases) t + = do γ' <- consCBLet γ (NonRec x e)+ forM_ cases $ cconsCase γ' x t nonDefAlts + where + nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]++cconsE γ (Lam α e) (RAllT α' t) | isTyVar α + = cconsE γ e $ subsTyVar_meet' (α', rVar α) t ++cconsE γ (Lam x e) (RFun y ty t _) + | not (isTyVar x) + = do γ' <- (γ, "cconsE") += (F.symbol x, ty)+ cconsE γ' e (t `F.subst1` (y, F.EVar $ F.symbol x))+ addIdA x (AnnDef ty) ++cconsE γ (Tick tt e) t + = cconsE (γ `setLoc` tickSrcSpan tt) e t++cconsE γ e@(Cast e' _) t + = do t' <- castTy γ (exprType e) e'+ addC (SubC γ t' t) ("cconsE Cast" ++ showPpr e) ++cconsE γ e t+ = do te <- consE γ e+ te' <- instantiatePreds γ e te >>= addPost γ+ addC (SubC γ te' t) ("cconsE" ++ showPpr e)+++splitConstraints (RRTy [(_, cs)] _ OCons t) + = let (css, t') = splitConstraints t in (cs:css, t')+splitConstraints t + = ([], t) +-------------------------------------------------------------------+-- | @instantiatePreds@ peels away the universally quantified @PVars@+-- of a @RType@, generates fresh @Ref@ for them and substitutes them+-- in the body.+ +instantiatePreds γ e (RAllP π t)+ = do r <- freshPredRef γ e π+ instantiatePreds γ e $ replacePreds "consE" t [(π, r)]++instantiatePreds _ _ t0+ = return t0++-------------------------------------------------------------------+-- | @instantiateStrata@ generates fresh @Strata@ vars and substitutes+-- them inside the body of the type.++instantiateStrata ls t = substStrata t ls <$> mapM (\_ -> fresh) ls++substStrata t ls ls' = F.substa f t+ where+ f x = fromMaybe x $ L.lookup x su+ su = zip ls ls'++-------------------------------------------------------------------++cconsLazyLet γ (Let (NonRec x ex) e) t+ = do tx <- trueTy (varType x)+ γ' <- (γ, "Let NonRec") +++= (x', ex, tx)+ cconsE γ' e t+ where+ x' = F.symbol x++cconsLazyLet _ _ _ + = errorstar "Constraint.Generate.cconsLazyLet called on invalid inputs"++-------------------------------------------------------------------+-- | Type Synthesis -----------------------------------------------+-------------------------------------------------------------------+consE :: CGEnv -> Expr Var -> CG SpecType +-------------------------------------------------------------------++consE γ (Var x) + = do t <- varRefType γ x+ addLocA (Just x) (loc γ) (varAnn γ x t)+ return t++consE γ (Lit c) + = refreshVV $ uRType $ literalFRefType (emb γ) c++consE γ e'@(App e (Type τ)) + = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e+ t <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ+ addW $ WfC γ t+ t' <- refreshVV t+ instantiatePreds γ e' $ subsTyVar_meet' (α, t') te++consE γ e'@(App e a) | isDictionary a + = if isJust tt + then return $ fromJust tt+ else do ([], πs, ls, te) <- bkUniv <$> consE γ e+ te0 <- instantiatePreds γ e' $ foldr RAllP te πs + te' <- instantiateStrata ls te0+ (γ', te''') <- dropExists γ te'+ te'' <- dropConstraints γ te'''+ updateLocA πs (exprLoc e) te'' + let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''+ pushConsBind $ cconsE γ' a tx + addPost γ' $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a)+ where+ grepfunname (App x (Type _)) = grepfunname x+ grepfunname (Var x) = x+ grepfunname e = errorstar $ "grepfunname on \t" ++ showPpr e + mdict w = case w of + Var x -> case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing} + Tick _ e -> mdict e+ _ -> Nothing + isDictionary _ = isJust (mdict a)+ d = fromJust (mdict a)+ dinfo = dlookup (denv γ) d+ tt = dhasinfo dinfo $ grepfunname e++consE γ e'@(App e a) + = do ([], πs, ls, te) <- bkUniv <$> consE γ e+ te0 <- instantiatePreds γ e' $ foldr RAllP te πs + te' <- instantiateStrata ls te0+ (γ', te''') <- dropExists γ te'+ te'' <- dropConstraints γ te'''+ updateLocA πs (exprLoc e) te'' + let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''+ pushConsBind $ cconsE γ' a tx + addPost γ' $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a)++consE γ (Lam α e) | isTyVar α + = liftM (RAllT (rTyVar α)) (consE γ e) ++consE γ e@(Lam x e1) + = do tx <- freshTy_type LamE (Var x) τx + γ' <- ((γ, "consE") += (F.symbol x, tx))+ t1 <- consE γ' e1+ addIdA x $ AnnDef tx + addW $ WfC γ tx + return $ rFun (F.symbol x) tx t1+ where+ FunTy τx _ = exprType e ++-- EXISTS-BASED CONSTRAINTS HEREHEREHEREHERE+-- Currently suppressed because they break all sorts of invariants,+-- e.g. for `unfoldR`...+-- consE γ e@(Let b@(NonRec x _) e')+-- = do γ' <- consCBLet γ b+-- consElimE γ' [F.symbol x] e'+-- +-- consE γ (Case e x _ [(ac, ys, ce)]) +-- = do γ' <- consCBLet γ (NonRec x e)+-- γ'' <- caseEnv γ' x [] ac ys+-- consElimE γ'' (F.symbol <$> (x:ys)) ce ++consE γ e@(Let _ _) + = cconsFreshE LetE γ e++consE γ e@(Case _ _ _ _) + = cconsFreshE CaseE γ e++consE γ (Tick tt e)+ = do t <- consE (γ `setLoc` l) e+ addLocA Nothing l (AnnUse t)+ return t+ where l = tickSrcSpan tt++consE γ e@(Cast e' _) + = castTy γ (exprType e) e'++consE _ e@(Coercion _)+ = trueTy $ exprType e++consE _ e + = errorstar $ "consE cannot handle " ++ showPpr e ++castTy _ τ (Var x)+ = do t <- trueTy τ + return $ t `strengthen` (uTop $ F.uexprReft $ F.expr x)++castTy γ τ e+ = do t <- trueTy (exprType e)+ cconsE γ e t+ trueTy τ ++singletonReft = uTop . F.symbolReft . F.symbol ++-- | @consElimE@ is used to *synthesize* types by **existential elimination** +-- instead of *checking* via a fresh template. That is, assuming+-- γ |- e1 ~> t1+-- we have+-- γ |- let x = e1 in e2 ~> Ex x t1 t2 +-- where+-- γ, x:t1 |- e2 ~> t2+-- instead of the earlier case where we generate a fresh template `t` and check+-- γ, x:t1 |- e <~ t++-- consElimE γ xs e+-- = do t <- consE γ e+-- xts <- forM xs $ \x -> (x,) <$> (γ ??= x)+-- return $ rEx xts t++-- | @consFreshE@ is used to *synthesize* types with a **fresh template** when+-- the above existential elimination is not easy (e.g. at joins, recursive binders)++cconsFreshE kvkind γ e+ = do t <- freshTy_type kvkind e $ exprType e+ addW $ WfC γ t+ cconsE γ e t+ return t++checkUnbound γ e x t + | x `notElem` (F.syms t) = t+ | otherwise = errorstar $ "consE: cannot handle App " ++ showPpr e ++ " at " ++ showPpr (loc γ)++dropExists γ (REx x tx t) = liftM (, t) $ (γ, "dropExists") += (x, tx)+dropExists γ t = return (γ, t)++dropConstraints :: CGEnv -> SpecType -> CG SpecType+dropConstraints γ (RRTy [(_, ct)] _ OCons t) + = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ (zip xs ts)+ addC (SubC γ' t1 t2) "dropConstraints"+ dropConstraints γ t+ where+ trep = toRTypeRep ct+ xs = init $ ty_binds trep+ ts = init $ ty_args trep+ t2 = ty_res trep+ t1 = last $ ty_args trep++dropConstraints _ t = return t++-------------------------------------------------------------------------------------+cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG ()+-------------------------------------------------------------------------------------+cconsCase γ x t acs (ac, ys, ce)+ = do cγ <- caseEnv γ x acs ac ys + cconsE cγ ce t++refreshTy t = refreshVV t >>= refreshArgs++refreshVV (RAllT a t) = liftM (RAllT a) (refreshVV t)+refreshVV (RAllP p t) = liftM (RAllP p) (refreshVV t)++refreshVV (REx x t1 t2)+ = do [t1', t2'] <- mapM refreshVV [t1, t2]+ liftM (shiftVV (REx x t1' t2')) fresh++refreshVV (RFun x t1 t2 r)+ = do [t1', t2'] <- mapM refreshVV [t1, t2]+ liftM (shiftVV (RFun x t1' t2' r)) fresh++refreshVV (RAppTy t1 t2 r)+ = do [t1', t2'] <- mapM refreshVV [t1, t2]+ liftM (shiftVV (RAppTy t1' t2' r)) fresh++refreshVV (RApp c ts rs r)+ = do ts' <- mapM refreshVV ts+ rs' <- mapM refreshVVRef rs+ liftM (shiftVV (RApp c ts' rs' r)) fresh++refreshVV t + = return t+++refreshVVRef (RProp ss t) + = do xs <- mapM (\_ -> fresh) (fst <$> ss)+ let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs)+ liftM (RProp (zip xs (snd <$> ss)) . F.subst su) (refreshVV t)++refreshVVRef (RPropP ss r) + = return $ RPropP ss r++refreshVVRef (RHProp _ _) + = errorstar "TODO: EFFECTS refreshVVRef" +++-------------------------------------------------------------------------------------+caseEnv :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> CG CGEnv +-------------------------------------------------------------------------------------+caseEnv γ x _ (DataAlt c) ys+ = do let (x' : ys') = F.symbol <$> (x:ys)+ xt0 <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x'+ tdc <- γ ??= (dataConSymbol c) >>= refreshVV+ let (rtd, yts, _) = unfoldR tdc (shiftVV xt0 x') ys+ let r1 = dataConReft c ys' + let r2 = dataConMsReft rtd ys'+ let xt = xt0 `strengthen` (uTop (r1 `F.meet` r2))+ let cbs = safeZip "cconsCase" (x':ys') (xt0:yts)+ cγ' <- addBinders γ x' cbs+ cγ <- addBinders cγ' x' [(x', xt)]+ return cγ ++caseEnv γ x acs a _ + = do let x' = F.symbol x+ xt' <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x')+ cγ <- addBinders γ x' [(x', xt')]+ return cγ++altReft γ _ (LitAlt l) = literalFReft (emb γ) l+altReft γ acs DEFAULT = mconcat [notLiteralReft l | LitAlt l <- acs]+ where notLiteralReft = maybe mempty F.notExprReft . snd . literalConst (emb γ)+altReft _ _ _ = error "Constraint : altReft"++unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)+ where + tbody = instantiatePvs (instantiateTys td ts) $ reverse rs+ (ys0, yts', rt) = safeBkArrow $ instantiateTys tbody tvs'+ yts'' = zipWith F.subst sus (yts'++[rt])+ (t3,yts) = (last yts'', init yts'')+ sus = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])+ (αs, ys') = mapSnd (F.symbol <$>) $ L.partition isTyVar ys+ tvs' = rVar <$> αs+ tvys = ofType . varType <$> αs++unfoldR _ _ _ = error "Constraint.hs : unfoldR"++instantiateTys = foldl' go+ where go (RAllT α tbody) t = subsTyVar_meet' (α, t) tbody+ go _ _ = errorstar "Constraint.instanctiateTy" ++instantiatePvs = foldl' go + where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]+ go _ _ = errorstar "Constraint.instanctiatePv" ++checkTyCon _ t@(RApp _ _ _ _) = t+checkTyCon x t = checkErr x t --errorstar $ showPpr x ++ "type: " ++ showPpr t++checkFun _ t@(RFun _ _ _ _) = t+checkFun x t = checkErr x t++checkAll _ t@(RAllT _ _) = t+checkAll x t = checkErr x t++checkErr (msg, e) t = errorstar $ msg ++ showPpr e ++ ", type: " ++ showpp t++varAnn γ x t + | x `S.member` recs γ+ = AnnLoc (getSrcSpan' x) + | otherwise + = AnnUse t++getSrcSpan' x + | loc == noSrcSpan+ = loc+ | otherwise+ = loc+ where loc = getSrcSpan x++-----------------------------------------------------------------------+-- | Helpers: Creating Fresh Refinement -------------------------------+-----------------------------------------------------------------------++freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp+freshPredRef γ e (PV _ (PVProp τ) _ as)+ = do t <- freshTy_type PredInstE e (toType τ)+ args <- mapM (\_ -> fresh) as+ let targs = [(x, s) | (x, (s, y, z)) <- zip args as, (F.EVar y) == z ]+ γ' <- foldM (++=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]+ addW $ WfC γ' t+ return $ RProp targs t++freshPredRef _ _ (PV _ PVHProp _ _)+ = errorstar "TODO:EFFECTS:freshPredRef"++-----------------------------------------------------------------------+---------- Helpers: Creating Refinement Types For Various Things ------+-----------------------------------------------------------------------++argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr+argExpr _ (Var vy) = Just $ F.eVar vy+argExpr γ (Lit c) = snd $ literalConst (emb γ) c+argExpr γ (Tick _ e) = argExpr γ e+argExpr _ e = errorstar $ "argExpr: " ++ showPpr e+++varRefType γ x = liftM (varRefType' γ x) (γ ??= F.symbol x)++varRefType' γ x t'+ | Just tys <- trec γ, Just tr <- M.lookup x' tys + = tr `strengthen` xr+ | otherwise+ = t+ where t = t' `strengthen` xr+ xr = singletonReft x -- uTop $ F.symbolReft $ F.symbol x+ x' = F.symbol x++-- TODO: should only expose/use subt. Not subsTyVar_meet+subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t)++-----------------------------------------------------------------------+--------------- Forcing Strictness ------------------------------------+-----------------------------------------------------------------------++instance NFData CGEnv where+ rnf (CGE x1 x2 x3 _ x5 x6 x7 x8 x9 _ _ x10 _ _ _ _ _)+ = x1 `seq` rnf x2 `seq` seq x3 `seq` rnf x5 `seq` + rnf x6 `seq` x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10++instance NFData FEnv where+ rnf (FE x1 _) = rnf x1++instance NFData SubC where+ rnf (SubC x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3+ rnf (SubR x1 _ x2) + = rnf x1 `seq` rnf x2++instance NFData Class where+ rnf _ = ()++instance NFData RTyCon where+ rnf _ = ()++instance NFData Type where + rnf _ = ()++instance NFData WfC where+ rnf (WfC x1 x2) + = rnf x1 `seq` rnf x2++instance NFData CGInfo where+ rnf x = ({-# SCC "CGIrnf1" #-} rnf (hsCs x)) `seq` + ({-# SCC "CGIrnf2" #-} rnf (hsWfs x)) `seq` + ({-# SCC "CGIrnf3" #-} rnf (fixCs x)) `seq` + ({-# SCC "CGIrnf4" #-} rnf (fixWfs x)) `seq` + ({-# SCC "CGIrnf6" #-} rnf (freshIndex x)) `seq`+ ({-# SCC "CGIrnf7" #-} rnf (binds x)) `seq`+ ({-# SCC "CGIrnf8" #-} rnf (annotMap x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (kuts x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (lits x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (kvProf x)) ++-------------------------------------------------------------------------------+--------------------- Reftypes from F.Fixpoint Expressions ----------------------+-------------------------------------------------------------------------------++forallExprRefType :: CGEnv -> SpecType -> SpecType+forallExprRefType γ t = t `strengthen` (uTop r') + where r' = fromMaybe mempty $ forallExprReft γ r + r = F.sr_reft $ rTypeSortedReft (emb γ) t++forallExprReft γ r + = do e <- F.isSingletonReft r+ r' <- forallExprReft_ γ e+ return r'++forallExprReft_ γ (F.EApp f es) + = case forallExprReftLookup γ (val f) of+ Just (xs,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in+ Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t+ Nothing -> Nothing -- F.exprReft e++forallExprReft_ γ (F.EVar x) + = case forallExprReftLookup γ x of + Just (_,_,t) -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t + Nothing -> Nothing -- F.exprReft e++forallExprReft_ _ _ = Nothing -- F.exprReft e ++forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)+ where + snap = mapThd3 ignoreOblig . bkArrow . fourth4 . bkUniv . (γ ?=) . F.symbol++splitExistsCases z xs tx+ = fmap $ fmap (exrefAddEq z xs tx)++exrefAddEq z xs t (F.Reft(s, rs))+ = F.Reft(s, [F.RConc (F.POr [ pand x | x <- xs])])+ where tref = fromMaybe mempty $ stripRTypeBase t+ pand x = F.PAnd $ (substzx x) (fFromRConc <$> rs)+ ++ exrefToPred x tref+ substzx x = F.subst (F.mkSubst [(z, F.EVar x)])++exrefToPred x uref+ = F.subst (F.mkSubst [(v, F.EVar x)]) ((fFromRConc <$> r))+ where (F.Reft(v, r)) = ur_reft uref+fFromRConc (F.RConc p) = p+fFromRConc _ = errorstar "can not hanlde existential type with kvars"++-------------------------------------------------------------------------------+-------------------- Cleaner Signatures For Rec-bindings ----------------------+-------------------------------------------------------------------------------++exprLoc :: CoreExpr -> Maybe SrcSpan++exprLoc (Tick tt _) = Just $ tickSrcSpan tt+exprLoc (App e a) | isType a = exprLoc e+exprLoc _ = Nothing++isType (Type _) = True+isType a = eqType (exprType a) predType+++exprRefType :: CoreExpr -> SpecType +exprRefType = exprRefType_ M.empty ++exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType +exprRefType_ γ (Let b e) + = exprRefType_ (bindRefType_ γ b) e++exprRefType_ γ (Lam α e) | isTyVar α+ = RAllT (rTyVar α) (exprRefType_ γ e)++exprRefType_ γ (Lam x e) + = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)++exprRefType_ γ (Tick _ e)+ = exprRefType_ γ e++exprRefType_ γ (Var x) + = M.lookupDefault (ofType $ varType x) x γ++exprRefType_ _ e+ = ofType $ exprType e++bindRefType_ γ (Rec xes)+ = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes]++bindRefType_ γ (NonRec x e)+ = extendγ γ [(x, exprRefType_ γ e)]++extendγ γ xts+ = foldr (\(x,t) m -> M.insert x t m) γ xts+++instance NFData REnv where+ rnf (REnv _) = () -- rnf m
+ src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -0,0 +1,32 @@+module Language.Haskell.Liquid.Constraint.ToFixpoint (++ cgInfoFInfo++ ) where++import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.Constraint.Types++import Language.Haskell.Liquid.Types hiding ( binds )+import Language.Fixpoint.Misc ( mapSnd )++import qualified Data.HashMap.Strict as M++import Language.Haskell.Liquid.Qualifier+import Language.Haskell.Liquid.RefType ( rTypeSortedReft )+++cgInfoFInfo :: GhcInfo -> CGInfo -> F.FInfo Cinfo+cgInfoFInfo info cgi+ = F.FI { F.cm = M.fromList $ F.addIds $ fixCs cgi+ , F.ws = fixWfs cgi + , F.bs = binds cgi + , F.gs = F.fromListSEnv . map mkSort $ meas spc+ , F.lits = lits cgi + , F.kuts = kuts cgi + , F.quals = (qualifiers $ spc) ++ (specificationQualifiers (maxParams (config spc)) info)+ }+ where + spc = spec info+ tce = tcEmbeds spc + mkSort = mapSnd (rTypeSortedReft tce . val)
+ src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -0,0 +1,260 @@+module Language.Haskell.Liquid.Constraint.Types where++import CoreSyn+import SrcLoc ++import qualified TyCon as TC+import qualified DataCon as DC+++import Text.PrettyPrint.HughesPJ hiding (first)++import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.List as L++import Control.Applicative ((<$>))+import Data.Monoid (mconcat)+import Data.Maybe (catMaybes)++import Var++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Strata+import Language.Haskell.Liquid.Misc (fourth4)+import Language.Haskell.Liquid.RefType (shiftVV)+import Language.Haskell.Liquid.PredType (wiredSortedSyms)+import qualified Language.Fixpoint.Types as F++import Language.Fixpoint.Misc ++import qualified Language.Haskell.Liquid.CTags as Tg++data CGEnv + = CGE { loc :: !SrcSpan -- ^ Location in original source file+ , renv :: !REnv -- ^ SpecTypes for Bindings in scope+ , syenv :: !(F.SEnv Var) -- ^ Map from free Symbols (e.g. datacons) to Var+ -- , penv :: !(F.SEnv PrType) -- ^ PrTypes for top-level bindings (merge with renv) + , denv :: !RDEnv -- ^ Dictionary Environment+ , fenv :: !FEnv -- ^ Fixpoint Environment+ , recs :: !(S.HashSet Var) -- ^ recursive defs being processed (for annotations)+ , invs :: !RTyConInv -- ^ Datatype invariants + , ial :: !RTyConIAl -- ^ Datatype checkable invariants + , grtys :: !REnv -- ^ Top-level variables with (assert)-guarantees to verify+ , assms :: !REnv -- ^ Top-level variables with assumed types+ , emb :: F.TCEmb TC.TyCon -- ^ How to embed GHC Tycons into fixpoint sorts+ , tgEnv :: !Tg.TagEnv -- ^ Map from top-level binders to fixpoint tag+ , tgKey :: !(Maybe Tg.TagKey) -- ^ Current top-level binder+ , trec :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints+ , lcb :: !(M.HashMap F.Symbol CoreExpr) -- ^ Let binding that have not been checked+ , holes :: !HEnv -- ^ Types with holes, will need refreshing+ , lcs :: !LConstraint -- ^ Logical Constraints+ } -- deriving (Data, Typeable)+++data LConstraint = LC [SpecType]+++instance PPrint CGEnv where+ pprint = pprint . renv++instance Show CGEnv where+ show = showpp++++-----------------------------------------------------------------+------------------- Constraints: Types --------------------------+-----------------------------------------------------------------++data SubC = SubC { senv :: !CGEnv+ , lhs :: !SpecType+ , rhs :: !SpecType + }+ | SubR { senv :: !CGEnv+ , oblig :: !Oblig+ , ref :: !RReft+ }++data WfC = WfC !CGEnv !SpecType + -- deriving (Data, Typeable)++type FixSubC = F.SubC Cinfo+type FixWfC = F.WfC Cinfo++instance PPrint SubC where+ pprint c = pprint (senv c)+ $+$ ((text " |- ") <+> ( (pprint (lhs c)) + $+$ text "<:" + $+$ (pprint (rhs c))))++instance PPrint WfC where+ pprint (WfC w r) = pprint w <> text " |- " <> pprint r ++instance SubStratum SubC where+ subS su (SubC γ t1 t2) = SubC γ (subS su t1) (subS su t2)+ subS _ c = c+++++-----------------------------------------------------------+-------------------- Generation: Types --------------------+-----------------------------------------------------------++data CGInfo = CGInfo { hsCs :: ![SubC] -- ^ subtyping constraints over RType+ , hsWfs :: ![WfC] -- ^ wellformedness constraints over RType+ , sCs :: ![SubC] -- ^ additional stratum constrains for let bindings+ , fixCs :: ![FixSubC] -- ^ subtyping over Sort (post-splitting)+ , isBind :: ![Bool] -- ^ tracks constraints that come from let-bindings + , fixWfs :: ![FixWfC] -- ^ wellformedness constraints over Sort (post-splitting)+ , freshIndex :: !Integer -- ^ counter for generating fresh KVars+ , binds :: !F.BindEnv -- ^ set of environment binders+ , annotMap :: !(AnnInfo (Annot SpecType)) -- ^ source-position annotation map+ , tyConInfo :: !(M.HashMap TC.TyCon RTyCon) -- ^ information about type-constructors+ , specDecr :: ![(Var, [Int])] -- ^ ? FIX THIS+ , termExprs :: !(M.HashMap Var [F.Expr]) -- ^ Terminating Metrics for Recursive functions+ , specLVars :: !(S.HashSet Var) -- ^ Set of variables to ignore for termination checking+ , specLazy :: !(S.HashSet Var) -- ^ ? FIX THIS+ , tyConEmbed :: !(F.TCEmb TC.TyCon) -- ^ primitive Sorts into which TyCons should be embedded+ , kuts :: !(F.Kuts) -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)+ , lits :: ![(F.Symbol, F.Sort)] -- ^ ? FIX THIS + , tcheck :: !Bool -- ^ Check Termination (?) + , scheck :: !Bool -- ^ Check Strata (?)+ , trustghc :: !Bool -- ^ Trust ghc auto generated bindings+ , pruneRefs :: !Bool -- ^ prune unsorted refinements+ , logErrors :: ![TError SpecType] -- ^ Errors during coontraint generation+ , kvProf :: !KVProf -- ^ Profiling distribution of KVars + , recCount :: !Int -- ^ number of recursive functions seen (for benchmarks)+ } -- deriving (Data, Typeable)++instance PPrint CGInfo where + pprint cgi = {-# SCC "ppr_CGI" #-} ppr_CGInfo cgi++ppr_CGInfo _cgi + = (text "*********** Constraint Information ***********")+ -- -$$ (text "*********** Haskell SubConstraints ***********")+ -- -$$ (pprintLongList $ hsCs cgi)+ -- -$$ (text "*********** Haskell WFConstraints ************")+ -- -$$ (pprintLongList $ hsWfs cgi)+ -- -$$ (text "*********** Fixpoint SubConstraints **********")+ -- -$$ (F.toFix $ fixCs cgi)+ -- -$$ (text "*********** Fixpoint WFConstraints ************")+ -- -$$ (F.toFix $ fixWfs cgi)+ -- -$$ (text "*********** Fixpoint Kut Variables ************")+ -- -$$ (F.toFix $ kuts cgi)+ -- -$$ (text "*********** Literals in Source ************")+ -- -$$ (pprint $ lits cgi)+ -- -$$ (text "*********** KVar Distribution *****************")+ -- -$$ (pprint $ kvProf cgi)+ -- -$$ (text "Recursive binders:" <+> pprint (recCount cgi))+++------------------------------------------------------------------------------+------------------------------------------------------------------------------+----------------------------- Helper Types: HEnv -----------------------------+------------------------------------------------------------------------------+------------------------------------------------------------------------------+++newtype HEnv = HEnv (S.HashSet F.Symbol)++fromListHEnv = HEnv . S.fromList+elemHEnv x (HEnv s) = x `S.member` s+++------------------------------------------------------------------------------+------------------------------------------------------------------------------+-------------------------- Helper Types: Invariants --------------------------+------------------------------------------------------------------------------+------------------------------------------------------------------------------+++type RTyConInv = M.HashMap RTyCon [SpecType]+type RTyConIAl = M.HashMap RTyCon [SpecType]++mkRTyConInv :: [F.Located SpecType] -> RTyConInv +mkRTyConInv ts = group [ (c, t) | t@(RApp c _ _ _) <- strip <$> ts]+ where + strip = fourth4 . bkUniv . val ++mkRTyConIAl = mkRTyConInv . fmap snd++addRTyConInv :: RTyConInv -> SpecType -> SpecType+addRTyConInv m t@(RApp c _ _ _)+ = case M.lookup c m of+ Nothing -> t+ Just ts -> L.foldl' conjoinInvariant' t ts+addRTyConInv _ t + = t ++addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType)+addRInv m (x, t) + | x `elem` ids , (RApp c _ _ _) <- res t, Just invs <- M.lookup c m+ = (x, addInvCond t (mconcat $ catMaybes (stripRTypeBase <$> invs))) + | otherwise + = (x, t)+ where+ ids = [id | tc <- M.keys m+ , dc <- TC.tyConDataCons $ rtc_tc tc+ , id <- DC.dataConImplicitIds dc]+ res = ty_res . toRTypeRep++conjoinInvariant' t1 t2 + = conjoinInvariantShift t1 t2++conjoinInvariantShift t1 t2 + = conjoinInvariant t1 (shiftVV t2 (rTypeValueVar t1)) ++conjoinInvariant (RApp c ts rs r) (RApp ic its _ ir) + | (c == ic && length ts == length its)+ = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir)++conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir) + = t { rt_reft = r `F.meet` ir }++conjoinInvariant t@(RVar _ r) (RVar _ ir) + = t { rt_reft = r `F.meet` ir }++conjoinInvariant t _ + = t++++grapBindsWithType tx γ + = fst <$> toListREnv (filterREnv ((== toRSort tx) . toRSort) (renv γ))++---------------------------------------------------------------+----- Refinement Type Environments ----------------------------+---------------------------------------------------------------++++toListREnv (REnv env) = M.toList env+filterREnv f (REnv env) = REnv $ M.filter f env+fromListREnv = REnv . M.fromList+deleteREnv x (REnv env) = REnv (M.delete x env)+insertREnv x y (REnv env) = REnv (M.insert x y env)+lookupREnv x (REnv env) = M.lookup x env+memberREnv x (REnv env) = M.member x env+++++------------------------------------------------------------------------------+------------------------------------------------------------------------------+------------------------ Fixpoint Environment --------------------------------+------------------------------------------------------------------------------+------------------------------------------------------------------------------+++data FEnv = FE { fe_binds :: !F.IBindEnv -- ^ Integer Keys for Fixpoint Environment+ , fe_env :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment+ }++insertFEnv (FE benv env) ((x, t), i)+ = FE (F.insertsIBindEnv [i] benv) (F.insertSEnv x t env)++insertsFEnv = L.foldl' insertFEnv++initFEnv init = FE F.emptyIBindEnv $ F.fromListSEnv (wiredSortedSyms ++ init)
src/Language/Haskell/Liquid/CoreToLogic.hs view
@@ -3,72 +3,181 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE EmptyDataDecls #-} -module Language.Haskell.Liquid.CoreToLogic ( coreToDef , mkLit, runToLogic, LError(..) ) where+module Language.Haskell.Liquid.CoreToLogic ( + coreToDef , coreToFun+ , mkLit, runToLogic,+ logicType, + strengthenResult++ ) where+ import GHC hiding (Located) import Var+import Type -import qualified CoreSyn as C+import qualified CoreSyn as C import Literal import IdInfo ++import TysWiredIn+ import Control.Applicative import Language.Fixpoint.Misc import Language.Fixpoint.Names (dropModuleNames, isPrefixOfSym) import Language.Fixpoint.Types hiding (Def, R, simplify) import qualified Language.Fixpoint.Types as F-import qualified Language.Fixpoint.Types as F-import Language.Haskell.Liquid.GhcMisc hiding (isDictionary)+import Language.Haskell.Liquid.GhcMisc+import Language.Haskell.Liquid.GhcPlay import Language.Haskell.Liquid.Types hiding (GhcInfo(..), GhcSpec (..))+import Language.Haskell.Liquid.WiredIn+import Language.Haskell.Liquid.RefType + import qualified Data.HashMap.Strict as M import Data.Monoid-import Data.Functor-import Data.Either -newtype LogicM a = LM (Either a LError) +logicType :: (Reftable r) => Type -> RRType r+logicType τ = fromRTypeRep $ t{ty_res = res, ty_binds = binds, ty_args = args}+ where + t = toRTypeRep $ ofType τ + res = mkResType $ ty_res t+ (binds, args) = unzip $ dropWhile isClassBind $ zip (ty_binds t) (ty_args t)+ -data LError = LE String+ mkResType t + | isBool t = propType+ | otherwise = t +isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon+isBool _ = False++isClassBind = isClassType . snd++{- strengthenResult type: the refinement depends on whether the result type is a Bool or not:++CASE1: measure f@logic :: X -> Prop <=> f@haskell :: x:X -> {v:Bool | (Prop v) <=> (f@logic x)} ++CASE2: measure f@logic :: X -> Y <=> f@haskell :: x:X -> {v:Y | v = (f@logic x)} +-}++strengthenResult :: Var -> SpecType+strengthenResult v+ | isBool res+ = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $ + fromRTypeRep $ rep{ty_res = res `strengthen` r, ty_binds = xs}+ | otherwise+ = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $ + fromRTypeRep $ rep{ty_res = res `strengthen` r', ty_binds = xs}+ where rep = toRTypeRep t+ res = ty_res rep+ xs = intSymbol (symbol ("x" :: String)) <$> [1..]+ r' = U (exprReft (EApp f (EVar <$> vxs))) mempty mempty+ r = U (propReft (PBexp $ EApp f (EVar <$> vxs))) mempty mempty+ vxs = fst $ unzip $ dropWhile isClassBind $ zip xs (ty_args rep)+ f = dummyLoc $ dropModuleNames $ simplesymbol v+ t = (ofType $ varType v) :: SpecType+++simplesymbol = symbol . getName++newtype LogicM a = LM {runM :: LState -> Either a Error}++data LState = LState { symbolMap :: LogicMap + , mkError :: String -> Error+ }++ instance Monad LogicM where- return = LM . Left- (LM (Left x)) >>= f = f x- (LM (Right x)) >>= f = LM (Right x)+ return = LM . const . Left+ (LM m) >>= f + = LM $ \s -> case m s of + (Left x) -> (runM (f x)) s + (Right x) -> Right x instance Functor LogicM where- fmap f (LM (Left x)) = LM $ Left $ f x- fmap f (LM (Right x)) = LM $ Right x+ fmap f (LM m) = LM $ \s -> case m s of + (Left x) -> Left $ f x+ (Right x) -> Right x instance Applicative LogicM where- pure = LM . Left-- (LM (Left f)) <*> (LM (Left x)) = LM $ Left (f x)- (LM (Right f)) <*> (LM (Left x)) = LM $ Right f- (LM (Left f)) <*> (LM (Right x)) = LM $ Right x- (LM (Right f)) <*> (LM (Right x)) = LM $ Right x+ pure = LM . const . Left+ (LM f) <*> (LM m) + = LM $ \s -> case (f s, m s) of + (Left f , Left x ) -> Left $ f x+ (Right f, Left _ ) -> Right f+ (Left _ , Right x) -> Right x+ (Right _, Right x) -> Right x throw :: String -> LogicM a-throw = LM . Right . LE+throw str = LM $ \s -> Right $ (mkError s) str -runToLogic (LM x) = x+getState :: LogicM LState+getState = LM $ Left +runToLogic lmap ferror (LM m) + = m $ LState {symbolMap = lmap, mkError = ferror}+ coreToDef :: LocSymbol -> Var -> C.CoreExpr -> LogicM [Def DataCon]-coreToDef x v e = go $ simplify e+coreToDef x _ e = go $ inline_preds $ simplify e where- go (C.Lam a e) = go e+ go (C.Lam _ e) = go e go (C.Tick _ e) = go e- go (C.Case _ _ _ alts) = mapM goalt alts- go e' = throw "Measure Functions should have a case at top level"+ go (C.Case _ _ t alts) + | eqType t boolTy = mapM goalt_prop alts+ | otherwise = mapM goalt alts+ go _ = throw "Measure Functions should have a case at top level" - goalt ((C.DataAlt d), xs, e) = ((Def x d (symbol <$> xs)) . E) <$> coreToLogic e+ goalt ((C.DataAlt d), xs, e) = ((Def x d (symbol <$> xs)) . E) <$> coreToLogic e goalt alt = throw $ "Bad alternative" ++ showPpr alt + goalt_prop ((C.DataAlt d), xs, e) = ((Def x d (symbol <$> xs)) . P) <$> coreToPred e+ goalt_prop alt = throw $ "Bad alternative" ++ showPpr alt + inline_preds = inline (eqType boolTy . varType)++coreToFun :: LocSymbol -> Var -> C.CoreExpr -> LogicM ([Symbol], Either Pred Expr)+coreToFun _ v e = go [] $ inline_preds $ simplify e+ where+ go acc (C.Lam x e) | isTyVar x = go acc e+ go acc (C.Lam x e) | isErasable x = go acc e+ go acc (C.Lam x e) = go (symbol x : acc) e+ go acc (C.Tick _ e) = go acc e+ go acc e | eqType rty boolTy + = (reverse acc,) . Left . traceShow "coreToPred" <$> coreToPred e + | otherwise + = (reverse acc,) . Right . traceShow "coreToLogic" <$> coreToLogic e++ inline_preds = inline (eqType boolTy . varType)++ rty = snd $ splitFunTys $ snd $ splitForAllTys $ varType v++instance Show C.CoreExpr where+ show = showPpr++coreToPred :: C.CoreExpr -> LogicM Pred+coreToPred (C.Let b p) = subst1 <$> coreToPred p <*> makesub b+coreToPred (C.Tick _ p) = coreToPred p+coreToPred (C.App (C.Var v) e) | ignoreVar v = coreToPred e+coreToPred (C.Var x)+ | x == falseDataConId+ = return PFalse+ | x == trueDataConId+ = return PTrue+coreToPred p@(C.App _ _) = toPredApp p +coreToPred e+ = PBexp <$> coreToLogic e +-- coreToPred e +-- = throw ("Cannot transform to Logical Predicate:\t" ++ showPpr e)++ coreToLogic :: C.CoreExpr -> LogicM Expr coreToLogic (C.Let b e) = subst1 <$> coreToLogic e <*> makesub b coreToLogic (C.Tick _ e) = coreToLogic e@@ -77,38 +186,108 @@ = case mkLit l of Nothing -> throw $ "Bad Literal in measure definition" ++ showPpr l Just i -> return i-coreToLogic (C.Var x) = return $ EVar $ symbol x+coreToLogic (C.Var x) = (symbolMap <$> getState) >>= eVarWithMap x coreToLogic e@(C.App _ _) = toLogicApp e -coreToLogic e = throw ("Cannot transform to Logic" ++ showPpr e)+coreToLogic (C.Case e b _ alts) | eqType (varType b) boolTy+ = checkBoolAlts alts >>= coreToIte e +coreToLogic e = throw ("Cannot transform to Logic:\t" ++ showPpr e) +checkBoolAlts :: [C.CoreAlt] -> LogicM (C.CoreExpr, C.CoreExpr)+checkBoolAlts [(C.DataAlt false, [], efalse), (C.DataAlt true, [], etrue)]+ | false == falseDataCon, true == trueDataCon+ = return (efalse, etrue)+checkBoolAlts [(C.DataAlt true, [], etrue), (C.DataAlt false, [], efalse)]+ | false == falseDataCon, true == trueDataCon+ = return (efalse, etrue)+checkBoolAlts alts+ = throw ("checkBoolAlts failed on " ++ showPpr alts) ++coreToIte e (efalse, etrue)+ = do p <- coreToPred e+ e1 <- coreToLogic efalse + e2 <- coreToLogic etrue+ return $ EIte p e2 e1++toPredApp :: C.CoreExpr -> LogicM Pred+toPredApp p + = do let (f, es) = splitArgs p+ f' <- tosymbol f+ go f' es+ where+ go f [e1, e2]+ | Just rel <- M.lookup (val f) brels + = PAtom rel <$> (coreToLogic e1) <*> (coreToLogic e2)+ go f [e]+ | val f == symbol ("not" :: String)+ = PNot <$> coreToPred e+ go f [e1, e2]+ | val f == symbol ("||" :: String)+ = POr <$> mapM coreToPred [e1, e2]+ | val f == symbol ("&&" :: String)+ = PAnd <$> mapM coreToPred [e1, e2]+ go f es+ | val f == symbol ("or" :: String)+ = POr <$> mapM coreToPred es+ | val f == symbol ("and" :: String)+ = PAnd <$> mapM coreToPred es+ | otherwise+ = PBexp <$> toLogicApp p+ toLogicApp :: C.CoreExpr -> LogicM Expr toLogicApp e = do let (f, es) = splitArgs e- args <- reverse <$> (mapM coreToLogic es)- (`makeApp` args) <$> tosymbol f+ args <- mapM coreToLogic es+ lmap <- symbolMap <$> getState+ def <- (`EApp` args) <$> tosymbol f+ (\x -> makeApp def lmap x args) <$> tosymbol' f -makeApp f [e1, e2] | Just op <- M.lookup (val f) bops+makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr+makeApp _ _ f [e1, e2] | Just op <- M.lookup (val f) bops = EBin op e1 e2 -makeApp f args - = EApp f args+makeApp def lmap f es + = eAppWithMap lmap f es def +eVarWithMap :: Id -> LogicMap -> LogicM Expr+eVarWithMap x lmap + = do f' <- tosymbol' (C.Var x :: C.CoreExpr)+ return $ eAppWithMap lmap f' [] (EVar $ symbol x)++brels :: M.HashMap Symbol Brel+brels = M.fromList [ (symbol ("==" :: String), Eq)+ , (symbol ("/=" :: String), Ne)+ , (symbol (">=" :: String), Ge)+ , (symbol (">" :: String) , Gt)+ , (symbol ("<=" :: String), Le)+ , (symbol ("<" :: String) , Lt)+ ]+ bops :: M.HashMap Symbol Bop-bops = M.fromList [ (symbol ("+" :: String), Plus)- , (symbol ("-" :: String), Minus)- , (symbol ("*" :: String), Times)- , (symbol ("/" :: String), Div)- , (symbol ("%" :: String), Mod)+bops = M.fromList [ (numSymbol "+", Plus)+ , (numSymbol "-", Minus)+ , (numSymbol "*", Times)+ , (numSymbol "/", Div)+ , (numSymbol "%", Mod) ] + where+ numSymbol :: String -> Symbol+ numSymbol = symbol . (++) "GHC.Num." -splitArgs (C.App (C.Var i) e) | ignoreVar i = splitArgs e-splitArgs (C.App f (C.Var v)) | isDictionary v = splitArgs f-splitArgs (C.App f e) = (f', e:es) where (f', es) = splitArgs f-splitArgs f = (f, [])+splitArgs e = (f, reverse es)+ where+ (f, es) = go e + go (C.App (C.Var i) e) | ignoreVar i = go e+ go (C.App f (C.Var v)) | isErasable v = go f+ go (C.App f e) = (f', e:es) where (f', es) = go f+ go f = (f, [])+ tosymbol (C.Var x) = return $ dummyLoc $ simpleSymbolVar x tosymbol e = throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied") +tosymbol' (C.Var x) = return $ dummyLoc $ simpleSymbolVar' x+tosymbol' e = throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied")+ makesub (C.NonRec x e) = (symbol x,) <$> coreToLogic e makesub _ = throw "Cannot make Logical Substitution of Recursive Definitions" @@ -128,22 +307,24 @@ simpleSymbolVar = dropModuleNames . symbol . showPpr . getName+simpleSymbolVar' = symbol . showPpr . getName -isDictionary v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v)+isErasable v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v) isDead = isDeadOcc . occInfo . idInfo class Simplify a where simplify :: a -> a + inline :: (Id -> Bool) -> a -> a instance Simplify C.CoreExpr where- simplify e@(C.Var x) + simplify e@(C.Var _) = e simplify e@(C.Lit _) = e simplify (C.App e (C.Type _)) = simplify e- simplify (C.App e (C.Var dict)) | isDictionary dict + simplify (C.App e (C.Var dict)) | isErasable dict = simplify e simplify (C.App (C.Lam x e) _) | isDead x = simplify e@@ -157,15 +338,38 @@ = C.Let (simplify xes) (simplify e) simplify (C.Case e x t alts) = C.Case (simplify e) x t (simplify <$> alts)- simplify (C.Cast e c) + simplify (C.Cast e _) = simplify e simplify (C.Tick _ e) = simplify e+ simplify (C.Coercion c)+ = C.Coercion c+ simplify (C.Type t)+ = C.Type t + inline p (C.Let (C.NonRec x ex) e) | p x+ = sub (M.singleton x (inline p ex)) (inline p e)+ inline p (C.Let xes e) = C.Let (inline p xes) (inline p e) + inline p (C.App e1 e2) = C.App (inline p e1) (inline p e2)+ inline p (C.Lam x e) = C.Lam x (inline p e)+ inline p (C.Case e x t alts) = C.Case (inline p e) x t (inline p <$> alts)+ inline p (C.Cast e c) = C.Cast (inline p e) c+ inline p (C.Tick t e) = C.Tick t (inline p e)+ inline _ (C.Var x) = C.Var x+ inline _ (C.Lit l) = C.Lit l+ inline _ (C.Coercion c) = C.Coercion c+ inline _ (C.Type t) = C.Type t++ instance Simplify C.CoreBind where simplify (C.NonRec x e) = C.NonRec x (simplify e) simplify (C.Rec xes) = C.Rec (mapSnd simplify <$> xes ) + inline p (C.NonRec x e) = C.NonRec x (inline p e)+ inline p (C.Rec xes) = C.Rec (mapSnd (inline p) <$> xes)+ instance Simplify C.CoreAlt where simplify (c, xs, e) = (c, xs, simplify e) ++ inline p (c, xs, e) = (c, xs, inline p e)
src/Language/Haskell/Liquid/Desugar/Check.lhs view
@@ -483,9 +483,9 @@ remove_var _ = panic "Check.remove_var: equation does not begin with a variable" -----------------------+{- eqnPats :: (EqnNo, EquationInfo) -> [Pat Id] eqnPats (_, eqn) = eqn_pats eqn- okGroup :: [(EqnNo, EquationInfo)] -> Bool -- True if all equations have at least one pattern, and -- all have the same number of patterns@@ -493,12 +493,12 @@ okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] where n_pats = length (eqnPats e)-+-} -- Half-baked print-pprGroup :: [(EqnNo, EquationInfo)] -> SDoc-pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc-pprGroup es = vcat (map pprEqnInfo es)-pprEqnInfo e = ppr (eqnPats e)+-- pprGroup :: [(EqnNo, EquationInfo)] -> SDoc+-- pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc+-- pprGroup es = vcat (map pprEqnInfo es)+-- pprEqnInfo e = ppr (eqnPats e) firstPatN :: (EqnNo, EquationInfo) -> Pat Id
src/Language/Haskell/Liquid/Desugar/DsBinds.lhs view
@@ -44,7 +44,7 @@ import Digraph -import TyCon ( isTupleTyCon, tyConDataCons_maybe )+import TyCon ( tyConDataCons_maybe ) import TcEvidence import TcType import Type
src/Language/Haskell/Liquid/Desugar/DsExpr.lhs view
@@ -133,11 +133,11 @@ ; ds_binds <- dsTcEvBinds ev_binds ; return (mkCoreLets ds_binds body2) } -dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn +dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches , fun_tick = tick, fun_infix = inf }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed- = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches+ = do { (_, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches -- ; MASSERT( null args ) -- Functions aren't lifted -- ; MASSERT( isIdHsWrapper co_fn ) ; let rhs' = mkOptTickBox tick rhs@@ -419,7 +419,7 @@ mk_arg (arg_ty, lbl) -- Selector id has the field label as its name = case findField (rec_flds rbinds) lbl of- (rhs:rhss) -> -- ASSERT( null rhss )+ (rhs:_) -> -- ASSERT( null rhss ) dsLExpr rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty@@ -468,7 +468,7 @@ So we need to cast (T a Int) to (T a b). Sigh. \begin{code}-dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })+dsExpr (RecordUpd record_expr (HsRecFields { rec_flds = fields }) cons_to_upd in_inst_tys out_inst_tys) | null fields = dsLExpr record_expr@@ -743,7 +743,7 @@ goL [] = panic "dsDo" goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (LastStmt body _) stmts+ go _ (LastStmt body _) _ = {- ASSERT( null stmts ) -} dsLExpr body -- The 'return' op isn't used for 'do' expressions
src/Language/Haskell/Liquid/Desugar/DsForeign.lhs view
@@ -53,7 +53,6 @@ import Config import OrdList import Pair-import Util import Hooks import Data.Maybe@@ -151,19 +150,19 @@ -> Safety -> Maybe Header -> DsM ([Binding], SDoc, SDoc)-dsCImport id co (CLabel cid) cconv _ _ = do- dflags <- getDynFlags- let ty = pFst $ coercionKind co- fod = case tyConAppTyCon_maybe (dropForAlls ty) of- Just tycon- | tyConUnique tycon == funPtrTyConKey ->- IsFunction- _ -> IsData- (resTy, foRhs) <- resultWrapper ty+dsCImport id co (CLabel _) _ _ _ = do+ -- dflags <- getDynFlags+ -- let ty = pFst $ coercionKind co+ -- fod = case tyConAppTyCon_maybe (dropForAlls ty) of+ -- Just tycon+ -- | tyConUnique tycon == funPtrTyConKey ->+ -- IsFunction+ -- _ -> IsData+ -- (resTy, foRhs) <- resultWrapper ty -- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this let rhs = let x = x in x -- foRhs (Lit (MachLabel cid stdcall_info fod)) let rhs' = Cast rhs co- let stdcall_info = fun_type_arg_stdcall_info dflags cconv ty+ -- let stdcall_info = fun_type_arg_stdcall_info dflags cconv ty return ([(id, rhs')], empty, empty) dsCImport id co (CFunction target) cconv@PrimCallConv safety _@@ -176,16 +175,16 @@ -- For stdcall labels, if the type was a FunPtr or newtype thereof, -- then we need to calculate the size of the arguments in order to add -- the @n suffix to the label.-fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int-fun_type_arg_stdcall_info dflags StdCallConv ty- | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,- tyConUnique tc == funPtrTyConKey- = let- (_tvs,sans_foralls) = tcSplitForAllTys arg_ty- (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls- in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)-fun_type_arg_stdcall_info _ _other_conv _- = Nothing+-- fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int+-- fun_type_arg_stdcall_info dflags StdCallConv ty+-- | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,+-- tyConUnique tc == funPtrTyConKey+-- = let+-- (_tvs,sans_foralls) = tcSplitForAllTys arg_ty+-- (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls+-- in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)+-- fun_type_arg_stdcall_info _ _other_conv _+-- = Nothing \end{code} @@ -776,7 +775,7 @@ -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). | otherwise = case splitDataProductType_maybe rep_ty of- Just (_, _, data_con, [prim_ty]) ->+ Just (_, _, _, [prim_ty]) -> -- ASSERT(dataConSourceArity data_con == 1) -- ASSERT2(isUnLiftedType prim_ty, ppr prim_ty) prim_ty
src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs view
@@ -25,7 +25,6 @@ import PrelNames import Module import Name-import Util import SrcLoc import Outputable \end{code}
src/Language/Haskell/Liquid/Desugar/DsListComp.lhs view
@@ -34,7 +34,6 @@ import FastString import TcType import ListSetOps( getNth )-import Util \end{code} List comprehensions may be desugared in one of two ways: ``ordinary''@@ -209,7 +208,7 @@ deListComp [] _ = panic "deListComp" -deListComp (LastStmt body _ : quals) list+deListComp (LastStmt body _ : _) list = -- Figure 7.4, SLPJ, p 135, rule C above -- ASSERT( null quals ) do { core_body <- dsLExpr body@@ -316,7 +315,7 @@ dfListComp _ _ [] = panic "dfListComp" -dfListComp c_id n_id (LastStmt body _ : quals)+dfListComp c_id n_id (LastStmt body _ : _) = -- ASSERT( null quals ) do { core_body <- dsLExpr body ; return (mkApps (Var c_id) [core_body, Var n_id]) }@@ -516,7 +515,7 @@ -- -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea ---dePArrComp (LastStmt e' _ : quals) pa cea+dePArrComp (LastStmt e' _ : _) pa cea = -- ASSERT( null quals ) do { mapP <- dsDPHBuiltin mapPVar ; let ty = parrElemType cea@@ -674,7 +673,7 @@ --------------- dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr -dsMcStmt (LastStmt body ret_op) stmts+dsMcStmt (LastStmt body ret_op) _ = -- ASSERT( null stmts ) do { body' <- dsLExpr body ; ret_op' <- dsExpr ret_op
src/Language/Haskell/Liquid/Desugar/HscMain.hs view
@@ -31,70 +31,16 @@ import Language.Haskell.Liquid.Desugar.Desugar (deSugarWithLoc) import Module -import Packages-import RdrName-import HsSyn-import CoreSyn-import StringBuffer-import Parser import Lexer-import SrcLoc-import TcRnDriver-import TcIface ( typecheckIface ) import TcRnMonad-import IfaceEnv ( initNameCache )-import LoadIface ( ifaceStats, initExternalPackageState )-import PrelInfo-import MkIface-import SimplCore-import TidyPgm-import CorePrep-import CoreToStg ( coreToStg )-import qualified StgCmm ( codeGen )-import StgSyn-import CostCentre-import ProfInit-import TyCon-import Name-import SimplStg ( stg2stg )-import Cmm-import CmmParse ( parseCmmFile )-import CmmBuildInfoTables-import CmmPipeline-import CmmInfo-import CodeOutput-import NameEnv ( emptyNameEnv )-import NameSet ( emptyNameSet )-import InstEnv-import FamInstEnv-import Fingerprint ( Fingerprint )-import Hooks -import DynFlags import ErrUtils -import Outputable-import HscStats ( ppSourceStats ) import HscTypes-import MkExternalCore ( emitExternalCore )-import FastString-import UniqFM ( emptyUFM )-import UniqSupply import Bag import Exception-import qualified Stream-import Stream (Stream) -import Util -import Data.List-import Control.Monad-import Data.Maybe-import Data.IORef-import System.FilePath as FilePath-import System.Directory-- -- ----------------------------------------------------------------------------- getWarnings :: Hsc WarningMessages@@ -107,12 +53,6 @@ logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) --- | log warning in the monad, and if there are errors then--- throw a SourceError exception.-logWarningsReportErrors :: Messages -> Hsc ()-logWarningsReportErrors (warns,errs) = do- logWarnings warns- when (not $ isEmptyBag errs) $ throwErrors errs -- | Throw some errors. throwErrors :: ErrorMessages -> Hsc a
src/Language/Haskell/Liquid/Desugar/Match.lhs view
@@ -275,12 +275,13 @@ corresponds roughly to @matchVarCon@. \begin{code}+ match :: [Id] -- Variables rep\'ing the exprs we\'re matching with -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -match [] ty eqns+match [] _ eqns = -- ASSERT2( not (null eqns), ppr ty ) return (foldr1 combineMatchResults match_results) where
src/Language/Haskell/Liquid/Desugar/MatchCon.lhs view
@@ -155,9 +155,9 @@ -- dataConInstOrigArgTys takes the univ and existential tyvars -- and returns the types of the *value* args, which is what we want - ex_tvs = case con1 of- RealDataCon dcon1 -> dataConExTyVars dcon1- PatSynCon psyn1 -> patSynExTyVars psyn1+-- ex_tvs = case con1 of+-- RealDataCon dcon1 -> dataConExTyVars dcon1+-- PatSynCon psyn1 -> patSynExTyVars psyn1 match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult -- All members of the group have compatible ConArgPats
src/Language/Haskell/Liquid/Desugar/MatchLit.lhs view
@@ -44,11 +44,7 @@ import DynFlags import Util import FastString-import Control.Monad -import Data.Int-import Data.Traversable (traverse)-import Data.Word \end{code} %************************************************************************@@ -156,7 +152,7 @@ \begin{code} warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()-warnAboutOverflowedLiterals dflags lit+warnAboutOverflowedLiterals _ _ -- | wopt Opt_WarnOverflowedLiterals dflags -- , Just (i, tc) <- getIntegralLit lit -- = if tc == intTyConName then check i tc (undefined :: Int)@@ -204,7 +200,7 @@ warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM () -- Warns about [2,3 .. 1] which returns the empty list -- Only works for integral types, not floating point-warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr+warnAboutEmptyEnumerations _ _ _ _ -- | wopt Opt_WarnEmptyEnumerations dflags -- , Just (from,tc) <- getLHsIntegralLit fromExpr -- , Just mThn <- traverse getLHsIntegralLit mThnExpr@@ -232,7 +228,7 @@ -- else return () -- | otherwise = return ()-+{- getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name) -- See if the expression is an Integral literal -- Remember to look through automatically-added tick-boxes! (Trac #8384)@@ -247,6 +243,7 @@ | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc) getIntegralLit _ = Nothing+-} \end{code} @@ -402,7 +399,7 @@ litValKey (HsIntegral i) True = MachInt (-i) litValKey (HsFractional r) False = MachFloat (fl_value r) litValKey (HsFractional r) True = MachFloat (negate (fl_value r))-litValKey (HsIsString s) neg = {- ASSERT( not neg) -} MachStr (fastStringToByteString s)+litValKey (HsIsString s) _ = {- ASSERT( not neg) -} MachStr (fastStringToByteString s) \end{code} %************************************************************************
+ src/Language/Haskell/Liquid/Dictionaries.hs view
@@ -0,0 +1,66 @@+module Language.Haskell.Liquid.Dictionaries (+ makeDictionaries+ , makeDictionary++ , dfromList+ , dmapty+ , dmap+ , dinsert+ , dlookup+ , dhasinfo+ ) where++import Control.Applicative ((<$>))++import Var+++import Language.Fixpoint.Names (dropModuleNames)+import Language.Fixpoint.Types+import Language.Fixpoint.Misc ++import Language.Haskell.Liquid.GhcMisc ()+import Language.Haskell.Liquid.Types++import qualified Data.HashMap.Strict as M+import Language.Haskell.Liquid.PrettyPrint ()++makeDictionaries :: [RInstance SpecType] -> DEnv Symbol SpecType+makeDictionaries = DEnv . M.fromList . map makeDictionary+++makeDictionary :: RInstance SpecType -> (Symbol, M.HashMap Symbol SpecType)+makeDictionary (RI c t xts) = (makeDictionaryName c t, M.fromList (mapFst val <$> xts))++makeDictionaryName :: Located Symbol -> SpecType -> Symbol+makeDictionaryName t (RApp c _ _ _) = symbol ("$f" ++ (symbolString $ val t) ++ c')+ where + c' = symbolString (dropModuleNames $ symbol $ rtc_tc c)++makeDictionaryName _ _ = errorstar "makeDictionaryName: called with invalid type"++------------------------------------------------------------------------------+------------------------------------------------------------------------------+------------------------ Dictionay Environment -------------------------------+------------------------------------------------------------------------------+------------------------------------------------------------------------------+++dfromList :: [(Var, M.HashMap Symbol t)] -> DEnv Var t+dfromList = DEnv . M.fromList++dmapty :: (a -> b) -> DEnv v a -> DEnv v b+dmapty f (DEnv e) = DEnv (M.map (M.map f) e)++dmap f xts = M.map f xts++dinsert (DEnv denv) x xts = DEnv $ M.insert x xts denv++dlookup (DEnv denv) x = M.lookup x denv+++dhasinfo Nothing _ = Nothing+dhasinfo (Just xts) x = M.lookup x' xts+ where+ x' = (dropModuleNames $ symbol $ show x)+
src/Language/Haskell/Liquid/DiffCheck.hs view
@@ -38,17 +38,14 @@ 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.Misc (traceShow) import Language.Fixpoint.Types (FixResult (..)) import Language.Fixpoint.Files-import Language.Haskell.Liquid.Types (errSpan, AnnInfo (..), Error, TError (..), Output (..))+import Language.Haskell.Liquid.Types (AnnInfo (..), Error, TError (..), Output (..)) import Language.Haskell.Liquid.GhcInterface import Language.Haskell.Liquid.GhcMisc import Text.Parsec.Pos (sourceName, sourceLine, sourceColumn, SourcePos, newPos)-import Text.PrettyPrint.HughesPJ (text, render, Doc)-import Control.Monad (forM, forM_)+import Text.PrettyPrint.HughesPJ (text, render, Doc) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB@@ -132,7 +129,10 @@ ------------------------------------------------------------------------- coreDefs :: [CoreBind] -> [Def] --------------------------------------------------------------------------coreDefs cbs = L.sort [D l l' x | b <- cbs, let (l, l') = coreDef b, x <- bindersOf b]+coreDefs cbs = L.sort [D l l' x | b <- cbs+ , x <- bindersOf b+ , isGoodSrcSpan (getSrcSpan x)+ , (l, l') <- coreDef b] coreDef b = meetSpans b eSp vSp where eSp = lineSpan b $ catSpans b $ bindSpans b @@ -149,28 +149,25 @@ -- 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')+meetSpans _ Nothing _ + = []+meetSpans _ (Just (l,l')) Nothing + = [(l, l')]+meetSpans _ (Just (l,l')) (Just (m,_)) + = [(max l m, l')] lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp)-lineSpan b _ = Nothing +lineSpan _ _ = Nothing -catSpans b [] = error $ "INCCHECK: catSpans: no spans found for " ++ showPpr b-catSpans b xs = foldr1 combineSrcSpans [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z]+catSpans b [] = error $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b+catSpans b xs = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z] bindFile (NonRec x _) = varFile x bindFile (Rec xes) = varFile $ fst $ head xes varFile b = case getSrcSpan b of RealSrcSpan z -> srcSpanFile z- _ -> error $ "INCCHECK: getFile: no file found for: " ++ showPpr b+ _ -> error $ "DIFFCHECK: getFile: no file found for: " ++ showPpr b bindSpans (NonRec x e) = getSrcSpan x : exprSpans e@@ -190,7 +187,7 @@ 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 = [] +exprSpans _ = [] altSpans (_, xs, e) = map getSrcSpan xs ++ exprSpans e @@ -309,7 +306,7 @@ adjustResult lm cm (Crash es z) = errorsResult (`Crash` z) $ adjustErrors lm cm es adjustResult _ _ r = r -errorsResult f [] = Safe+errorsResult _ [] = Safe errorsResult f es = f es adjustErrors lm cm = mapMaybe adjustError@@ -331,22 +328,14 @@ isCheckedRealSpan cm = not . null . (`IM.search` cm) . srcSpanStartLine adjustSpan lm (RealSrcSpan rsp) = RealSrcSpan <$> adjustReal lm rsp -adjustSpan lm sp = Just sp +adjustSpan _ sp = Just sp adjustReal lm rsp | Just δ <- getShift l1 lm = Just $ realSrcSpan f (l1 + δ) c1 (l2 + δ) c2 | otherwise = Nothing where (f, l1, c1, l2, c2) = unpackRealSrcSpan rsp --- DELETE unCheckedDefs cd = filter (not . isCheckedError cm) --- DELETE where --- DELETE cm = checkedItv cd--- DELETE --- DELETE isCheckedError cm e--- DELETE | RealSrcSpan sp <- errSpan e = isCheckedSpan sp--- DELETE | otherwise = False - -- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@ -- in the diff and returns @Nothing@ otherwise. getShift :: Int -> LMap -> Maybe Int@@ -408,47 +397,4 @@ instance ToJSON (Output Doc) instance FromJSON (Output Doc) --- Move to Fixpoint--- instance ToJSON Symbol --- instance FromJSON Symbol --- instance ToJSON Subst --- instance FromJSON Subst--- instance ToJSON Sort--- instance FromJSON Sort--- instance ToJSON SymConst --- instance FromJSON SymConst--- instance ToJSON Constant --- instance FromJSON Constant--- instance ToJSON Bop --- instance FromJSON Bop --- instance ToJSON Brel --- instance FromJSON Brel--- instance ToJSON LocSymbol --- instance FromJSON LocSymbol --- instance ToJSON FTycon --- instance FromJSON FTycon --- instance ToJSON Expr --- instance FromJSON Expr --- instance ToJSON Pred --- instance FromJSON Pred --- instance ToJSON Refa --- instance FromJSON Refa --- instance ToJSON Reft--- instance FromJSON Reft--- --- -- Move to Types--- instance ToJSON Predicate --- instance FromJSON Predicate --- instance ToJSON LParseError --- instance FromJSON LParseError --- instance ToJSON Oblig --- instance FromJSON Oblig --- instance ToJSON Stratum--- instance FromJSON Stratum--- instance ToJSON RReft--- instance FromJSON RReft--- instance ToJSON UsedPVar--- instance FromJSON UsedPVar--- instance ToJSON EMsg --- instance FromJSON EMsg
src/Language/Haskell/Liquid/Errors.hs view
@@ -14,9 +14,7 @@ import Data.Hashable import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S-import qualified Data.Text as T-import Data.List (sortBy, intersperse)-import Data.Function (on)+import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList) import Data.Monoid hiding ((<>)) import Language.Fixpoint.Misc hiding (intersperse)@@ -39,7 +37,7 @@ . tidyErrContext sol . applySolution sol -tidyErrContext s err@(ErrSubType {})+tidyErrContext _ err@(ErrSubType {}) = err { ctx = c', tact = subst θ tA, texp = subst θ tE } where (θ, c') = tidyCtx xs $ ctx err @@ -148,16 +146,19 @@ ppError' :: (PPrint a) => Tidy -> Doc -> TError a -> Doc ----------------------------------------------------------------------- -ppError' _ dSp (ErrAssType _ OTerm s r)+ppError' _ dSp (ErrAssType _ OCons _ _)+ = dSp <+> text "Constraint Check"++ppError' _ dSp (ErrAssType _ OTerm _ _) = dSp <+> text "Termination Check" -ppError' _ dSp (ErrAssType _ OInv s r)+ppError' _ dSp (ErrAssType _ OInv _ _) = dSp <+> text "Invariant Check" -ppError' Lossy dSp (ErrSubType _ s c tA tE)+ppError' Lossy dSp (ErrSubType _ _ _ _ _) = dSp <+> text "Liquid Type Mismatch" -ppError' Full dSp (ErrSubType _ s c tA tE)+ppError' Full dSp (ErrSubType _ _ c tA tE) = dSp <+> text "Liquid Type Mismatch" $+$ sepVcat blankLine [ nests 2 [ text "Inferred type" @@ -176,6 +177,15 @@ $+$ (pprint v <+> dcolon <+> pprint t) $+$ (nest 4 $ pprint s) +ppError' _ dSp (ErrBadData _ v s)+ = dSp <+> text "Bad Data Specification"+ $+$ (pprint v <+> dcolon <+> pprint s)++ppError' _ dSp (ErrTermSpec _ v e s)+ = dSp <+> text "Bad Termination Specification"+ $+$ (pprint v <+> dcolon <+> pprint e)+ $+$ (nest 4 $ pprint s)+ ppError' _ dSp (ErrInvt _ t s) = dSp <+> text "Bad Invariant Specification" $+$ (nest 4 $ text "invariant " <+> pprint t $+$ pprint s)@@ -218,6 +228,20 @@ $+$ text "Haskell:" <+> pprint τ $+$ text "Liquid :" <+> pprint t +ppError' _ dSp (ErrAliasCycle _ acycle)+ = dSp <+> text "Cyclic Alias Definitions"+ $+$ text "The following alias definitions form a cycle:"+ $+$ (nest 4 $ sepVcat blankLine $ map describe acycle)+ where+ describe (pos, name)+ = text "Type alias:" <+> pprint name+ $+$ text "Defined at:" <+> pprint pos++ppError' _ dSp (ErrIllegalAliasApp _ dn dl)+ = dSp <+> text "Refinement Type Alias cannot be used in this context"+ $+$ text "Type alias:" <+> pprint dn+ $+$ text "Defined at:" <+> pprint dl+ ppError' _ dSp (ErrAliasApp _ n name dl dn) = dSp <+> text "Malformed Type Alias Application" $+$ text "Type alias:" <+> pprint name@@ -230,25 +254,23 @@ ppError' _ dSp (ErrTermin xs _ s) = dSp <+> text "Termination Error on" <+> (hsep $ intersperse comma $ map pprint xs) $+$ s +ppError' _ dSp (ErrRClass pos cls insts)+ = dSp <+> text "Refined classes cannot have refined instances"+ $+$ (nest 4 $ sepVcat blankLine $ describeCls : map describeInst insts)+ where+ describeCls+ = text "Refined class definition for:" <+> cls+ $+$ text "Defined at:" <+> pprint pos+ describeInst (pos, t)+ = text "Refined instance for:" <+> t+ $+$ text "Defined at:" <+> pprint pos+ ppError' _ _ (ErrOther _ s) = text "Panic!" <+> nest 4 (pprint s) ppVar v = text "`" <> pprint v <> text "'" ---- instance (Ord k, PPrint k, PPrint v) => PPrint (M.HashMap k v) where--- pprint = ppTable---- ppXTS xts' = vcat $ ppXT n <$> xts--- where --- n = 1 + maximum [ i | (x, _) <- xts, let i = keySize x, i <= thresh ]--- keySize = length . render . pprint--- xts = sortBy (compare `on` fst) xts' -- $ M.toList m--- thresh = 6--- --- ppXT n (x,t) = pprint x $$ nest n (colon <+> pprint t) --- where x = rTypeValueVar t instance ToJSON Error where toJSON e = object [ "pos" .= (errSpan e)
src/Language/Haskell/Liquid/GhcInterface.hs view
@@ -15,57 +15,40 @@ ) where import IdInfo import InstEnv-import qualified Data.Foldable as F import Bag (bagToList) import ErrUtils-import Panic import GHC hiding (Target) import DriverPhases (Phase(..)) import DriverPipeline (compileFile) 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 System.FilePath ( replaceExtension, normalise) import DynFlags-import Control.Arrow (second)-import Control.Monad (filterM, foldM, zipWithM, when, forM, forM_, liftM, (<=<))+import Control.Monad (filterM, foldM, when, forM, forM_, liftM) import Control.DeepSeq import Control.Applicative hiding (empty) import Data.Monoid hiding ((<>))-import Data.List (partition, intercalate, foldl', find, (\\), delete, nub)-import Data.Maybe (fromMaybe, catMaybes, maybeToList)+import Data.List (foldl', find, (\\), delete, nub)+import Data.Maybe (catMaybes, maybeToList) import qualified Data.HashSet as S-import qualified Data.HashMap.Strict as M-import qualified Data.Text as T-+ import System.Console.CmdArgs.Verbosity (whenLoud) import System.Directory (removeFile, createDirectory, 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@@ -75,7 +58,6 @@ 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 @@ -119,14 +101,21 @@ let useVs = readVars coreBinds let letVs = letVars coreBinds let derVs = derivedVars coreBinds $ mgi_is_dfun modguts- (spec, imps, incs) <- moduleSpec cfg coreBinds (impVs ++ defVs) letVs name' modguts tgtSpec impSpecs'+ logicmap <- liftIO makeLogicMap + (spec, imps, incs) <- moduleSpec cfg coreBinds (impVs ++ defVs) letVs name' modguts tgtSpec logicmap impSpecs' liftIO $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps hqualFiles <- moduleHquals modguts paths target imps incs return $ GI hscEnv coreBinds derVs impVs letVs useVs hqualFiles imps incs spec ++makeLogicMap + = do lg <- getCoreToLogicPath+ lspec <- readFile lg+ return $ parseSymbolToLogic lg lspec+ derivedVars :: CoreProgram -> Maybe [DFunId] -> [Id] derivedVars cbs (Just fds) = concatMap (derivedVs cbs) fds-derivedVars cbs Nothing = []+derivedVars _ Nothing = [] derivedVs :: CoreProgram -> DFunId -> [Id] derivedVs cbs fd = concatMap bindersOf cbf ++ deps@@ -140,7 +129,7 @@ dep (DFunUnfolding _ _ e) = concatMap grapDep e dep (CoreUnfolding {uf_tmpl = e}) = grapDep e- dep f = []+ dep _ = [] grapDep :: CoreExpr -> [Id] grapDep e = freeVars S.empty e@@ -198,53 +187,13 @@ -- mod_guts <- modSummaryModGuts modSummary mod_p <- parseModule modSummary mod_guts <- coreModule <$> (desugarModuleWithLoc =<< typecheckModule (ignoreInline mod_p))- let deriv = getDerivedDictionaries mod_guts mod_p+ let deriv = getDerivedDictionaries mod_guts return $! (miModGuts (Just deriv) mod_guts) Nothing -> exitWithPanic "Ghc Interface: Unable to get GhcModGuts" --getDerivedDictionaries cm mod = dFuns -- filter ((`elem` pdFuns) . shortPpr) dFuns - where hsmod = unLoc $ pm_parsed_source mod- decls = unLoc <$> hsmodDecls hsmod- tyClD = [d | TyClD d <- decls]- tyDec = filter isDataDecl tyClD- inst = mkInst <$> tyDec- mkInst x = (tcdLName x, dd_derivs $ tcdDataDefn x)- mkDic = \(x, y) -> "$f" ++ showPpr y ++ showPpr x-- pdFuns = mkDic <$> [(c, d) | (c, ds) <- inst, d <- F.concat ds]- dFuns = is_dfun <$> (instEnvElts $ mg_inst_env cm)- - shortPpr = symbolString . dropModuleNames . symbol---- 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 =<< liftM ignoreInline (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 Nothing 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"+getDerivedDictionaries cm = is_dfun <$> (instEnvElts $ mg_inst_env cm) cleanFiles :: FilePath -> IO ()--- deleteBinFilez fn = mapM_ (tryIgnore "delete binaries" . removeFileIfExists) --- $ (fn `replaceExtension`) `fmap` exts--- where --- exts = ["hi", "o"]- cleanFiles fn = do forM_ bins (tryIgnore "delete binaries" . removeFileIfExists) tryIgnore "create temp directory" $ createDirectory dir @@ -285,7 +234,7 @@ -- | Extracting Specifications (Measures + Assumptions) ------------------------ -------------------------------------------------------------------------------- -moduleSpec cfg cbs vars defVars target mg tgtSpec impSpecs+moduleSpec cfg cbs vars defVars target mg tgtSpec logicmap impSpecs = do addImports impSpecs addContext $ IIModule $ moduleName $ mgi_module mg env <- getSession@@ -294,11 +243,10 @@ | (_,spec) <- specs , x <- Ms.imports spec ]- ghcSpec <- liftIO $ makeGhcSpec cfg target cbs vars defVars exports env specs+ ghcSpec <- liftIO $ makeGhcSpec cfg target cbs vars defVars exports env logicmap specs return (ghcSpec, imps, Ms.includes tgtSpec) where exports = mgi_exports mg- name = mgi_namestring mg impNames = map (getModString.fst) impSpecs addImports = mapM (addContext . IIDecl . qualImportDecl . getModName . fst) @@ -306,12 +254,6 @@ 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" realSpecName = "Real" notRealSpecName = "NotReal"@@ -376,21 +318,6 @@ | otherwise = 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 = extFileNameR ext $ symbolString preludeName@@ -517,8 +444,6 @@ extendEnv = foldl' (flip S.insert) --- names = (map varName) . bindings--- bindings (NonRec x _) = [x] bindings (Rec xes )
src/Language/Haskell/Liquid/GhcMisc.hs view
@@ -20,64 +20,52 @@ import Avail (availsToNameSet) import CoreSyn hiding (Expr)+import qualified CoreSyn as Core import CostCentre-import FamInstEnv (FamInst) import GHC hiding (L) import HscTypes (Dependencies, ImportedMods, ModGuts(..)) import Kind (superKind) import NameSet (NameSet)-import SrcLoc (mkRealSrcLoc, mkRealSrcSpan, srcSpanFile, srcSpanFileName_maybe, srcSpanStartLine, srcSpanStartCol)+import SrcLoc (mkRealSrcLoc, mkRealSrcSpan, srcSpanFileName_maybe) import Language.Fixpoint.Names (dropModuleNames)-import Language.Fixpoint.Misc (errorstar, stripParens) import Text.Parsec.Pos (sourceName, sourceLine, sourceColumn, SourcePos, newPos)-import Language.Fixpoint.Types hiding (SESearch(..))+import Language.Fixpoint.Types hiding (Constant (..), SESearch(..)) import Name (mkInternalName, getSrcSpan, nameModule_maybe) import Module (moduleNameFS)-import OccName (mkTyVarOcc, mkTcOcc)+import OccName (mkTyVarOcc, mkTcOcc, occNameFS) 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 Panic (throwGhcException)+import HscTypes (HscEnv(..), FindResult(..)) import FastString import TcRnDriver-import OccName - import RdrName-import Type (liftedTypeKind, eqType)+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.Monoid (mempty) import Data.Hashable import qualified Data.HashSet as S import qualified Data.List as L import Data.Aeson -import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Unsafe as T 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 +import Data.Monoid (mappend)++import Language.Fixpoint.Names (symSepName, isSuffixOfSym, singletonSym)+ ----------------------------------------------------------------------- --------------- Datatype For Holding GHC ModGuts ---------------------- -----------------------------------------------------------------------@@ -116,9 +104,7 @@ tickSrcSpan :: Outputable a => Tickish a -> SrcSpan tickSrcSpan (ProfNote cc _ _) = cc_loc cc-tickSrcSpan z = noSrcSpan -- errorstar msg--- where msg = "tickSrcSpan: unhandled tick: " ++ showPpr z-+tickSrcSpan _ = noSrcSpan ----------------------------------------------------------------------- --------------- Generic Helpers for Accessing GHC Innards ------------- -----------------------------------------------------------------------@@ -313,12 +299,17 @@ go tvs (Tick _ e) = go tvs e go tvs e = (reverse tvs, e) -ignoreLetBinds e@(Let (NonRec x xe) e') +ignoreLetBinds (Let (NonRec _ _) e') = ignoreLetBinds e' ignoreLetBinds e = e -isDictionary x = L.isPrefixOf "$d" (symbolString $ dropModuleNames $ symbol x)+isDictionaryExpression :: Core.Expr Id -> Maybe Id+isDictionaryExpression (Tick _ e) = isDictionaryExpression e+isDictionaryExpression (Var x) | isDictionary x = Just x+isDictionaryExpression _ = Nothing++isDictionary x = L.isPrefixOf "$f" (symbolString $ dropModuleNames $ symbol x) isInternal x = L.isPrefixOf "$" (symbolString $ dropModuleNames $ symbol x) @@ -376,6 +367,18 @@ instance Symbolic Name where symbol = symbol . showPpr -- qualifiedNameSymbol+++instance Symbolic Var where+ symbol = varSymbol++varSymbol :: Var -> Symbol+varSymbol v + | us `isSuffixOfSym` vs = vs+ | otherwise = vs `mappend` singletonSym symSepName `mappend` us+ where us = symbol $ showPpr $ getDataConVarUnique v+ vs = symbol $ getName v+ qualifiedNameSymbol n = symbol $ case nameModule_maybe n of
+ src/Language/Haskell/Liquid/GhcPlay.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.GhcPlay where++import GHC +import CoreSyn+import Var+import TypeRep+import TcRnMonad+import Coercion++import Control.Arrow ((***))+import qualified Data.HashMap.Strict as M++import Language.Haskell.Liquid.GhcMisc ()++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+ Just (TyVarTy v) -> v + _ -> b++ 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)+substTysWith _ (LitTy t) = LitTy t
+ src/Language/Haskell/Liquid/Literals.hs view
@@ -0,0 +1,38 @@+module Language.Haskell.Liquid.Literals (+ literalFRefType, literalFReft, literalConst+ ) where ++import TypeRep+import Literal++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.CoreToLogic (mkLit)++import Language.Fixpoint.Types (exprReft)++import Data.Monoid+---------------------------------------------------------------+----------------------- Typing Literals -----------------------+---------------------------------------------------------------++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 mempty 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 +
src/Language/Haskell/Liquid/Measure.hs view
@@ -16,28 +16,24 @@ 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.List as L import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -import qualified Data.Text as T+import Data.List (foldl1')+ import Data.Monoid hiding ((<>))-import Data.List (foldl1', union, nub)-import Data.Either (partitionEithers) import Data.Bifunctor-import Data.Text (Text) import Control.Applicative ((<$>))-import Control.Exception (assert) import Language.Fixpoint.Misc import Language.Fixpoint.Types hiding (Def, R) import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.Types hiding (GhcInfo(..), GhcSpec (..)) import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.Variance -- MOVE TO TYPES type BareSpec = Spec BareType LocSymbol@@ -61,11 +57,14 @@ , lvars :: ![(LocSymbol)] -- ^ Variables that should be checked in the environment they are used , lazy :: !(S.HashSet LocSymbol) -- ^ Ignore Termination Check in these Functions , hmeas :: !(S.HashSet LocSymbol) -- ^ Binders to turn into measures using haskell definitions+ , inlines :: !(S.HashSet LocSymbol) -- ^ Binders to turn into logic inline using haskell definitions , pragmas :: ![Located String] -- ^ Command-line configurations passed in through source , cmeasures :: ![Measure ty ()] -- ^ Measures attached to a type-class , imeasures :: ![Measure ty bndr] -- ^ Mappings from (measure,type) -> measure , classes :: ![RClass ty] -- ^ Refined Type-Classes , termexprs :: ![(LocSymbol, [Expr])] -- ^ Terminating Conditions for functions + , rinstance :: ![RInstance ty] + , dvariance :: ![(LocSymbol, [Variance])] } @@ -166,11 +165,14 @@ , lvars = lvars s1 ++ lvars s2 , lazy = S.union (lazy s1) (lazy s2) , hmeas = S.union (hmeas s1) (hmeas s2)+ , inlines = S.union (inlines s1) (inlines s2) , pragmas = pragmas s1 ++ pragmas s2 , cmeasures = cmeasures s1 ++ cmeasures s2 , imeasures = imeasures s1 ++ imeasures s2 , classes = classes s1 ++ classes s1 , termexprs = termexprs s1 ++ termexprs s2+ , rinstance = rinstance s1 ++ rinstance s2+ , dvariance = dvariance s1 ++ dvariance s2 } mempty@@ -192,11 +194,14 @@ , lvars = [] , lazy = S.empty , hmeas = S.empty+ , inlines = S.empty , pragmas = [] , cmeasures = [] , imeasures = [] , classes = [] , termexprs = []+ , rinstance = []+ , dvariance = [] } -- MOVE TO TYPES@@ -238,8 +243,9 @@ , cmeasures = first f <$> (cmeasures s) , imeasures = first f <$> (imeasures s) , classes = fmap f <$> (classes s)+ , rinstance = fmap f <$> (rinstance s) }- where fmapP f (x, y) = (fmap f x, fmap f y)+ where fmapP f (x, y) = (fmap f x, fmap f y) second f s = s { measures = fmap (second f) (measures s)
src/Language/Haskell/Liquid/Misc.hs view
@@ -4,13 +4,23 @@ import Control.Applicative import System.FilePath-import qualified Data.Text as T +import qualified Data.List as L+ import Language.Fixpoint.Misc (errorstar)-import Language.Fixpoint.Types +import Data.List (sort)+ import Paths_liquidhaskell +firstDuplicate :: Ord a => [a] -> Maybe a+firstDuplicate = go . sort+ where+ go (y:x:xs) | x == y = Just x + | otherwise = go (x:xs)+ go _ = Nothing ++ safeIndex err n ls | n >= length ls = errorstar err@@ -22,7 +32,7 @@ (x:_) !? 0 = Just x (_:xs) !? n = xs !? (n-1) -safeFromJust err (Just x) = x+safeFromJust _ (Just x) = x safeFromJust err _ = errorstar err addFst3 a (b, c) = (a, b, c)@@ -48,9 +58,9 @@ 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"+getIncludeDir = dropFileName <$> (getDataFileName $ "include" </> "Prelude.spec")+getCssPath = getDataFileName $ "syntax" </> "liquid.css"+getCoreToLogicPath = getDataFileName $ "include" </> "CoreToLogic.lg" maximumWithDefault zero [] = zero@@ -74,11 +84,21 @@ pad _ f [] ys = (f <$> ys, ys) pad _ f xs [] = (xs, f <$> xs)-pad msg f xs ys+pad msg _ xs ys | nxs == nys = (xs, ys) | otherwise = errorstar $ "pad: " ++ msg where nxs = length xs nys = length ys- - ++++ordNub :: Ord a => [a] -> [a]+ordNub = map head . L.group . L.sort++intToString :: Int -> String+intToString 1 = "1st"+intToString 2 = "2nd"+intToString 3 = "3rd"+intToString n = show n ++ "th"+
src/Language/Haskell/Liquid/Parse.hs view
@@ -1,32 +1,26 @@ {-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, TupleSections, OverloadedStrings #-} module Language.Haskell.Liquid.Parse- (hsSpecificationP, lhsSpecificationP, specSpecificationP)+ ( hsSpecificationP, lhsSpecificationP, specSpecificationP+ , parseSymbolToLogic+ ) where import Control.Monad import Text.Parsec-import Text.Parsec.Error ( messageString - , errorMessages- , newErrorMessage- , errorPos- , Message (..)) +import Text.Parsec.Error (newErrorMessage, Message (..)) import Text.Parsec.Pos (newPos) import qualified Text.Parsec.Token as Token import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import Data.Interned import Control.Applicative ((<$>), (<*), (<*>))-import Data.Char (toLower, isLower, isSpace, isAlpha)+import Data.Char (isLower, isSpace, isAlpha) import Data.List (foldl', partition)-import Data.Monoid (mempty) -import GHC (mkModuleName, ModuleName)+import GHC (mkModuleName) import Text.PrettyPrint.HughesPJ (text) import Language.Preprocessor.Unlit (unlit)@@ -34,9 +28,10 @@ import Language.Fixpoint.Types hiding (Def, R) import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.Variance + import qualified Language.Haskell.Liquid.Measure as Measure import Language.Fixpoint.Names (listConName, hpropConName, propConName, tupConName, headSym) import Language.Fixpoint.Misc hiding (dcolon, dot)@@ -105,8 +100,6 @@ pos = errorPos e sp = sourcePosSrcSpan pos msg = text $ "Error Parsing Specification from: " ++ f- -- lpe = LPE pos (eMsgs e)- eMsgs = fmap messageString . errorMessages --------------------------------------------------------------------------- remParseError :: SourceName -> String -> String -> ParseError @@ -130,7 +123,26 @@ ++ ----------------------------------------------------------------------------------+-- Parse to Logic ---------------------------------------------------------------+----------------------------------------------------------------------------------++parseSymbolToLogic = parseWithError toLogicP ++toLogicP+ = toLogicMap <$> many toLogicOneP ++toLogicOneP+ = do reserved "define"+ (x:xs) <- many1 symbolP+ reserved "="+ e <- exprP + return (x, xs, e)+++---------------------------------------------------------------------------------- -- Lexer Tokens ------------------------------------------------------------------ ---------------------------------------------------------------------------------- @@ -152,6 +164,7 @@ <|> bareAllS <|> bareAllExprP <|> bareExistsP+ <|> try bareConstraintP <|> try bareFunP <|> bareAtomP (refBindP bindP) <|> try (angles (do t <- parens $ bareTypeP@@ -191,7 +204,8 @@ bbaseNoAppP :: Parser (Reft -> BareType) bbaseNoAppP- = liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP+ = holeRefP+ <|> liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP <|> try (liftM5 bCon locUpperIdP stratumP predicatesP (return []) (return mempty)) <|> liftM3 bRVar lowerIdP stratumP monoPredicateP @@ -216,6 +230,28 @@ t <- bareTypeP return $ foldr (uncurry RAllE) t zs +bareConstraintP+ = do ct <- braces constraintP+ t <- bareTypeP + return $ rrTy ct t +++constraintP+ = do xts <- constraintEnvP+ t1 <- bareTypeP+ reserved "<:"+ t2 <- bareTypeP+ return $ fromRTypeRep $ RTypeRep [] [] [] ((val . fst <$> xts) ++ [dummySymbol]) ((snd <$> xts) ++ [t1]) t2 +++constraintEnvP+ = try (do xts <- sepBy tyBindP comma+ reserved "|-"+ return xts)+ <|> return []++rrTy ct t = RRTy [(dummySymbol, ct)] mempty OCons t + bareExistsP = do reserved "exists" zs <- brackets $ sepBy1 exBindP comma @@ -276,13 +312,6 @@ ts = toRSort <$> ty_args trep err = "Predicate Variable with non-Prop output sort: " ++ showpp t --- = do t <- bareTypeP--- let trep = toRTypeRep t--- if isPropBareType $ ty_res trep--- then return $ zip (ty_binds trep) (toRSort <$> (ty_args trep)) --- else parserFail $ "Predicate Variable with non-Prop output sort: " ++ showpp t-- xyP lP sepP rP = liftM3 (\x _ y -> (x, y)) lP (spaces >> sepP) rP @@ -292,16 +321,6 @@ = (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 b@@ -346,7 +365,7 @@ <|> return [] dummyRSort- = ROth "dummy"+ = RVar "dummy" mempty refasP :: Parser [Refa] refasP = (try (brackets $ sepBy (RConc <$> predP) semi)) @@ -451,10 +470,13 @@ | LVars LocSymbol | Lazy LocSymbol | HMeas LocSymbol+ | Inline LocSymbol | Pragma (Located String) | CMeas (Measure ty ()) | IMeas (Measure ty ctor) | Class (RClass ty)+ | RInst (RInstance ty)+ | Varia (LocSymbol, [Variance]) -- | For debugging instance Show (Pspec a b) where@@ -476,15 +498,16 @@ show (Decr _) = "Decr" show (LVars _) = "LVars" show (Lazy _) = "Lazy" - show (HMeas _) = "HMeas" + show (HMeas _) = "HMeas" + show (Inline _) = "Inline" show (Pragma _) = "Pragma" show (CMeas _) = "CMeas" show (IMeas _) = "IMeas" show (Class _) = "Class" -+ show (Varia _) = "Varia"+ show (RInst _) = "RInst" --- mkSpec :: String -> [Pspec ty LocSymbol] -> Measure.Spec ty LocSymbol mkSpec name xs = (name,) $ Measure.qualifySpec (symbol name) $ Measure.Spec@@ -507,52 +530,62 @@ , Measure.lvars = [d | LVars d <- xs] , Measure.lazy = S.fromList [s | Lazy s <- xs] , Measure.hmeas = S.fromList [s | HMeas s <- xs]+ , Measure.inlines = S.fromList [s | Inline s <- xs] , Measure.pragmas = [s | Pragma s <- xs] , Measure.cmeasures = [m | CMeas m <- xs] , Measure.imeasures = [m | IMeas m <- xs] , Measure.classes = [c | Class c <- xs]+ , Measure.dvariance = [v | Varia v <- xs]+ , Measure.rinstance = [i | RInst i <- xs] , Measure.termexprs = [(y, es) | Asrts (ys, (_, Just es)) <- xs, y <- ys] } specP :: Parser (Pspec BareType LocSymbol) specP - = try (reserved "assume" >> liftM Assm tyBindP )- <|> (reserved "assert" >> liftM Asrt tyBindP )- <|> (reserved "Local" >> liftM LAsrt tyBindP )- <|> try (reserved "measure" >> liftM Meas measureP ) - <|> (reserved "measure" >> liftM HMeas hmeasureP ) - <|> try (reserved "class" >> reserved "measure" >> liftM CMeas cMeasureP)- <|> (reserved "instance" >> reserved "measure" >> liftM IMeas iMeasureP)- <|> (reserved "class" >> liftM Class classP )- <|> (reserved "import" >> liftM Impt symbolP )- <|> (reserved "data" >> liftM DDecl dataDeclP )- <|> (reserved "include" >> liftM Incl filePathP )- <|> (reserved "invariant" >> liftM Invt invariantP)- <|> (reserved "using" >> liftM IAlias invaliasP )- <|> (reserved "type" >> liftM Alias aliasP )- <|> (reserved "predicate" >> liftM PAlias paliasP )- <|> (reserved "expression">> liftM EAlias ealiasP )- <|> (reserved "embed" >> liftM Embed embedP )- <|> (reserved "qualif" >> liftM Qualif qualifierP)- <|> (reserved "Decrease" >> liftM Decr decreaseP )- <|> (reserved "LAZYVAR" >> liftM LVars lazyVarP )- <|> (reserved "Strict" >> liftM Lazy lazyVarP )- <|> (reserved "Lazy" >> liftM Lazy lazyVarP )- <|> (reserved "LIQUID" >> liftM Pragma pragmaP )+ = try (reservedToken "assume" >> liftM Assm tyBindP )+ <|> (reservedToken "assert" >> liftM Asrt tyBindP )+ <|> (reservedToken "Local" >> liftM LAsrt tyBindP )+ <|> try (reservedToken "measure" >> liftM Meas measureP ) + <|> (reservedToken "measure" >> liftM HMeas hmeasureP ) + <|> (reservedToken "inline" >> liftM Inline inlineP ) + <|> try (reservedToken "class" >> reserved "measure" >> liftM CMeas cMeasureP)+ <|> try (reservedToken "instance" >> reserved "measure" >> liftM IMeas iMeasureP)+ <|> (reservedToken "instance" >> liftM RInst instanceP )+ <|> (reservedToken "class" >> liftM Class classP )+ <|> (reservedToken "import" >> liftM Impt symbolP )+ <|> try (reservedToken "data" >> reserved "variance " >> liftM Varia datavarianceP)+ <|> (reservedToken "data" >> liftM DDecl dataDeclP )+ <|> (reservedToken "include" >> liftM Incl filePathP )+ <|> (reservedToken "invariant" >> liftM Invt invariantP)+ <|> (reservedToken "using" >> liftM IAlias invaliasP )+ <|> (reservedToken "type" >> liftM Alias aliasP )+ <|> (reservedToken "predicate" >> liftM PAlias paliasP )+ <|> (reservedToken "expression">> liftM EAlias ealiasP )+ <|> (reservedToken "embed" >> liftM Embed embedP )+ <|> (reservedToken "qualif" >> liftM Qualif qualifierP)+ <|> (reservedToken "Decrease" >> liftM Decr decreaseP )+ <|> (reservedToken "LAZYVAR" >> liftM LVars lazyVarP )+ <|> (reservedToken "Strict" >> liftM Lazy lazyVarP )+ <|> (reservedToken "Lazy" >> liftM Lazy lazyVarP )+ <|> (reservedToken "LIQUID" >> liftM Pragma pragmaP ) <|> ({- DEFAULT -} liftM Asrts tyBindsP ) +reservedToken str = try(string str >> spaces1) ++spaces1 = satisfy isSpace >> spaces+ pragmaP :: Parser (Located String) pragmaP = locParserP stringLiteral -lazyP :: Parser Symbol-lazyP = binderP- lazyVarP :: Parser LocSymbol lazyVarP = locParserP binderP hmeasureP :: Parser LocSymbol hmeasureP = locParserP binderP +inlineP :: Parser LocSymbol+inlineP = locParserP binderP+ decreaseP :: Parser (LocSymbol, [Int]) decreaseP = mapSnd f <$> liftM2 (,) (locParserP binderP) (spaces >> (many integer)) where f = ((\n -> fromInteger n - 1) <$>)@@ -563,6 +596,14 @@ pathCharP = choice $ char <$> pathChars pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/'] +datavarianceP = liftM2 (,) (locUpperIdP) (spaces >> many varianceP)+ +varianceP = (reserved "bivariant" >> return Bivariant)+ <|> (reserved "invariant" >> return Invariant)+ <|> (reserved "covariant" >> return Covariant)+ <|> (reserved "contravariant" >> return Contravariant)+ <?> "Invalib variance annotation\t Use one of bivariant, invariant, covariant, contravariant"+ tyBindsP :: Parser ([LocSymbol], (BareType, Maybe [Expr])) tyBindsP = xyP (sepBy (locParserP binderP) comma) dcolon termBareTypeP @@ -628,6 +669,17 @@ iMeasureP :: Parser (Measure BareType LocSymbol) iMeasureP = measureP +instanceP + = do c <- locUpperIdP+ t <- locUpperIdP+ as <- classParams + ts <- sepBy tyBindP semi+ return $ RI c (RApp t ((`RVar` mempty) <$> as) [] mempty) ts+ where + classParams+ = (reserved "where" >> return [])+ <|> (liftM2 (:) lowerIdP classParams)+ classP :: Parser (RClass BareType) classP = do sups <- superP@@ -700,7 +752,7 @@ mkTupPat zs = (tupDataCon (length zs), zs) mkNilPat _ = (dummyLoc "[]", [] )-mkConsPat x c y = (dummyLoc ":" , [x, y])+mkConsPat x _ y = (dummyLoc ":" , [x, y]) tupDataCon n = dummyLoc $ symbol $ "(" <> replicate (n - 1) ',' <> ")" @@ -786,89 +838,3 @@ instance Inputable (Measure BareType LocSymbol) 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 BareType Symbol -me1 = (rr $ intercalate "\n" m1) -me2 = (rr $ intercalate "\n" m2)--}
src/Language/Haskell/Liquid/PredType.hs view
@@ -5,15 +5,11 @@ , dataConTy , dataConPSpecType , makeTyConInfo- , unify , replacePreds , replacePredsWithRefs , pVartoRConc - -- * Compute `Type` of GHC `CoreExpr`- , exprType- -- * Dummy `Type` that represents _all_ abstract-predicates , predType @@ -25,25 +21,15 @@ , 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, mappend)-import qualified Data.Text as T import Language.Fixpoint.Misc import Language.Fixpoint.Types hiding (Predicate, Expr)@@ -53,18 +39,15 @@ import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.Misc -import Control.Applicative ((<$>), (<*>))-import Control.Monad.State+import Control.Applicative ((<$>)) import Data.List (nub) import Data.Default -import Debug.Trace (trace)- makeTyConInfo = hashMapMapWithKey mkRTyCon . M.fromList mkRTyCon :: TC.TyCon -> TyConP -> RTyCon-mkRTyCon tc (TyConP αs' ps ls cv conv size) = RTyCon tc pvs' (mkTyConInfo tc cv conv size)+mkRTyCon tc (TyConP αs' ps _ tyvariance predvariance size) = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size) where τs = [rVar α :: RSort | α <- TC.tyConTyVars tc] pvs' = subts (zip αs' τs) <$> ps @@ -77,6 +60,7 @@ tx _ [] [] [] = [] tx su (x:xs) (y:ys) (t:ts) = (y, subst (F.mkSubst su) t) : tx ((x, F.EVar y):su) xs ys ts+ tx _ _ _ _ = errorstar "PredType.dataConPSpecType.tx called on invalid inputs" yts' = tx [] xs ys ts ts' = map ("" ,) cs ++ yts' su = F.mkSubst [(x, F.EVar y) | (x, y) <- zip xs ys]@@ -113,100 +97,6 @@ = rApp c (dataConTy m <$> ts) [] mempty dataConTy _ _ = error "ofTypePAppTy"-------------------------------------------------------------------------------- | 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 (RAllS s t) pt- = do t' <- unifyS t pt - return $ RAllS s t'--unifyS t (RAllS s pt) - = do t' <- unifyS t pt - return $ RAllS s t'--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 r) (RAppTy pt1 pt2 p)- = do t1' <- unifyS rt1 pt1- t2' <- unifyS rt2 pt2- return $ RAppTy t1' t2' (bUnify r p)--unifyS (RVar v a) (RVar _ p)- = do modify $ \s -> s `S.union` (S.fromList $ pvars 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 (p:fps) - fps = getR <$> ps- getR (RPropP _ r) = r- getR (RProp _ _ ) = mempty --unifyS (RAllE x tx t) (RAllE x' tx' t') | x == x'- = RAllE x <$> unifyS tx tx' <*> unifyS t t'--unifyS (REx x tx t) (REx x' tx' t') | x == x'- = REx x <$> unifyS tx tx' <*> unifyS t t'- -unifyS t (REx x' tx' t')- = REx x' ((\p -> U mempty p mempty) <$> tx') <$> unifyS t t'- -unifyS t@(RVar v a) (RAllE x' tx' t')- = RAllE x' ((\p -> U mempty p mempty)<$> tx') <$> (unifyS t t')--unifyS t1 t2 - = error ("unifyS" ++ show t1 ++ " with " ++ show t2)---- pToReft p = Reft (vv, [RPvar p]) -pToReft = (\p -> U mempty p mempty) . pdVar --bUnify r (Pr pvs) = foldl' meet r $ pToReft <$> pvs- --- ORIG unifyRef (RPropP s r) p = RPropP s $ bUnify r p -- (foldl' meet r $ pToReft <$> pvs)--- ORIG unifyRef (RProp s t) (Pr pvs) = RProp s $ foldl' strengthen t $ pToReft <$> pvs---- ORIG zipWithZero f xz yz = go--- ORIG where--- ORIG go [] ys = (xz `f`) <$> ys--- ORIG go xs [] = (`f` yz) <$> xs--- ORIG go (x:xs) (y:ys) = f x y : go xs ys- --- ORIG zipWithZero _ _ _ [] [] = []--- ORIG zipWithZero f xz yz [] (y:ys) = f xz y : zipWithZero f xz yz [] ys--- ORIG zipWithZero f xz yz (x:xs) [] = f x yz : zipWithZero f xz yz xs []--- ORIG zipWithZero f xz yz (x:xs) (y:ys) = f x y : zipWithZero f xz yz xs ys ---------------------------------------------------------------------------- ----- Interface: Replace Predicate With Uninterprented Function Symbol -----@@ -216,8 +106,6 @@ = U (Reft (v, rs ++ rs')) (Pr ps2) s 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) | length args == length (pargs p) = RConc $ pApp (pname p) $ EVar v:(thd3 <$> args)@@ -333,7 +221,7 @@ substRCon msg su t _ _ = errorstar $ msg ++ " substRCon " ++ showpp (su, t) -substPredP msg su@(p, RProp ss tt) (RProp s t) +substPredP msg su@(p, RProp ss _) (RProp s t) = RProp ss' $ substPred (msg ++ ": substPredP") su t where ss' = drop n ss ++ s@@ -342,44 +230,25 @@ substPredP _ _ (RHProp _ _) = errorstar "TODO:EFFECTS:substPredP" -substPredP _ _ (RPropP _ _) - = error $ "RPropP found in substPredP"-+substPredP _ su p@(RPropP _ _) + = errorstar ("PredType.substPredP1 called on invalid inputs" ++ showpp (su, p)) +substPredP _ su p + = errorstar ("PredType.substPredP called on invalid inputs" ++ showpp (su, p)) splitRPvar pv (U x (Pr pvs) s) = (U x (Pr pvs') s, 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 (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- freeArgsPs p (RVar _ r) = freeArgsPsRef p r freeArgsPs p (RFun _ t1 t2 r) = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs p (RAllT _ t) = freeArgsPs p t +freeArgsPs p (RAllS _ t)+ = freeArgsPs p t freeArgsPs p (RAllP p' t) | p == p' = [] | otherwise = freeArgsPs p t @@ -387,12 +256,16 @@ = nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts freeArgsPs p (RAllE _ t1 t2) = nub $ freeArgsPs p t1 ++ freeArgsPs p t2 +freeArgsPs p (REx _ t1 t2) + = nub $ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs p (RAppTy t1 t2 r) = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs _ (RExprArg _) = []-freeArgsPs _ (ROth _)- = []+freeArgsPs p (RHole r)+ = freeArgsPsRef p r+freeArgsPs p (RRTy env r _ t)+ = nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t freeArgsPsRef p (U _ (Pr ps) _) = [x | (_, x, w) <- (concatMap pargs ps'), (EVar x) == w] where @@ -420,7 +293,8 @@ | otherwise = errorstar $ "PredType.meetListWithPSubRef partial application to " ++ showpp π where su = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]-+meetListWithPSubRef _ _ _ _+ = errorstar "PredType.meetListWithPSubRef called with invalid input" ---------------------------------------------------------------------------- -- | Interface: Modified CoreSyn.exprType due to predApp -------------------@@ -434,63 +308,7 @@ symbolType = TyVarTy . symbolTyVar ------------------------------------------------------------------------------exprType :: CoreExpr -> Type------------------------------------------------------------------------------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 (App e1 (Var v))- | isPredType v = exprType e1-exprType e@(App _ _)- | (f, es) <- collectArgs e = applyTypeToArgs e (exprType f) es -exprType _ = error "PredType : exprType" --- | @collectArgs@ 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- | isPredType v = go f as- go (App f a) as = go f (a:as)- go e as = (e, as)--isPredType v = eqType (idType v) predType---- | 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 where@@ -503,8 +321,6 @@ pappArity = 7 --- pappSym n = S $ "papp" ++ show n- pappSort n = FFunc (2 * n) $ [ptycon] ++ args ++ [bSort] where ptycon = fApp (Left predFTyCon) $ FVar <$> [0..n-1] args = FVar <$> [n..(2*n-1)]@@ -513,7 +329,3 @@ wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]] predFTyCon = symbolFTycon $ dummyLoc predName---- pApp :: Symbol -> [F.Expr] -> Pred--- pApp p es= PBexp $ EApp (dummyLoc $ pappSym $ length es) (EVar p:es)-
src/Language/Haskell/Liquid/PrettyPrint.hs view
@@ -21,9 +21,9 @@ -- * Printing a List with many large items , pprintLongList , ppSpine+ , pprintSymbol ) where -import Type (tidyType) import ErrUtils (ErrMsg) import HscTypes (SourceError) import SrcLoc -- (RealSrcSpan, SrcSpan (..))@@ -37,19 +37,20 @@ import Language.Haskell.Liquid.Types hiding (sort) import Language.Fixpoint.Names (dropModuleNames, propConName, hpropConName) import TypeRep hiding (maybeParen, pprArrowChain) -import Text.Parsec.Pos (SourcePos, newPos, sourceName, sourceLine, sourceColumn) import Text.Parsec.Error (ParseError, errorMessages, showErrorMessages) import Var (Var)-import Control.Applicative ((<*>), (<$>))+import Control.Applicative ((<$>)) import Data.Maybe (fromMaybe) import Data.List (sort, sortBy) import Data.Function (on) import Data.Monoid (mempty)-import Data.Aeson -import qualified Data.Text as T-import Data.Interned import qualified Data.HashMap.Strict as M +++pprintSymbol :: Symbol -> Doc+pprintSymbol x = char '‘' <> pprint x <> char '’'+ instance PPrint SrcSpan where pprint = pprDoc @@ -108,7 +109,11 @@ ppE Lossy = ppEnvShort ppEnv ppE Full = ppEnv +ppTyConB bb + | ppShort bb = text . symbolString . dropModuleNames . symbol . render . ppTycon+ | otherwise = ppTycon + ppr_rtype bb p t@(RAllT _ _) = ppr_forall bb p t ppr_rtype bb p t@(RAllP _ _) @@ -125,8 +130,6 @@ ppr_rtype bb p (RApp c ts rs r) | isTuple c = ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb rs-- ppr_rtype bb p (RApp c ts rs r) | isEmpty rsDoc && isEmpty tsDoc = ppTy r $ ppT c@@ -135,10 +138,8 @@ where rsDoc = ppReftPs bb rs tsDoc = hsep (ppr_rtype bb p <$> ts)- ppT | ppShort bb = text . symbolString . dropModuleNames . symbol . render . ppTycon- | otherwise = ppTycon--+ ppT = ppTyConB bb+ ppr_rtype bb p t@(REx _ _ _) = ppExists bb p t ppr_rtype bb p t@(RAllE _ _ _)@@ -147,8 +148,8 @@ = 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 $ "???-" ++ symbolString s+ppr_rtype bb p (RRTy [(_, e)] _ OCons t) + = sep [braces (ppr_rsubtype bb p e) <+> "=>", ppr_rtype bb p t] ppr_rtype bb p (RRTy e r o t) = sep [ppp (pprint o <+> ppe <+> pprint r), ppr_rtype bb p t] where ppe = (hsep $ punctuate comma (pprint <$> e)) <+> colon <> colon@@ -156,17 +157,27 @@ ppr_rtype _ _ (RHole r) = ppTy r $ text "_" ++ppr_rsubtype bb p e = pprint_env <+> text "|-" <+> ppr_rtype bb p tl <+> "<:" <+> ppr_rtype bb p tr+ where+ trep = toRTypeRep e+ tr = ty_res trep+ tl = last $ ty_args trep+ env = zip (init $ ty_binds trep) (init $ ty_args trep)+ pprint_bind (x, t) = pprint x <+> colon <> colon <+> ppr_rtype bb p t + pprint_env = hsep $ punctuate comma (pprint_bind <$> env)+ ppSpine (RAllT _ t) = text "RAllT" <+> parens (ppSpine t) ppSpine (RAllP _ t) = text "RAllP" <+> parens (ppSpine t)+ppSpine (RAllS _ t) = text "RAllS" <+> parens (ppSpine t) ppSpine (RAllE _ _ t) = text "RAllE" <+> parens (ppSpine t) ppSpine (REx _ _ t) = text "REx" <+> parens (ppSpine t) ppSpine (RFun _ i o _) = ppSpine i <+> text "->" <+> ppSpine o ppSpine (RAppTy t t' _) = text "RAppTy" <+> parens (ppSpine t) <+> parens (ppSpine t')-ppSpine (RHole r) = text "RHole"-ppSpine (RApp c ts rs _) = text "RApp" <+> parens (pprint c)-ppSpine (RVar v _) = text "RVar"+ppSpine (RHole _) = text "RHole"+ppSpine (RApp c _ _ _) = text "RApp" <+> parens (pprint c)+ppSpine (RVar _ _) = text "RVar" ppSpine (RExprArg _) = text "RExprArg"-ppSpine (ROth s) = text "ROth" <+> text (symbolString s) ppSpine (RRTy _ _ _ _) = text "RRTy" -- | From GHC: TypeRep @@ -197,7 +208,7 @@ split zs (RAllE x t t') = split ((x,t):zs) t' split zs t = (reverse zs, t) -ppReftPs bb rs +ppReftPs _ rs | all isTauto rs = empty | not (ppPs ppEnv) = empty | otherwise = angleBrackets $ hsep $ punctuate comma $ pprint <$> rs@@ -251,7 +262,7 @@ dargs = [pprv t | (t,_,_) <- xts] ppr_pvar_kind pprv (PVProp t) = pprv t <+> arrow <+> ppr_name propConName -ppr_pvar_kind pprv (PVHProp) = ppr_name hpropConName +ppr_pvar_kind _ (PVHProp) = ppr_name hpropConName ppr_name = text . symbolString instance PPrint RTyVar where@@ -262,10 +273,12 @@ ppr_tyvar = text . tvId ppr_tyvar_short = text . showPpr -instance (Reftable s, PPrint s, PPrint p, Reftable p, PPrint t, PPrint (RType a b c p)) => PPrint (Ref t s (RType a b c p)) where+instance (Reftable s, PPrint s, PPrint p, Reftable p, PPrint t, PPrint (RType b c p)) => PPrint (Ref t s (RType b c p)) where pprint (RPropP ss s) = ppRefArgs (fst <$> ss) <+> pprint s- pprint (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))+ pprint (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))+ pprint (RHProp ss _) = ppRefArgs (fst <$> ss) <+> text "world" + ppRefArgs [] = empty ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [vv Nothing]) <+> text "->" @@ -273,7 +286,7 @@ ppRefSym s = pprint s instance (PPrint r, Reftable r) => PPrint (UReft r) where- pprint (U r p s)+ pprint (U r p _) | isTauto r = pprint p | isTauto p = pprint r | otherwise = pprint p <> text " & " <> pprint r
src/Language/Haskell/Liquid/Qualifier.hs view
@@ -4,12 +4,8 @@ specificationQualifiers ) where -import IdInfo (IdDetails(..))-import Var (idDetails)- import Language.Haskell.Liquid.Bare import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.GhcInterface import Language.Haskell.Liquid.GhcMisc (getSourcePos) import Language.Haskell.Liquid.PredType import Language.Haskell.Liquid.Types@@ -20,7 +16,6 @@ import Data.List (delete, nub) import Data.Maybe (fromMaybe) import qualified Data.HashSet as S-import qualified Data.Text as T import Data.Bifunctor (second) -----------------------------------------------------------------------------------@@ -34,12 +29,6 @@ , q <- refTypeQuals (getSourcePos x) (tcEmbeds $ spec info) (val t) , length (q_params q) <= k + 1 ]- where- isClassOp (idDetails -> ClassOpId _) = True- isClassOp _ = False- isDataCon (idDetails -> DataConWorkId _) = True- isDataCon (idDetails -> DataConWrapId _) = True- isDataCon _ = False -- GRAVEYARD: scraping quals from imports kills the system with too much crap@@ -92,7 +81,7 @@ go γ t@(RVar _ _) = refTopQuals l tce t0 γ t go γ (RAllT _ t) = go γ t go γ (RAllP _ t) = go γ t - go γ t@(RAppTy t1 t2 r) = go γ t1 ++ go γ t2 ++ refTopQuals l tce t0 γ t+ go γ t@(RAppTy t1 t2 _) = go γ t1 ++ go γ t2 ++ refTopQuals l tce t0 γ t go γ (RFun x t t' _) = (go γ t) ++ (go (insertSEnv x (rTypeSort tce t) γ) t') go γ t@(RApp c ts rs _) = (refTopQuals l tce t0 γ t) @@ -104,8 +93,9 @@ ++ (go (insertSEnv x (rTypeSort tce t) γ) t') go _ _ = [] goRefs c g rs = concat $ zipWith (goRef g) rs (rTyConPVs c)- goRef g (RProp s t) _ = go (insertsSEnv g s) t+ goRef g (RProp s t) _ = go (insertsSEnv g s) t goRef _ (RPropP _ _) _ = []+ goRef _ (RHProp _ _) _ = errorstar "TODO: EFFECTS" insertsSEnv = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ) refTopQuals l tce t0 γ t
src/Language/Haskell/Liquid/RefType.hs view
@@ -36,6 +36,7 @@ -- TODO: categorize these! , ofType, toType , rTyVar, rVar, rApp, rEx + , symbolRTyVar , addTyConInfo -- , expandRApp , appRTyCon@@ -45,7 +46,6 @@ , subts, subvPredicate, subvUReft , subsTyVar_meet, subsTyVars_meet, subsTyVar_nomeet, subsTyVars_nomeet , dataConSymbol, dataConMsReft, dataConReft - , literalFRefType, literalFReft, literalConst , classBinds -- * Manipulating Refinements in RTypes @@ -60,51 +60,43 @@ import WwLib import FamInstEnv (emptyFamInstEnv) import Var-import Literal import GHC hiding (Located) import DataCon import qualified TyCon as TC import TypeRep hiding (maybeParen, pprArrowChain) -import Type (mkClassPred, splitFunTys, expandTypeSynonyms, isPredTy, substTyWith, classifyPredType, PredTree(..), isClassPred)+import Type (splitFunTys, expandTypeSynonyms, substTyWith, isClassPred) import TysWiredIn (listTyCon, intDataCon, trueDataCon, falseDataCon, intTyCon, charTyCon) -import qualified Data.Text as T-import Data.Interned import Data.Monoid hiding ((<>)) import Data.Maybe (fromMaybe, isJust) import Data.Hashable-import Data.Aeson 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, void)-import Control.Exception (Exception (..)) -import qualified Data.Foldable as Fold+import Control.Monad (void) import Text.Printf import Text.PrettyPrint.HughesPJ-import Text.Parsec.Pos (SourcePos) import Language.Haskell.Liquid.PrettyPrint import qualified Language.Fixpoint.Types as F import Language.Fixpoint.Types hiding (shiftVV, Predicate) import Language.Haskell.Liquid.Types hiding (R, DataConP (..), sort)-import Language.Haskell.Liquid.World -import Language.Haskell.Liquid.CoreToLogic (mkLit)+import Language.Haskell.Liquid.Variance import Language.Haskell.Liquid.Misc 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)-import Data.List (sort, isSuffixOf, foldl')+import Language.Haskell.Liquid.GhcMisc (typeUniqueString, tvId, showPpr, stringTyVar)+import Language.Fixpoint.Names (listConName, tupConName)+import Data.List (sort, foldl') + pdVar v = Pr [uPVar v] -findPVar :: [PVar (RType p c tv ())] -> UsedPVar -> PVar (RType p c tv ())+findPVar :: [PVar (RType c tv ())] -> UsedPVar -> PVar (RType c tv ()) findPVar ps p = PV name ty v (zipWith (\(_, _, e) (t, s, _) -> (t, s, e)) (pargs p) args) where PV name ty v args = fromMaybe (msg p) $ L.find ((== pname p) . pname) ps @@ -112,13 +104,13 @@ -- | Various functions for converting vanilla `Reft` to `Spec` -uRType :: RType p c tv a -> RType p c tv (UReft a)+uRType :: RType c tv a -> RType c tv (UReft a) uRType = fmap uTop -uRType' :: RType p c tv (UReft a) -> RType p c tv a +uRType' :: RType c tv (UReft a) -> RType c tv a uRType' = fmap ur_reft -uRTypeGen :: Reftable b => RType p c tv a -> RType p c tv b+uRTypeGen :: Reftable b => RType c tv a -> RType c tv b uRTypeGen = fmap $ const mempty uPVar :: PVar t -> UsedPVar@@ -137,27 +129,27 @@ -- 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)+instance ( SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) c+ , RefTypable c tv ()+ , RefTypable c tv r + , PPrint (RType c tv r) )- => Monoid (RType p c tv r) where+ => Monoid (RType c tv r) where mempty = errorstar "mempty: RType" mappend = strengthenRefType -- MOVE TO TYPES-instance ( SubsTy tv (RType p c tv ()) (RType p c tv ())- , SubsTy tv (RType p c tv ()) c+instance ( SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType 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+ , RefTypable c tv ()+ , RefTypable c tv (UReft r)) + => Monoid (Ref (RType c tv ()) r (RType c tv (UReft r))) where mempty = errorstar "mempty: RType 2" mappend _ _ = errorstar "mappend: RType 2" -instance ( Monoid r, Reftable r, RefTypable a b c r, RefTypable a b c ()) => Monoid (RTProp a b c r) where+instance ( Monoid r, Reftable r, RefTypable b c r, RefTypable b c ()) => Monoid (RTProp b c r) where mempty = errorstar "mempty: RTProp" mappend (RPropP s1 r1) (RPropP s2 r2) @@ -170,15 +162,21 @@ | isTrivial t2 = RProp s1 t1 | otherwise = RProp (s1 ++ s2) $ t1 `strengthenRefType` t2 -instance (Reftable r, RefTypable p c tv r, RefTypable p c tv ()) => Reftable (RTProp p c tv r) where+ mappend _ _ = errorstar "Reftable.mappend on invalid inputs"++instance (Reftable r, RefTypable c tv r, RefTypable c tv ()) => Reftable (RTProp c tv r) where isTauto (RPropP _ r) = isTauto r- isTauto (RProp _ t) = isTrivial t+ isTauto (RProp _ t) = isTrivial t+ isTauto (RHProp _ _) = errorstar "RefType: Reftable isTauto in RHProp" top (RProp xs t) = RProp xs $ mapReft top t + top _ = errorstar "RefType: Reftable top" ppTy (RPropP _ r) d = ppTy r d- ppTy (RProp _ _) _ = errorstar "RefType: Reftable ppTy in RProp"+ ppTy (RProp _ _) _ = errorstar "RefType: Reftable ppTy in RProp"+ ppTy (RHProp _ _) _ = errorstar "RefType: Reftable ppTy in RProp" toReft = errorstar "RefType: Reftable toReft" params = errorstar "RefType: Reftable params for Ref" bot = errorstar "RefType: Reftable bot for Ref"+ ofReft = errorstar "RefType: Reftable ofReft for Ref" ----------------------------------------------------------------------------@@ -195,21 +193,23 @@ subst _ _ = error "TODO:EFFECTS" substf f (RPropP ss r) = RPropP (mapSnd (substf f) <$> ss) $ substf f r- substf f (RProp ss r) = RProp (mapSnd (substf f) <$> ss) $ substf f r+ substf f (RProp ss r) = RProp (mapSnd (substf f) <$> ss) $ substf f r+ substf _ _ = error "TODO:EFFECTS" substa f (RPropP ss r) = RPropP (mapSnd (substa f) <$> ss) $ substa f r- substa f (RProp ss r) = RProp (mapSnd (substa f) <$> ss) $ substa f r- substa f _ = error "TODO:EFFECTS"+ substa f (RProp ss r) = RProp (mapSnd (substa f) <$> ss) $ substa f r+ substa _ _ = error "TODO:EFFECTS" ------------------------------------------------------------------------------- -- | Reftable Instances ------------------------------------------------------- ------------------------------------------------------------------------------- -instance (PPrint r, Reftable r) => Reftable (RType Class RTyCon RTyVar r) where+instance (PPrint r, Reftable r) => Reftable (RType RTyCon RTyVar r) where isTauto = isTrivial ppTy = errorstar "ppTy RProp Reftable" toReft = errorstar "toReft on RType" params = errorstar "params on RType" bot = errorstar "bot on RType"+ ofReft = errorstar "ofReft on RType" @@ -226,13 +226,13 @@ toFix = text . showPpr -- MOVE TO TYPES-instance (Eq p, PPrint p, TyConable c, Reftable r, PPrint r, PPrint c) => RefTypable p c Symbol r where- ppCls = ppClassSymbol+instance (TyConable c, Reftable r, PPrint r, PPrint c) => RefTypable c Symbol r where+-- ppCls = ppClassSymbol ppRType = ppr_rtype ppEnv -- MOVE TO TYPES-instance (Reftable r, PPrint r) => RefTypable Class RTyCon RTyVar r where- ppCls = ppClassClassPred+instance (Reftable r, PPrint r) => RefTypable RTyCon RTyVar r where+-- ppCls = ppClassClassPred ppRType = ppr_rtype ppEnv -- MOVE TO TYPES@@ -247,13 +247,11 @@ instance FreeVar LocSymbol Symbol where freeVars _ = [] -ppClassSymbol c _ = pprint c <+> text "..."-ppClassClassPred c ts = sDocDoc $ pprClassPred c (toType <$> ts) -- Eq Instances ------------------------------------------------------ -- MOVE TO TYPES-instance (RefTypable p c tv ()) => Eq (RType p c tv ()) where+instance (RefTypable c tv ()) => Eq (RType c tv ()) where (==) = eqRSort M.empty eqRSort m (RAllP _ t) (RAllP _ t') @@ -271,7 +269,7 @@ = 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 t1@(RApp c ts _ _) t2@(RApp c' ts' _ _)+eqRSort m (RApp c ts _ _) (RApp c' ts' _ _) = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts') eqRSort m (RVar a _) (RVar a' _) = a == M.lookupDefault a' a' m @@ -317,6 +315,8 @@ rVar = (`RVar` mempty) . RTV rTyVar = RTV +symbolRTyVar = rTyVar . stringTyVar . symbolString+ normalizePds t = addPds ps t' where (t', ps) = nlzP [] t @@ -324,7 +324,7 @@ rEx xts t = foldr (\(x, tx) t -> REx x tx t) t xts rApp c = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing)) -+--- NV TODO : remove this code!!! addPds ps (RAllT v t) = RAllT v $ addPds ps t addPds ps t = foldl' (flip rPred) t ps@@ -349,8 +349,6 @@ 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@(RRTy _ _ _ t') @@ -377,24 +375,8 @@ 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 mempty 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_ :: RefTypable c tv r => RType c tv r -> RType c tv r -> RType c tv r strengthenRefType_ (RAllT a1 t1) (RAllT _ t2) = RAllT a1 $ strengthenRefType_ t1 t2 @@ -420,13 +402,11 @@ 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+ rs = meets rs1 rs2 strengthenRefType_ (RVar v1 r1) (RVar _ r2)- = RVar v1 ({- tracePpr msg $ -} r1 `meet` r2)- where msg = "strengthenRefType_: RVAR r1 = " ++ showpp r1 ++ " r2 = " ++ showpp r2+ = RVar v1 (r1 `meet` r2) strengthenRefType_ t1 _ = t1@@ -438,7 +418,7 @@ | otherwise = errorstar "meets: unbalanced rs" -strengthen :: Reftable r => RType p c tv r -> r -> RType p c tv r+strengthen :: Reftable r => RType c tv r -> r -> RType c tv r strengthen (RApp c ts rs r) r' = RApp c ts rs (r `meet` r') strengthen (RVar a r) r' = RVar a (r `meet` r') strengthen (RFun b t1 t2 r) r' = RFun b t1 t2 (r `meet` r')@@ -466,10 +446,18 @@ expandRApp tce tyi t@(RApp {}) = RApp rc' ts rs' r where RApp rc ts rs r = t- rc' = appRTyCon tce tyi rc ts+ rc' = appRTyCon tce tyi rc as pvs = rTyConPVs rc' rs' = applyNonNull rs0 (rtPropPV rc pvs) rs rs0 = rtPropTop <$> pvs+ n = length fVs+ fVs = tyConTyVars $ rtc_tc rc+ as = choosen n ts (rVar <$> fVs)+ + choosen 0 _ _ = []+ choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys+ choosen i [] (y:ys) = y:choosen (i-1) [] ys+ choosen _ _ _ = errorstar "choosen: this cannot happen" expandRApp _ _ t = t @@ -519,7 +507,7 @@ = c {rtc_info = (rtc_info c) {sizeFunction = Just EVar} } -generalize :: (RefTypable c p tv r) => RType c p tv r -> RType c p tv r+generalize :: (RefTypable c tv r) => RType c tv r -> RType c tv r generalize t = mkUnivs (freeTyVars t) [] [] t freeTyVars (RAllP _ t) = freeTyVars t@@ -532,13 +520,13 @@ freeTyVars (REx _ _ t) = freeTyVars t freeTyVars (RExprArg _) = [] freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t'-freeTyVars (RHole r) = []-freeTyVars t = errorstar ("RefType.freeTyVars cannot handle" ++ show t)+freeTyVars (RHole _) = []+freeTyVars (RRTy e _ _ t) = L.nub $ concatMap freeTyVars (t:(snd <$> e)) tyClasses (RAllP _ t) = tyClasses t tyClasses (RAllS _ t) = tyClasses t-tyClasses (RAllT α 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'@@ -548,9 +536,9 @@ = [(cl, ts)] | otherwise = []-tyClasses (RVar α _) = [] +tyClasses (RVar _ _) = [] tyClasses (RRTy _ _ _ t) = tyClasses t-tyClasses (RHole r) = []+tyClasses (RHole _) = [] tyClasses t = errorstar ("RefType.tyClasses cannot handle" ++ show t) @@ -560,9 +548,10 @@ instance (NFData a, NFData b, NFData t) => NFData (Ref t a b) where rnf (RPropP s a) = rnf s `seq` rnf a- rnf (RProp s b) = rnf s `seq` rnf b+ rnf (RProp s b) = rnf s `seq` rnf b+ rnf (RHProp _ _) = errorstar "TODO RHProp.rnf" -instance (NFData a, NFData b, NFData c, NFData e) => NFData (RType a b c e) where+instance (NFData b, NFData c, NFData e) => NFData (RType 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@@ -571,10 +560,9 @@ rnf (RApp _ ts rs r) = rnf ts `seq` rnf rs `seq` rnf r 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- rnf (RRTy _ r o t) = rnf r `seq` rnf t+ rnf (RRTy _ r _ t) = rnf r `seq` rnf t rnf (RHole r) = rnf r ----------------------------------------------------------------@@ -587,16 +575,13 @@ 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+instance (RefTypable c tv r) => PPrint (RType c tv r) where pprint = ppRType TopPrec -instance PPrint (RType p c tv r) => Show (RType p c tv r) where+instance PPrint (RType c tv r) => Show (RType c tv r) where show = showpp -instance PPrint (RTProp p c tv r) => Show (RTProp p c tv r) where+instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where show = showpp instance PPrint REnv where@@ -613,17 +598,7 @@ 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@(α, τ,_) (RAllS l t) +subsFree m s z (RAllS l t) = RAllS l (subsFree m s z t) subsFree m s z@(α, τ,_) (RAllP π t) = RAllP (subt (α, τ) π) (subsFree m s z t)@@ -649,19 +624,15 @@ = t subsFree m s z (RRTy e r o t) = RRTy (mapSnd (subsFree m s z) <$> e) r o (subsFree m s z t)-subsFree _ _ _ t@(ROth _) - = t-subsFree _ _ _ t@(RHole r)+subsFree _ _ _ t@(RHole _) = 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'+subsFreeRAppTy _ _ t t' r' = RAppTy t t' r' mkRApp m s c ts rs r r'@@ -679,7 +650,9 @@ subsFreeRef m s (α', τ', t') (RProp ss t) = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t subsFreeRef _ _ (α', τ', _) (RPropP ss r) - = RPropP (mapSnd (subt (α', τ')) <$> ss) $ {- subt (α', τ') -} r+ = RPropP (mapSnd (subt (α', τ')) <$> ss) r+subsFreeRef _ _ _ (RHProp _ _)+ = errorstar "TODO RHProp.subsFreeRef" ------------------------------------------------------------------- ------------------- Type Substitutions ----------------------------@@ -695,7 +668,7 @@ instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where subt su (PVProp t) = PVProp (subt su t)- subt su PVHProp = PVHProp+ subt _ PVHProp = PVHProp instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where subt su (PV n t v xts) = PV n (subt su t) v [(subt su t, x, y) | (t,x,y) <- xts]@@ -728,9 +701,10 @@ instance SubsTy Symbol BSort BSort where subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) -instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType p c tv ())) => SubsTy tv ty (RTProp p c tv (UReft r)) where+instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType c tv ())) => SubsTy tv ty (RTProp c tv (UReft r)) where subt m (RPropP ss p) = RPropP ((mapSnd (subt m)) <$> ss) $ subt m p- subt m (RProp ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t+ subt m (RProp ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t+ subt _ (RHProp _ _) = errorstar "TODO: RHProp.subt" subvUReft :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft subvUReft f (U r p s) = U r (subvPredicate f p) s@@ -740,7 +714,6 @@ --------------------------------------------------------------- --- ofType, ofType_ :: Reftable r => Type -> RRType r ofType = ofType_ . expandTypeSynonyms ofType_ (TyVarTy α) @@ -759,10 +732,8 @@ ofType_ (LitTy x) = fromTyLit x where- fromTyLit (NumTyLit n) = rApp intTyCon [] [] mempty- fromTyLit (StrTyLit s) = rApp listTyCon [rApp charTyCon [] [] mempty] [] mempty-ofType_ τ - = errorstar ("ofType cannot handle: " ++ showPpr τ)+ fromTyLit (NumTyLit _) = rApp intTyCon [] [] mempty+ fromTyLit (StrTyLit _) = rApp listTyCon [rApp charTyCon [] [] mempty] [] mempty ---------------------------------------------------------------- ------------------- Converting to Fixpoint ---------------------@@ -772,10 +743,6 @@ instance Expression Var where expr = eVar ---pprShort = symbolString . dropModuleNames . symbol- dataConSymbol :: DataCon -> Symbol dataConSymbol = symbol . dataConWorkId @@ -802,11 +769,11 @@ isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c isBaseTy (TyVarTy _) = True-isBaseTy (AppTy t1 t2) = False+isBaseTy (AppTy _ _) = False isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts isBaseTy (FunTy _ _) = False isBaseTy (ForAllTy _ _) = False-+isBaseTy (LitTy _) = True vv_ = vv Nothing @@ -841,8 +808,6 @@ = AppTy (toType t) (toType t') toType t@(RExprArg _) = errorstar $ "RefType.toType cannot handle 1: " ++ show t-toType t@(ROth _) - = errorstar $ "RefType.toType cannot handle 2: " ++ show t toType (RRTy _ _ _ t) = toType t toType t@@ -850,33 +815,6 @@ --------------------------------------------------------------------------------------- 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 mempty 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 ----------------------------------------------------------------- ---------------- Annotations and Solutions -------------------- --------------------------------------------------------------- @@ -939,7 +877,7 @@ typeSort :: TCEmb TyCon -> Type -> Sort typeSort tce τ@(ForAllTy _ _) = typeSortForAll tce τ-typeSort tce t@(FunTy τ1 τ2)+typeSort tce t@(FunTy _ _) = typeSortFun tce t typeSort tce (TyConApp c τs) = fApp (Left $ tyConFTyCon tce c) (typeSort tce <$> τs)@@ -959,11 +897,6 @@ 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@@ -993,19 +926,16 @@ where f = ((<$>) ((,) dummySymbol . ofType)) . third4 menv = (emptyFamInstEnv, emptyFamInstEnv) --- Move to misc-forth4 (_, _, _, x) = x- ----------------------------------------------------------------------------------------- -- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum) ----------------------------------------------------------------------------------------- -classBinds t@(RApp c ts _ _) +classBinds (RApp c ts _ _) | isFracCls c = [(rTyVarSymbol a, trueSortedReft FReal) | (RVar a _) <- ts] | isNumCls c = [(rTyVarSymbol a, trueSortedReft FNum) | (RVar a _) <- ts]-classBinds t +classBinds _ = [] rTyVarSymbol (RTV α) = typeUniqueSymbol $ TyVarTy α@@ -1029,11 +959,13 @@ Just f = sizeFunction $ rtc_info c vv = "vvRec" -mkDType xvs acc ((v, (x, t@(RApp c _ _ _))):vxts)+mkDType xvs acc ((v, (x, (RApp c _ _ _))):vxts) = mkDType ((v', x, f):xvs) (r:acc) vxts where r = cmpLexRef xvs (v', x, f) v' = symbol v Just f = sizeFunction $ rtc_info c+mkDType _ _ _+ = errorstar "RefType.mkDType called on invalid input" cmpLexRef vxs (v, x, g) = pAnd $ (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero)@@ -1045,7 +977,7 @@ where rs = makeLexReft [] [] es es' vv = "vvRec" -makeLexReft old acc [] [] +makeLexReft _ acc [] [] = acc makeLexReft old acc (e:es) (e':es') = makeLexReft ((e,e'):old) (r:acc) es es'@@ -1053,30 +985,39 @@ r = pAnd $ (PAtom Lt e' e) : (PAtom Ge e' zero) : [PAtom Eq o' o | (o,o') <- old] - ++ [PAtom Ge o' zero | (o,o') <- old] + ++ [PAtom Ge o' zero | (_,o') <- old] zero = ECon $ I 0+makeLexReft _ _ _ _+ = errorstar "RefType.makeLexReft on invalid input" ------------------------------------------------------------------------------- -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]+mkTyConInfo :: TyCon -> VarianceInfo -> VarianceInfo -> (Maybe (Symbol -> Expr)) -> TyConInfo++mkTyConInfo c usertyvar userprvariance f + = TyConInfo (if null usertyvar then defaulttyvar else usertyvar) userprvariance f+ where + defaulttyvar = varSignToVariance <$> [0 ..n]++ varSignToVariance i = case filter (\p -> fst p == i) varsigns of + [] -> Invariant+ [(_, b)] -> if b then Covariant else Contravariant+ _ -> Bivariant+ 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)+ 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+ go _ _ (LitTy _) = [] 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)
src/Language/Haskell/Liquid/Strata.hs view
@@ -9,8 +9,6 @@ import Control.Applicative ((<$>)) -import Debug.Trace (trace)-import Language.Fixpoint.Misc import Language.Fixpoint.Types (Symbol) import Language.Haskell.Liquid.Types hiding (Def, Loc) @@ -19,7 +17,7 @@ | otherwise = True solveStrata = go True [] [] - where go False solved acc [] = solved+ where go False solved _ [] = solved go True solved acc [] = go False solved [] $ {-traceShow ("OLD \n" ++ showMap solved acc ) $ -} subsS solved <$> acc go mod solved acc (([], _):ls) = go mod solved acc ls go mod solved acc ((_, []):ls) = go mod solved acc ls@@ -28,14 +26,7 @@ | noUpdate l = go mod solved (l:acc) ls | otherwise = go True (solve l ++ solved) (l:acc) ls -traceSMap s init sol= sol -- trace (s ++ "\n" ++ showMap sol init) sol -showMap :: [(Symbol, Stratum)] -> [([Stratum], [Stratum])] -> String-showMap s acc - = "\nMap lenght = " ++ show (length acc) ++ "\n" ++- "Solved = (" ++ show (length s) ++ ")\n" ++ show s ++ "\n"- ++ concatMap (\xs -> (show xs ++ "\n") ) acc ++ "\n\n"- allSVars (xs, ys) = all isSVar $ xs ++ ys noSVar (xs, ys) = all (not . isSVar) (xs ++ ys) noUpdate (xs, ys) = (not $ updateFin(xs, ys)) && (not $ updateDiv (xs, ys)) @@ -71,7 +62,7 @@ subS su (AnnUse t) = AnnUse $ subS su t subS su (AnnDef t) = AnnDef $ subS su t subS su (AnnRDf t) = AnnRDf $ subS su t- subS su (AnnLoc s) = AnnLoc s+ subS _ (AnnLoc s) = AnnLoc s instance SubStratum SpecType where subS su t = (\r -> r {ur_strata = subS su (ur_strata r)}) <$> t
src/Language/Haskell/Liquid/Tidy.hs view
@@ -15,21 +15,16 @@ , isTmpSymbol ) 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 qualified Data.Text as T-import Data.Maybe (fromMaybe) --import Language.Fixpoint.Misc import Language.Fixpoint.Names (symSepName, isPrefixOfSym, takeWhileSym) import Language.Fixpoint.Types import Language.Haskell.Liquid.GhcMisc (stringTyVar) import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.PrettyPrint import Language.Haskell.Liquid.RefType hiding (shiftVV) -------------------------------------------------------------------------@@ -100,7 +95,6 @@ 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@@ -124,7 +118,7 @@ tyVars (REx _ _ t) = tyVars t tyVars (RExprArg _) = [] tyVars (RRTy _ _ _ t) = tyVars t-tyVars (ROth _) = []+tyVars (RHole _) = [] subsTyVarsAll ats = go where @@ -141,8 +135,8 @@ 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 (RRTy _ _ _ t) = funBinds t-funBinds (RAppTy t1 t2 r) = funBinds t1 ++ funBinds t2-funBinds (RExprArg e) = []+funBinds (RAppTy t1 t2 _) = funBinds t1 ++ funBinds t2+funBinds (RExprArg _) = []+funBinds (RHole _) = []
src/Language/Haskell/Liquid/TransformRec.hs view
@@ -11,7 +11,7 @@ import Bag import Coercion-import Control.Arrow (second, (***))+import Control.Arrow (second) import Control.Monad.State import CoreLint import CoreSyn@@ -27,6 +27,7 @@ import Var import Name (isSystemName) import Language.Haskell.Liquid.GhcMisc+import Language.Haskell.Liquid.GhcPlay import Language.Haskell.Liquid.Misc (mapSndM) import Language.Fixpoint.Misc (mapSnd) @@ -35,17 +36,35 @@ import qualified Data.List as L + transformRecExpr :: CoreProgram -> CoreProgram transformRecExpr cbs | isEmptyBag $ filterBag isTypeError e = {-trace "new cbs"-} pg | otherwise - = error ("INITIAL\n" ++ showPpr pg0 ++ "\nTRANSFORMED\n" ++ showPpr pg ++ "Type-check" ++ showSDoc (pprMessageBag e))- where pg0 = evalState (transPg cbs) initEnv+ = error ("Type-check" ++ showSDoc (pprMessageBag e))+ where pg0 = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv (_, e) = lintCoreBindings [] pg pg = inlineFailCases pg0 +++inlineLoopBreaker (NonRec x e) | Just (lbx, lbe) <- hasLoopBreaker be + = Rec [(x, foldr Lam (sub (M.singleton lbx e') lbe) (αs ++ as))]+ where+ (αs, as, be) = collectTyAndValBinders e++ e' = foldl' App (foldl' App (Var x) ((Type . TyVarTy) <$> αs)) (Var <$> as)++ hasLoopBreaker (Let (Rec [(x1, e1)]) (Var x2)) | isLoopBreaker x1 && x1 == x2 = Just (x1, e1)+ hasLoopBreaker _ = Nothing++ isLoopBreaker = isStrongLoopBreaker . occInfo . idInfo++inlineLoopBreaker bs + = bs+ inlineFailCases :: CoreProgram -> CoreProgram inlineFailCases = (go [] <$>) where @@ -61,7 +80,7 @@ go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt) go' su (Cast e c) = Cast (go' su e) c go' su (Tick t e) = Tick t (go' su e)- go' su e = e+ go' _ e = e goalt su (c, xs, e) = (c, xs, go' su e) @@ -69,12 +88,11 @@ getFailExpr = L.lookup addFailExpr x (Lam _ e) su = (x, e):su - addFailExpr x e _ = error "internal error" -- this cannot happen+ addFailExpr _ _ _ = error "internal error" -- this cannot happen isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False isTypeError _ = True -scopeTr = outerScTr . innerScTr transformScope = outerScTr . innerScTr outerScTr = mapNonRec (go [])@@ -91,12 +109,12 @@ 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)+ go bs _ e = (bs, e) type TE = State TrEnv data TrEnv = Tr { freshIndex :: !Int- , loc :: SrcSpan+ , _loc :: SrcSpan } initEnv = Tr 0 noSrcSpan@@ -134,6 +152,8 @@ e' = Let (Rec xes') e xes' = (second mkLet) <$> xes +trans _ _ _ _ = error "TransformRec.trans called with invalid input"+ makeTrans vs ids (Let (Rec xes) e) = do fids <- mapM (mkFreshIds vs ids) xs let (ids', ys) = unzip fids@@ -149,6 +169,8 @@ mkSu ys ids' = mkSubs ids vs ids' (zip xs ys) mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e') +makeTrans _ _ _ = error "TransformRec.makeTrans called with invalid input"+ 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 @@ -190,71 +212,6 @@ = 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
src/Language/Haskell/Liquid/Types.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-} -- | This module should contain all the global type definitions and basic instances. @@ -37,13 +38,13 @@ -- * Refined Type Constructors , RTyCon (RTyCon, rtc_tc, rtc_info)- , TyConInfo(..)+ , TyConInfo(..), defaultTyConInfo , rTyConPVs , rTyConPropVs- , isClassRTyCon+ , isClassRTyCon, isClassType -- * Refinement Types - , RType (..), Ref(..), RTProp (..)+ , RType (..), Ref(..), RTProp , RTyVar (..) , RTAlias (..) @@ -139,7 +140,6 @@ -- * Refinement Type Aliases , RTEnv (..)- , RTBareOrSpec , mapRT, mapRP, mapRE -- * Final Result@@ -182,23 +182,24 @@ , getStrata , makeDivType, makeFinType + -- * CoreToLogic+ , LogicMap, toLogicMap, eAppWithMap, LMap(..)++ -- * Refined Instances+ , RDEnv, DEnv(..), RInstance(..)+ ) where -import FastString (fsLit)-import SrcLoc (noSrcSpan, mkGeneralSrcSpan, SrcSpan)+import SrcLoc (noSrcSpan, SrcSpan) import TyCon import DataCon-import Name (getName) import NameSet import Module (moduleNameFS)-import Class (classTyCon) import TypeRep hiding (maybeParen, pprArrowChain) import Var-import Unique-import Literal import Text.Printf-import GHC (Class, HscEnv, ModuleName, Name, moduleNameString)+import GHC (HscEnv, ModuleName, moduleNameString) import GHC.Generics import Language.Haskell.Liquid.GhcMisc @@ -207,10 +208,10 @@ import TysWiredIn (listTyCon) import Control.Arrow (second)-import Control.Monad (liftM, liftM2, liftM3)+import Control.Monad (liftM, liftM2, liftM3, liftM4) import qualified Control.Monad.Error as Ex import Control.DeepSeq-import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>)) import Data.Typeable (Typeable) import Data.Generics (Data) import Data.Monoid hiding ((<>))@@ -218,28 +219,26 @@ 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.Maybe (fromMaybe) import Data.Traversable hiding (mapM)-import Data.List (isSuffixOf, nub, union, unionBy)+import Data.List (nub) import Data.Text (Text) import qualified Data.Text as T-import Data.Aeson hiding (Result) -import Text.Parsec.Pos (SourcePos, newPos, sourceName, sourceLine, sourceColumn) +import Text.Parsec.Pos (SourcePos) import Text.Parsec.Error (ParseError) import Text.PrettyPrint.HughesPJ import Language.Fixpoint.Config hiding (Config) import Language.Fixpoint.Misc import Language.Fixpoint.Types hiding (Predicate, Def, R)--- import qualified Language.Fixpoint.Types as F-import Language.Fixpoint.Names (symSepName, isSuffixOfSym, singletonSym, funConName, listConName, tupConName)+import Language.Fixpoint.Names (funConName, listConName, tupConName) import CoreSyn (CoreBind) -import Language.Haskell.Liquid.GhcMisc (isFractionalClass)+import Language.Haskell.Liquid.Variance+import Language.Haskell.Liquid.Misc (mapSndM) -import System.FilePath ((</>), isAbsolute, takeDirectory) import Data.Default+ ----------------------------------------------------------------------------- -- | Command Line Config Options -------------------------------------------- -----------------------------------------------------------------------------@@ -285,9 +284,6 @@ showpp :: (PPrint a) => a -> String showpp = render . pprint -showEMsg :: (PPrint a) => a -> EMsg -showEMsg = EMsg . showpp - instance PPrint a => PPrint (Maybe a) where pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint) @@ -305,7 +301,7 @@ } ppEnv = ppEnvPrintPreds-ppEnvCurrent = PP False False False False+_ppEnvCurrent = PP False False False False ppEnvPrintPreds = PP True False False False ppEnvShort pp = pp { ppShort = True } @@ -362,14 +358,36 @@ , exports :: !NameSet -- ^ `Name`s exported by the module being verified , measures :: [Measure SpecType DataCon] , tyconEnv :: M.HashMap TyCon RTyCon+ , dicts :: DEnv Var SpecType -- ^ Dictionary Environment } +type LogicMap = M.HashMap Symbol LMap +data LMap = LMap { lvar :: Symbol+ , largs :: [Symbol] + , lexpr :: Expr+ }++instance Show LMap where+ show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t|->\t" ++ show e +++toLogicMap = M.fromList . map toLMap+ where + toLMap (x, xs, e) = (x, LMap {lvar = x, largs = xs, lexpr = e})++eAppWithMap lmap f es def+ | Just (LMap _ xs e) <- M.lookup (val f) lmap + = subst (mkSubst $ zip xs es) e+ | otherwise+ = def++ data TyConP = TyConP { freeTyVarsTy :: ![RTyVar] , freePredTy :: ![PVar RSort] , freeLabelTy :: ![Symbol]- , covPs :: ![Int] -- ^ indexes of covariant predicate arguments- , contravPs :: ![Int] -- ^ indexes of contravariant predicate arguments+ , varianceTs :: !VarianceInfo+ , variancePs :: !VarianceInfo , sizeFun :: !(Maybe (Symbol -> Expr)) } deriving (Data, Typeable) @@ -415,7 +433,7 @@ instance Functor PVKind where fmap f (PVProp t) = PVProp (f t)- fmap f (PVHProp) = PVHProp+ fmap _ (PVHProp) = PVHProp instance Functor PVar where fmap f (PV x t v txys) = PV x (f <$> t) v (mapFst3 f <$> txys)@@ -428,8 +446,9 @@ rnf (PV n t v txys) = rnf n `seq` rnf v `seq` rnf t `seq` rnf txys instance Hashable (PVar a) where- hashWithSalt i (PV n _ _ xys) = hashWithSalt i n+ hashWithSalt i (PV n _ _ _) = hashWithSalt i n + -------------------------------------------------------------------- ------------------ Predicates -------------------------------------- --------------------------------------------------------------------@@ -493,10 +512,11 @@ instance Symbolic RTyVar where symbol (RTV tv) = symbol . T.pack . showPpr $ tv + data RTyCon = RTyCon - { rtc_tc :: !TyCon -- ^ GHC Type Constructor- , rtc_pvars :: ![RPVar] -- ^ Predicate Parameters- , rtc_info :: !TyConInfo -- ^ TyConInfo+ { rtc_tc :: TyCon -- ^ GHC Type Constructor+ , rtc_pvars :: ![RPVar] -- ^ Predicate Parameters+ , rtc_info :: !TyConInfo -- ^ TyConInfo } deriving (Generic, Data, Typeable) @@ -504,12 +524,15 @@ isClassRTyCon = isClassTyCon . rtc_tc-rTyConInfo = rtc_info -rTyConTc = rtc_tc-rTyConPVs = rtc_pvars-rTyConPropVs = filter isPropPV . rtc_pvars-isPropPV = isProp . ptype+rTyConPVs = rtc_pvars+rTyConPropVs = filter isPropPV . rtc_pvars+isPropPV = isProp . ptype +++isClassType (RApp c _ _ _) = isClass c+isClassType _ = False+ -- rTyConPVHPs = filter isHPropPV . rtc_pvars -- isHPropPV = not . isPropPV @@ -517,7 +540,7 @@ isProp _ = False -defaultTyConInfo = TyConInfo [] [] [] [] Nothing+defaultTyConInfo = TyConInfo [] [] Nothing instance Default TyConInfo where def = defaultTyConInfo@@ -535,29 +558,26 @@ -- -- 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+-- varianceTyArgs = [Bivariant , Covariant, Contravatiant, Invariant]+-- variancePsArgs = [Covariant, Contravatiant, Bivariant] ----- 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))+ { varianceTyArgs :: !VarianceInfo -- ^ variance info for type variables+ , variancePsArgs :: !VarianceInfo -- ^ variance info for predicate variables+ , sizeFunction :: !(Maybe (Symbol -> Expr)) -- ^ logical function that computes the size of the structure } deriving (Generic, Data, Typeable) +instance Show TyConInfo where + show (TyConInfo x y _) = show x ++ "\n" ++ show y+ -------------------------------------------------------------------- ---- Unified Representation of Refinement Types -------------------- -------------------------------------------------------------------- -- MOVE TO TYPES-data RType p c tv r+data RType c tv r = RVar { rt_var :: !tv , rt_reft :: !r @@ -565,60 +585,59 @@ | RFun { rt_bind :: !Symbol- , rt_in :: !(RType p c tv r)- , rt_out :: !(RType p c tv r) + , rt_in :: !(RType c tv r)+ , rt_out :: !(RType c tv r) , rt_reft :: !r } | RAllT { rt_tvbind :: !tv - , rt_ty :: !(RType p c tv r)+ , rt_ty :: !(RType c tv r) } | RAllP {- rt_pvbind :: !(PVar (RType p c tv ()))- , rt_ty :: !(RType p c tv r)+ rt_pvbind :: !(PVar (RType c tv ()))+ , rt_ty :: !(RType c tv r) } | RAllS { rt_sbind :: !(Symbol)- , rt_ty :: !(RType p c tv r)+ , rt_ty :: !(RType c tv r) } | RApp { rt_tycon :: !c- , rt_args :: ![RType p c tv r] - , rt_pargs :: ![RTProp p c tv r] + , rt_args :: ![RType c tv r] + , rt_pargs :: ![RTProp c tv r] , rt_reft :: !r } | RAllE { rt_bind :: !Symbol- , rt_allarg :: !(RType p c tv r)- , rt_ty :: !(RType p c tv r) + , rt_allarg :: !(RType c tv r)+ , rt_ty :: !(RType c tv r) } | REx { rt_bind :: !Symbol- , rt_exarg :: !(RType p c tv r) - , rt_ty :: !(RType p c tv r) + , rt_exarg :: !(RType c tv r) + , rt_ty :: !(RType 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_arg :: !(RType c tv r)+ , rt_res :: !(RType c tv r) , rt_reft :: !r } | RRTy {- rt_env :: ![(Symbol, RType p c tv r)]+ rt_env :: ![(Symbol, RType c tv r)] , rt_ref :: !r , rt_obl :: !Oblig - , rt_ty :: !(RType p c tv r)+ , rt_ty :: !(RType c tv r) }- | ROth !Symbol | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_` -- see tests/pos/Holes.hs@@ -627,6 +646,7 @@ data Oblig = OTerm -- ^ Obligation that proves termination | OInv -- ^ Obligation that proves invariants+ | OCons -- ^ Obligation that proves constraints deriving (Generic, Data, Typeable) ignoreOblig (RRTy _ _ _ t) = t@@ -635,6 +655,7 @@ instance Show Oblig where show OTerm = "termination-condition" show OInv = "invariant-obligation"+ show OCons = "constraint-obligation" instance PPrint Oblig where pprint = text . show@@ -667,7 +688,7 @@ -- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing. -- In general, perhaps we need not expose @Ref@ directly at all.-type RTProp p c tv r = Ref (RType p c tv ()) r (RType p c tv r)+type RTProp c tv r = Ref (RType c tv ()) r (RType c tv r) -- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders@@ -686,8 +707,8 @@ = U { ur_reft :: !r, ur_pred :: !Predicate, ur_strata :: !Strata } deriving (Generic, Data, Typeable) -type BRType = RType LocSymbol LocSymbol Symbol-type RRType = RType Class RTyCon RTyVar+type BRType = RType LocSymbol Symbol+type RRType = RType RTyCon RTyVar type BSort = BRType () type RSort = RRType ()@@ -733,14 +754,14 @@ isFracCls = const False class ( TyConable c- , Eq p, Eq c, Eq tv+ , Eq c, Eq tv , Hashable tv , Reftable r , PPrint r- ) => RefTypable p c tv r + ) => RefTypable c tv r where- ppCls :: p -> [RType p c tv r] -> Doc- ppRType :: Prec -> RType p c tv r -> Doc +-- ppCls :: p -> [RType c tv r] -> Doc+ ppRType :: Prec -> RType c tv r -> Doc @@ -781,15 +802,34 @@ instance PPrint RTyCon where- pprint = toFix+ pprint = text . showPpr . rtc_tc + instance Show RTyCon where show = showpp --------------------------------------------------------------------------+-- | Refined Instances ---------------------------------------------------+--------------------------------------------------------------------------++data RInstance t = RI { riclass :: LocSymbol+ , ritype :: t + , risigs :: [(LocSymbol, t)]+ }++newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol ty)) deriving (Monoid)++type RDEnv = DEnv Var SpecType++instance Functor RInstance where+ fmap f (RI x t xts) = RI x (f t) (mapSnd f <$> xts) +++-------------------------------------------------------------------------- -- | Values Related to Specifications ------------------------------------ -------------------------------------------------------------------------- + -- | Data type refinements data DataDecl = D { tycName :: LocSymbol -- ^ Type Constructor Name@@ -808,6 +848,13 @@ } -- deriving (Show) ++instance Eq DataDecl where+ d1 == d2 = (tycName d1) == (tycName d2)++instance Ord DataDecl where+ compare d1 d2 = compare (tycName d1) (tycName d2)+ -- | For debugging. instance Show DataDecl where show dd = printf "DataDecl: data = %s, tyvars = %s" @@ -828,38 +875,23 @@ , rtVArgs = f <$> rtVArgs rt } --- | Datacons---- JUNK data BDataCon a --- JUNK = BDc a -- ^ Raw named data constructor--- JUNK | BTup Int -- ^ Tuple constructor + arity--- JUNK deriving (Eq, Ord, Show)--- JUNK --- JUNK instance Functor BDataCon where--- JUNK fmap f (BDc x) = BDc (f x)--- JUNK fmap f (BTup i) = BTup i--- JUNK --- JUNK instance Hashable a => Hashable (BDataCon a) where--- JUNK hashWithSalt i (BDc x) = hashWithSalt i x--- JUNK hashWithSalt i (BTup j) = hashWithSalt i j- ------------------------------------------------------------------------ -- | Constructor and Destructors for RTypes ---------------------------- ------------------------------------------------------------------------ -data RTypeRep p c tv r+data RTypeRep c tv r = RTypeRep { ty_vars :: [tv]- , ty_preds :: [PVar (RType p c tv ())]+ , ty_preds :: [PVar (RType c tv ())] , ty_labels :: [Symbol] , ty_binds :: [Symbol]- , ty_args :: [RType p c tv r]- , ty_res :: (RType p c tv r)+ , ty_args :: [RType c tv r]+ , ty_res :: (RType c tv r) } fromRTypeRep rep = mkArrow (ty_vars rep) (ty_preds rep) (ty_labels rep) (zip (ty_binds rep) (ty_args rep)) (ty_res rep) -toRTypeRep :: RType p c tv r -> RTypeRep p c tv r+toRTypeRep :: RType c tv r -> RTypeRep c tv r toRTypeRep t = RTypeRep αs πs ls xs ts t'' where (αs, πs, ls, t') = bkUniv t@@ -885,7 +917,7 @@ mkUnivs αs πs ls t = foldr RAllT (foldr RAllP (foldr RAllS t ls) πs) αs -bkUniv :: RType t t1 a t2 -> ([a], [PVar (RType t t1 a ())], [Symbol], RType t t1 a t2)+bkUniv :: RType t1 a t2 -> ([a], [PVar (RType t1 a ())], [Symbol], RType t1 a t2) bkUniv (RAllT α t) = let (αs, πs, ls, t') = bkUniv t in (α:αs, πs, ls, t') bkUniv (RAllP π t) = let (αs, πs, ls, t') = bkUniv t in (αs, π:πs, ls, t') bkUniv (RAllS s t) = let (αs, πs, ss, t') = bkUniv t in (αs, πs, s:ss, t') @@ -894,6 +926,8 @@ bkClass (RFun _ (RApp c t _ _) t' _) | isClass c = let (cs, t'') = bkClass t' in ((c, t):cs, t'')+bkClass (RRTy e r o t)+ = let (cs, t') = bkClass t in (cs, RRTy e r o t') bkClass t = ([], t) @@ -930,11 +964,11 @@ syms (SVar s) = [s] syms _ = [] subst su (SVar s) = SVar $ subst su s- subst su s = s+ subst _ s = s substf f (SVar s) = SVar $ substf f s- substf f s = s+ substf _ s = s substa f (SVar s) = SVar $ substa f s- substa f s = s+ substa _ s = s instance Subable Strata where syms s = concatMap syms s@@ -946,21 +980,24 @@ isTauto [] = True isTauto _ = False - ppTy s = error "ppTy on Strata" - toReft s = mempty+ ppTy _ = error "ppTy on Strata" + toReft _ = mempty params s = [l | SVar l <- s]- bot s = []- top s = []+ bot _ = []+ top _ = [] + ofReft = error "TODO: Strata.ofReft"+ 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 ps _) = toReft r `meet` toReft ps params (U r _ _) = params r bot (U r _ s) = U (bot r) (Pr []) (bot s) top (U r p s) = U (top r) (top p) (top s) + ofReft = error "TODO: UReft.ofReft"+ isTauto_ureft u = isTauto (ur_reft u) && isTauto (ur_pred u) && (isTauto $ ur_strata u) isTauto_ureft' u = isTauto (ur_reft u) && isTauto (ur_pred u)@@ -978,24 +1015,28 @@ ppr_str s = text "^" <> pprint s instance Subable r => Subable (UReft r) where- syms (U r p s) = syms r ++ syms p + syms (U r p _) = syms r ++ syms p subst s (U r z l) = U (subst s r) (subst s z) (subst s l) substf f (U r z l) = U (substf f r) (substf f z) (substf f l) substa f (U r z l) = U (substa f r) (substa f z) (substa f l) -instance (Reftable r, RefTypable p c tv r) => Subable (RTProp p c tv r) where+instance (Reftable r, RefTypable c tv r) => Subable (RTProp c tv r) where syms (RPropP ss r) = (fst <$> ss) ++ syms r- syms (RProp ss r) = (fst <$> ss) ++ syms r+ syms (RProp ss r) = (fst <$> ss) ++ syms r+ syms (RHProp _ _) = error "TODO: PHProp.syms" subst su (RPropP ss r) = RPropP ss (subst su r)- subst su (RProp ss t) = RProp ss (subst su <$> t)+ subst su (RProp ss t) = RProp ss (subst su <$> t)+ subst _ (RHProp _ _) = error "TODO: PHProp.subst" substf f (RPropP ss r) = RPropP ss (substf f r) - substf f (RProp ss t) = RProp ss (substf f <$> t)+ substf f (RProp ss t) = RProp ss (substf f <$> t)+ substf _ (RHProp _ _) = error "TODO PHProp.substf" substa f (RPropP ss r) = RPropP ss (substa f r) - substa f (RProp ss t) = RProp ss (substa f <$> t)+ substa f (RProp ss t) = RProp ss (substa f <$> t)+ substa _ (RHProp _ _) = error "TODO PHProp.substa" -instance (Subable r, RefTypable p c tv r) => Subable (RType p c tv r) where+instance (Subable r, RefTypable c tv r) => Subable (RType c tv r) where syms = foldReft (\r acc -> syms r ++ acc) [] substa f = mapReft (substa f) substf f = emapReft (substf . substfExcept f) [] @@ -1018,7 +1059,9 @@ toReft _ = mempty params = errorstar "TODO: instance of params for Predicate" + ofReft = error "TODO: Predicate.ofReft" + pToRef p = RConc $ pApp (pname p) $ (EVar $ parg p) : (thd3 <$> pargs p) pApp :: Symbol -> [Expr] -> Pred@@ -1035,16 +1078,16 @@ instance Functor UReft where fmap f (U r p s) = U (f r) p s -instance Functor (RType a b c) where+instance Functor (RType a b) 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 :: (r1 -> r2) -> RType c tv r1 -> RType c tv r2 mapReft f = emapReft (\_ -> f) [] -emapReft :: ([Symbol] -> r1 -> r2) -> [Symbol] -> RType p c tv r1 -> RType p c tv r2+emapReft :: ([Symbol] -> r1 -> r2) -> [Symbol] -> RType c tv r1 -> RType c tv r2 emapReft f γ (RVar α r) = RVar α (f γ r) emapReft f γ (RAllT α t) = RAllT α (emapReft f γ t)@@ -1057,12 +1100,12 @@ emapReft _ _ (RExprArg e) = RExprArg e emapReft f γ (RAppTy t t' r) = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r) emapReft f γ (RRTy e r o t) = RRTy (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)-emapReft _ _ (ROth s) = ROth s emapReft f γ (RHole r) = RHole (f γ r) -emapRef :: ([Symbol] -> t -> s) -> [Symbol] -> RTProp p c tv t -> RTProp p c tv s+emapRef :: ([Symbol] -> t -> s) -> [Symbol] -> RTProp c tv t -> RTProp c tv s emapRef f γ (RPropP s r) = RPropP s $ f γ r-emapRef f γ (RProp s t) = RProp s $ emapReft f γ t+emapRef f γ (RProp s t) = RProp s $ emapReft f γ t+emapRef _ _ (RHProp _ _) = error "TODO: PHProp empaReft" ------------------------------------------------------------------------------------------------------ -- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t@@ -1080,11 +1123,11 @@ isFunTy (RAllS _ t) = isFunTy t isFunTy (RAllT _ t) = isFunTy t isFunTy (RAllP _ t) = isFunTy t-isFunTy (RFun _ t1 t2 _) = True+isFunTy (RFun _ _ _ _) = True isFunTy _ = False -mapReftM :: (Monad m) => (r1 -> m r2) -> RType p c tv r1 -> m (RType p c tv r2)+mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType 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)@@ -1095,24 +1138,25 @@ 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 mapReftM f (RHole r) = liftM RHole (f r)+mapReftM f (RRTy xts r o t) = liftM4 RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t) -mapRefM :: (Monad m) => (t -> m s) -> (RTProp p c tv t) -> m (RTProp p c tv s)-mapRefM f (RPropP s r) = liftM (RPropP s) (f r)-mapRefM f (RProp s t) = liftM (RProp s) (mapReftM f t)+mapRefM :: (Monad m) => (t -> m s) -> (RTProp c tv t) -> m (RTProp c tv s)+mapRefM f (RPropP s r) = liftM (RPropP s) (f r)+mapRefM f (RProp s t) = liftM (RProp s) (mapReftM f t)+mapRefM _ (RHProp _ _) = error "TODO PHProp.mapRefM" --- foldReft :: (r -> a -> a) -> a -> RType p c tv r -> a+-- foldReft :: (r -> a -> a) -> a -> RType 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 :: Reftable r =>(p -> [RType c tv r] -> [(Symbol, a)])-> (RType c tv r -> a)-> (SEnv a -> Maybe (RType c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType c tv r-> c1 efoldReft cb g f fp = go where -- folding over RType go γ z me@(RVar _ r) = f γ (Just me) r z go γ z (RAllT _ t) = go γ z t go γ z (RAllP p t) = go (fp p γ) z t- go γ z (RAllS s t) = go γ z t+ go γ z (RAllS _ t) = go γ z t go γ z me@(RFun _ (RApp c ts _ _) t' r) | isClass c = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t') go γ z me@(RFun x t t' r) = f γ (Just me) r (go (insertSEnv x (g t) γ) (go γ z t) t')@@ -1120,15 +1164,16 @@ 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@(RRTy e r o t) = f γ (Just me) r (go γ z t)+ go γ z me@(RRTy [] r _ t) = f γ (Just me) r (go γ z t)+ go γ z me@(RRTy xts r _ t) = f γ (Just me) r (go γ (go γ z (envtoType xts)) t) go γ z me@(RAppTy t t' r) = f γ (Just me) r (go γ (go γ z t) t') go _ z (RExprArg _) = z go γ z me@(RHole r) = f γ (Just me) r z -- folding over Ref ho γ z (RPropP ss r) = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z- ho γ z (RProp ss t) = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t+ ho γ z (RProp ss t) = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t+ ho _ _ (RHProp _ _) = error "TODO: RHProp.ho" -- folding over [RType] go' γ z ts = foldr (flip $ go γ) z ts @@ -1136,6 +1181,7 @@ -- folding over [Ref] ho' γ z rs = foldr (flip $ ho γ) z rs + envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts) mapBot f (RAllT α t) = RAllT α (mapBot f t) mapBot f (RAllP π t) = RAllP π (mapBot f t)@@ -1145,9 +1191,11 @@ mapBot f (RApp c ts rs r) = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r mapBot f (REx b t1 t2) = REx b (mapBot f t1) (mapBot f t2) mapBot f (RAllE b t1 t2) = RAllE b (mapBot f t1) (mapBot f t2)+mapBot f (RRTy e r o t) = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t) mapBot f t' = f t' mapBotRef _ (RPropP s r) = RPropP s $ r-mapBotRef f (RProp s t) = RProp s $ mapBot f t+mapBotRef f (RProp s t) = RProp s $ mapBot f t+mapBotRef _ (RHProp _ _) = error "TODO: RHProp.mapBotRef" mapBind f (RAllT α t) = RAllT α (mapBind f t) mapBind f (RAllP π t) = RAllP π (mapBind f t)@@ -1157,42 +1205,43 @@ 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 _ (RHole r) = RHole r mapBind f (RRTy e r o t) = RRTy e r o (mapBind f t) mapBind _ (RExprArg e) = RExprArg e mapBind f (RAppTy t t' r) = RAppTy (mapBind f t) (mapBind f t') r mapBindRef f (RPropP s r) = RPropP (mapFst f <$> s) r-mapBindRef f (RProp s t) = RProp (mapFst f <$> s) $ mapBind f t+mapBindRef f (RProp s t) = RProp (mapFst f <$> s) $ mapBind f t+mapBindRef _ (RHProp _ _) = error "TODO: RHProp.mapBindRef" ---------------------------------------------------ofRSort :: Reftable r => RType p c tv () -> RType p c tv r +ofRSort :: Reftable r => RType c tv () -> RType c tv r ofRSort = fmap mempty -toRSort :: RType p c tv r -> RType p c tv () -toRSort = stripQuantifiers . mapBind (const dummySymbol) . fmap (const ())+toRSort :: RType c tv r -> RType c tv () +toRSort = stripAnnotations . mapBind (const dummySymbol) . fmap (const ()) -stripQuantifiers (RAllT α t) = RAllT α (stripQuantifiers t)-stripQuantifiers (RAllP _ t) = stripQuantifiers t-stripQuantifiers (RAllS _ 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 t = t-stripQuantifiersRef (RProp s t) = RProp s $ stripQuantifiers t-stripQuantifiersRef r = r+stripAnnotations (RAllT α t) = RAllT α (stripAnnotations t)+stripAnnotations (RAllP _ t) = stripAnnotations t+stripAnnotations (RAllS _ t) = stripAnnotations t+stripAnnotations (RAllE _ _ t) = stripAnnotations t+stripAnnotations (REx _ _ t) = stripAnnotations t+stripAnnotations (RFun x t t' r) = RFun x (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RAppTy t t' r) = RAppTy (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RApp c ts rs r) = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r+stripAnnotations (RRTy _ _ _ t) = stripAnnotations t+stripAnnotations t = t+stripAnnotationsRef (RProp s t) = RProp s $ stripAnnotations t+stripAnnotationsRef r = r insertsSEnv = foldr (\(x, t) γ -> insertSEnv x t γ) -rTypeValueVar :: (Reftable r) => RType p c tv r -> Symbol+rTypeValueVar :: (Reftable r) => RType c tv r -> Symbol rTypeValueVar t = vv where Reft (vv,_) = rTypeReft t -rTypeReft :: (Reftable r) => RType p c tv r -> Reft+rTypeReft :: (Reftable r) => RType c tv r -> Reft rTypeReft = fromMaybe trueReft . fmap toReft . stripRTypeBase -- stripRTypeBase :: RType a -> Maybe a@@ -1211,14 +1260,14 @@ mapRBase f (RVar a r) = RVar a $ f r mapRBase f (RFun x t1 t2 r) = RFun x t1 t2 $ f r mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r -mapRBase f t = t+mapRBase _ t = t makeLType :: Stratum -> SpecType -> SpecType makeLType l t = fromRTypeRep trep{ty_res = mapRBase f $ ty_res trep} where trep = toRTypeRep t- f (U r p s) = U r p [l]+ f (U r p _) = U r p [l] makeDivType = makeLType SDiv @@ -1389,6 +1438,11 @@ , msg :: !Doc } -- ^ sort error in specification + | ErrTermSpec { pos :: !SrcSpan+ , var :: !Doc+ , exp :: !Expr+ , msg :: !Doc+ } -- ^ sort error in specification | ErrDupAlias { pos :: !SrcSpan , var :: !Doc , kind :: !Doc@@ -1400,6 +1454,11 @@ , locs:: ![SrcSpan] } -- ^ multiple specs for same binder error + | ErrBadData { pos :: !SrcSpan+ , var :: !Doc+ , msg :: !Doc+ } -- ^ multiple specs for same binder error + | ErrInvt { pos :: !SrcSpan , inv :: !t , msg :: !Doc@@ -1439,7 +1498,16 @@ , hs :: !Type , texp :: !t } -- ^ Mismatch between Liquid and Haskell types+ + | ErrAliasCycle { pos :: !SrcSpan+ , acycle :: ![(SrcSpan, Doc)] + } -- ^ Cyclic Refined Type Alias Definitions + | ErrIllegalAliasApp { pos :: !SrcSpan+ , dname :: !Doc+ , dpos :: !SrcSpan+ } -- ^ Illegal RTAlias application (from BSort, eg. in PVar)+ | ErrAliasApp { pos :: !SrcSpan , nargs :: !Int , dname :: !Doc@@ -1451,12 +1519,16 @@ , msg :: !Doc } -- ^ Previously saved error, that carries over after DiffCheck - | ErrTermin { bind :: ![Var] , pos :: !SrcSpan , msg :: !Doc } -- ^ Termination Error + | ErrRClass { pos :: !SrcSpan+ , cls :: !Doc+ , insts :: ![(SrcSpan, Doc)]+ } -- ^ Refined Class/Interfaces Conflict+ | ErrOther { pos :: !SrcSpan , msg :: !Doc } -- ^ Unexpected PANIC @@ -1520,7 +1592,7 @@ show = getModString instance Symbolic ModName where- symbol (ModName t m) = symbol m+ symbol (ModName _ m) = symbol m instance Symbolic ModuleName where symbol = symbol . moduleNameFS@@ -1542,18 +1614,9 @@ ----------- Refinement Type Aliases ------------------------------------------- ------------------------------------------------------------------------------- -type RTBareOrSpec = Either (ModName, (RTAlias Symbol BareType))- (RTAlias RTyVar SpecType)--type RTPredAlias = Either (ModName, RTAlias Symbol Pred)- (RTAlias Symbol Pred)--type RTExprAlias = Either (ModName, RTAlias Symbol Expr)- (RTAlias Symbol Expr)--data RTEnv = RTE { typeAliases :: M.HashMap Symbol RTBareOrSpec- , predAliases :: M.HashMap Symbol RTPredAlias- , exprAliases :: M.HashMap Symbol RTExprAlias+data RTEnv = RTE { typeAliases :: M.HashMap Symbol (RTAlias RTyVar SpecType)+ , predAliases :: M.HashMap Symbol (RTAlias Symbol Pred)+ , exprAliases :: M.HashMap Symbol (RTAlias Symbol Expr) } instance Monoid RTEnv where@@ -1662,13 +1725,13 @@ instance NFData a => NFData (AnnInfo a) where- rnf (AI x) = () + rnf (AI _) = () instance NFData (Annot a) where- rnf (AnnDef x) = ()- rnf (AnnRDf x) = ()- rnf (AnnUse x) = ()- rnf (AnnLoc x) = ()+ rnf (AnnDef _) = ()+ rnf (AnnRDf _) = ()+ rnf (AnnUse _) = ()+ rnf (AnnLoc _) = () ------------------------------------------------------------------------ -- | Output ------------------------------------------------------------@@ -1747,15 +1810,6 @@ instance Symbolic DataCon where symbol = symbol . dataConWorkId -instance Symbolic Var where- symbol = varSymbol--varSymbol :: Var -> Symbol-varSymbol v - | us `isSuffixOfSym` vs = vs- | otherwise = vs `mappend` singletonSym symSepName `mappend` us- where us = symbol $ showPpr $ getDataConVarUnique v- vs = symbol $ getName v instance PPrint DataCon where pprint = text . showPpr
+ src/Language/Haskell/Liquid/Variance.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Language.Haskell.Liquid.Variance (+ Variance(..), VarianceInfo+ ) where++import Data.Typeable+import Data.Data++type VarianceInfo = [Variance]+data Variance = Invariant | Bivariant | Contravariant | Covariant deriving (Data, Typeable, Show)
+ src/Language/Haskell/Liquid/WiredIn.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.WiredIn where++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.GhcMisc+import Language.Haskell.Liquid.Variance++import Language.Fixpoint.Names (hpropConName, propConName)+import Language.Fixpoint.Types+import Language.Fixpoint.Misc (mapSnd)++import BasicTypes+import DataCon+import TyCon+import TysWiredIn++import Data.Monoid+import Control.Applicative++-----------------------------------------------------------------------+-- | LH Primitive TyCons ----------------------------------------------+-----------------------------------------------------------------------++propTyCon, hpropTyCon :: TyCon +propTyCon = symbolTyCon 'w' 24 propConName+hpropTyCon = symbolTyCon 'w' 24 hpropConName +++-----------------------------------------------------------------------+-- | LH Primitive Types ----------------------------------------------+-----------------------------------------------------------------------++propType :: Reftable r => RRType r +propType = RApp (RTyCon propTyCon [] defaultTyConInfo) [] [] mempty ++++--------------------------------------------------------------------+------ Predicate Types for WiredIns --------------------------------+--------------------------------------------------------------------++maxArity :: Arity +maxArity = 7++wiredTyCons = fst wiredTyDataCons+wiredDataCons = snd wiredTyDataCons++wiredTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, Located DataConP)])+wiredTyDataCons = (concat tcs, mapSnd dummyLoc <$> concat dcs)+ where + (tcs, dcs) = unzip l+ l = [listTyDataCons] ++ map tupleTyDataCons [2..maxArity]++listTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)])+listTyDataCons = ( [(c, TyConP [(RTV tyv)] [p] [] [Covariant] [Covariant] (Just fsize))]+ , [(nilDataCon, DataConP l0 [(RTV tyv)] [p] [] [] [] lt)+ , (consDataCon, DataConP l0 [(RTV tyv)] [p] [] [] cargs lt)])+ where+ l0 = dummyPos "LH.Bare.listTyDataCons"+ c = listTyCon+ [tyv] = tyConTyVars c+ t = rVar tyv :: RSort+ fld = "fldList"+ x = "xListSelector"+ xs = "xsListSelector"+ p = PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar fld)]+ px = pdVarReft $ PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar x)] + lt = rApp c [xt] [RPropP [] $ pdVarReft p] mempty + xt = rVar tyv+ xst = rApp c [RVar (RTV tyv) px] [RPropP [] $ pdVarReft p] mempty+ cargs = [(xs, xst), (x, xt)]+ fsize = \x -> EApp (dummyLoc "len") [EVar x]++tupleTyDataCons :: Int -> ([(TyCon, TyConP)] , [(DataCon, DataConP)])+tupleTyDataCons n = ( [(c, TyConP (RTV <$> tyvs) ps [] tyvarinfo pdvarinfo Nothing)]+ , [(dc, DataConP l0 (RTV <$> tyvs) ps [] [] cargs lt)])+ where + tyvarinfo = replicate n Covariant+ pdvarinfo = replicate (n-1) Covariant+ l0 = dummyPos "LH.Bare.tupleTyDataCons"+ c = tupleTyCon BoxedTuple n+ dc = tupleCon BoxedTuple n + tyvs@(tv:tvs) = tyConTyVars c+ (ta:ts) = (rVar <$> tyvs) :: [RSort]+ flds = mks "fld_Tuple"+ fld = "fld_Tuple"+ x1:xs = mks ("x_Tuple" ++ show n)+ ps = mkps pnames (ta:ts) ((fld, EVar fld):(zip flds (EVar <$>flds)))+ ups = uPVar <$> ps+ pxs = mkps pnames (ta:ts) ((fld, EVar x1):(zip flds (EVar <$> xs)))+ lt = rApp c (rVar <$> tyvs) (RPropP [] . pdVarReft <$> ups) mempty+ xts = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs+ cargs = reverse $ (x1, rVar tv) : (zip xs xts)+ pnames = mks_ "p"+ mks x = (\i -> symbol (x++ show i)) <$> [1..n]+ mks_ x = (\i -> symbol (x++ show i)) <$> [2..n]+++pdVarReft = (\p -> U mempty p mempty) . pdVar ++mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] []+mkps _ _ _ = error "Bare : mkps"++mkps_ [] _ _ _ ps = ps+mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps)+ where+ p = PV n (PVProp t) (vv Nothing) args+ a = (t, f, x)+mkps_ _ _ _ _ _ = error "Bare : mkps_"+
syntax/liquid-tip.el view
@@ -24,18 +24,12 @@ ;;; Code: (eval-when-compile (require 'cl))+(require 'auto-complete) (require 'json) (require 'pos-tip nil t) (require 'thingatpt)-(require 'button-lock nil t)--;; (require 'json-mode)-;; (require 'ring)-;; (require 'etags)-;; (require 'flymake)-;; (require 'eldoc)-;; (require 'log4e)-;; (require 'yaxception)+(require 'button-lock)+(require 'hdevtools) ;; ------------------------------------------------------------------------ ;; A structure to represent positions @@ -205,7 +199,6 @@ ;; DEBUG (position-string pos) ;; DEBUG ident))) - (defun liquid-ident-at-pos (pos) "Return the identifier at a given position" (thing-at-point 'word))@@ -226,12 +219,14 @@ "Popup help about anything at point." (interactive) (let* ((pos (liquid-get-position))- (ident (liquid-ident-at-pos pos))- (sorry (format "No information for %s" ident))+ (ident (liquid-ident-at-pos pos))+ (sorry (format "No information for %s" ident)) (annot (liquid-annot-at-pos pos))) (if annot - (liquid-tip-popup annot)- (liquid-tip-popup sorry))))+ (liquid-tip-popup annot)+ (hdevtools/show-type-info)+ ;; (liquid-tip-popup sorry)+ ))) ;;;###autoload@@ -240,9 +235,7 @@ (interactive) (progn (if mode (setq liquid-tip-mode mode)) (button-lock-mode 1)- (button-lock-set-button liquid-id-regexp 'liquid-tip-show)- ;; DEBUG (button-lock-set-button "yoga" 'liquid-tip-show)- ;; DEBUG (button-lock-set-button "mydiv" 'liquid-tip-show)+ (button-lock-set-button liquid-id-regexp 'liquid-tip-show :mouse-face nil :face nil :face-policy nil :mouse-binding 'double-mouse-1) )) ;;;###autoload@@ -253,23 +246,19 @@ (file (position-file pos))) (liquid-annot-set file mode))) -;; DEBUG (defface my-tooltip-;; DEBUG '((t-;; DEBUG :background "gray85"-;; DEBUG :foreground "black"-;; DEBUG :inherit variable-pitch))-;; DEBUG "Face for my tooltip.")-;; DEBUG -;; DEBUG (defface my-tooltip-highlight-;; DEBUG '((t-;; DEBUG :background "blue"-;; DEBUG :foreground "white"-;; DEBUG :inherit my-tooltip))-;; DEBUG "Face for my tooltip highlighted.")-;; DEBUG -;; DEBUG (let ((str (propertize "foo\nbar\nbaz" 'face 'my-tooltip)))-;; DEBUG (put-text-property 6 11 'face 'my-tooltip-highlight str)-;; DEBUG (pos-tip-show-no-propertize str 'my-tooltip))++;; For simple, ascii popups, use:+;; (liquid-tip-init 'ascii) +;; For emacs', balloon based popups, use:+;; (liquid-tip-init 'balloon)+;; or just+;; (liquid-tip-init 'balloon)++;; Reload annotations after check+(add-hook 'flycheck-after-syntax-check-hook+ (lambda () (liquid-tip-update 'flycheck)))++ (provide 'liquid-tip)
tests/test.hs view
@@ -51,7 +51,10 @@ testGroup "pos" <$> dirTests "tests/pos" [] ExitSuccess , testGroup "neg" <$> dirTests "tests/neg" [] (ExitFailure 1) , testGroup "crash" <$> dirTests "tests/crash" [] (ExitFailure 2) - ]+ , testGroup "parserpos" <$> dirTests "tests/parser/pos" [] ExitSuccess+ , testGroup "errorcrash" <$> dirTests "tests/error_messages/crash" [] (ExitFailure 2)+ , testGroup "errorpos" <$> dirTests "tests/parser/pos" [] ExitSuccess+ ] benchTests = group "Benchmarks" [ @@ -95,8 +98,10 @@ test = dir </> file log = let (d,f) = splitFileName file in dir </> d </> ".liquid" </> f <.> "log" -knownToFail CVC4 = [ "tests/pos/RealProps.hs", "tests/pos/RealProps1.hs", "tests/pos/initarray.hs" ]-knownToFail Z3 = []+knownToFail CVC4 = [ "tests/pos/linspace.hs", "tests/pos/RealProps.hs", "tests/pos/RealProps1.hs", "tests/pos/initarray.hs"+ , "tests/pos/maps.hs", "tests/pos/maps1.hs", "tests/neg/maps.hs"+ , "tests/pos/Product.hs" ]+knownToFail Z3 = [ "tests/pos/linspace.hs" ] --------------------------------------------------------------------------- testCmd :: FilePath -> FilePath -> FilePath -> SmtSolver -> String