Prop>. (a
-> {v:Bool| ((Prop v) <=> true)}) -> a -> a
@-} 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!" + diff --git a/include/Prelude.spec b/include/Prelude.spec --- a/include/Prelude.spec +++ b/include/Prelude.spec @@ -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 diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -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 diff --git a/src/Language/Haskell/Liquid/ACSS.hs b/src/Language/Haskell/Liquid/ACSS.hs --- a/src/Language/Haskell/Liquid/ACSS.hs +++ b/src/Language/Haskell/Liquid/ACSS.hs @@ -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. diff --git a/src/Language/Haskell/Liquid/ANFTransform.hs b/src/Language/Haskell/Liquid/ANFTransform.hs --- a/src/Language/Haskell/Liquid/ANFTransform.hs +++ b/src/Language/Haskell/Liquid/ANFTransform.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Annotate.hs b/src/Language/Haskell/Liquid/Annotate.hs --- a/src/Language/Haskell/Liquid/Annotate.hs +++ b/src/Language/Haskell/Liquid/Annotate.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs --- a/src/Language/Haskell/Liquid/Bare.hs +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Check.hs b/src/Language/Haskell/Liquid/Bare/Check.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Check.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Env.hs b/src/Language/Haskell/Liquid/Bare/Env.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Env.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Existential.hs b/src/Language/Haskell/Liquid/Bare/Existential.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Existential.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Expand.hs b/src/Language/Haskell/Liquid/Bare/Expand.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Expand.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/Bare/GhcSpec.hs b/src/Language/Haskell/Liquid/Bare/GhcSpec.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/GhcSpec.hs @@ -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') + diff --git a/src/Language/Haskell/Liquid/Bare/Lookup.hs b/src/Language/Haskell/Liquid/Bare/Lookup.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Lookup.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Measure.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Misc.hs b/src/Language/Haskell/Liquid/Bare/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Misc.hs @@ -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) + + + + + diff --git a/src/Language/Haskell/Liquid/Bare/OfType.hs b/src/Language/Haskell/Liquid/Bare/OfType.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/OfType.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Plugged.hs b/src/Language/Haskell/Liquid/Bare/Plugged.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Plugged.hs @@ -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) } + diff --git a/src/Language/Haskell/Liquid/Bare/RTEnv.hs b/src/Language/Haskell/Liquid/Bare/RTEnv.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/RTEnv.hs @@ -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 -> [ ] + diff --git a/src/Language/Haskell/Liquid/Bare/RefToLogic.hs b/src/Language/Haskell/Liquid/Bare/RefToLogic.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/RefToLogic.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Resolve.hs b/src/Language/Haskell/Liquid/Bare/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Resolve.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Bare/Spec.hs b/src/Language/Haskell/Liquid/Bare/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Spec.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/Bare/SymSort.hs b/src/Language/Haskell/Liquid/Bare/SymSort.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/SymSort.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/CTags.hs b/src/Language/Haskell/Liquid/CTags.hs --- a/src/Language/Haskell/Liquid/CTags.hs +++ b/src/Language/Haskell/Liquid/CTags.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/CmdLine.hs b/src/Language/Haskell/Liquid/CmdLine.hs --- a/src/Language/Haskell/Liquid/CmdLine.hs +++ b/src/Language/Haskell/Liquid/CmdLine.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint.hs b/src/Language/Haskell/Liquid/Constraint.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Constraint.hs b/src/Language/Haskell/Liquid/Constraint/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Constraint.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Constraint/Types.hs b/src/Language/Haskell/Liquid/Constraint/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Types.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/CoreToLogic.hs b/src/Language/Haskell/Liquid/CoreToLogic.hs --- a/src/Language/Haskell/Liquid/CoreToLogic.hs +++ b/src/Language/Haskell/Liquid/CoreToLogic.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Desugar/Check.lhs b/src/Language/Haskell/Liquid/Desugar/Check.lhs --- a/src/Language/Haskell/Liquid/Desugar/Check.lhs +++ b/src/Language/Haskell/Liquid/Desugar/Check.lhs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs b/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs --- a/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs +++ b/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs @@ -44,7 +44,7 @@ import Digraph -import TyCon ( isTupleTyCon, tyConDataCons_maybe ) +import TyCon ( tyConDataCons_maybe ) import TcEvidence import TcType import Type diff --git a/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs --- a/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs +++ b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs b/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs --- a/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs +++ b/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs b/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs --- a/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs +++ b/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs @@ -25,7 +25,6 @@ import PrelNames import Module import Name -import Util import SrcLoc import Outputable \end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs b/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs --- a/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs +++ b/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar/HscMain.hs b/src/Language/Haskell/Liquid/Desugar/HscMain.hs --- a/src/Language/Haskell/Liquid/Desugar/HscMain.hs +++ b/src/Language/Haskell/Liquid/Desugar/HscMain.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar/Match.lhs b/src/Language/Haskell/Liquid/Desugar/Match.lhs --- a/src/Language/Haskell/Liquid/Desugar/Match.lhs +++ b/src/Language/Haskell/Liquid/Desugar/Match.lhs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs b/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs --- a/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs +++ b/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs b/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs --- a/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs +++ b/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs @@ -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} %************************************************************************ diff --git a/src/Language/Haskell/Liquid/Dictionaries.hs b/src/Language/Haskell/Liquid/Dictionaries.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Dictionaries.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/DiffCheck.hs b/src/Language/Haskell/Liquid/DiffCheck.hs --- a/src/Language/Haskell/Liquid/DiffCheck.hs +++ b/src/Language/Haskell/Liquid/DiffCheck.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Errors.hs b/src/Language/Haskell/Liquid/Errors.hs --- a/src/Language/Haskell/Liquid/Errors.hs +++ b/src/Language/Haskell/Liquid/Errors.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/GhcInterface.hs b/src/Language/Haskell/Liquid/GhcInterface.hs --- a/src/Language/Haskell/Liquid/GhcInterface.hs +++ b/src/Language/Haskell/Liquid/GhcInterface.hs @@ -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 ) diff --git a/src/Language/Haskell/Liquid/GhcMisc.hs b/src/Language/Haskell/Liquid/GhcMisc.hs --- a/src/Language/Haskell/Liquid/GhcMisc.hs +++ b/src/Language/Haskell/Liquid/GhcMisc.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/GhcPlay.hs b/src/Language/Haskell/Liquid/GhcPlay.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GhcPlay.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Literals.hs b/src/Language/Haskell/Liquid/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Literals.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs --- a/src/Language/Haskell/Liquid/Measure.hs +++ b/src/Language/Haskell/Liquid/Measure.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Misc.hs b/src/Language/Haskell/Liquid/Misc.hs --- a/src/Language/Haskell/Liquid/Misc.hs +++ b/src/Language/Haskell/Liquid/Misc.hs @@ -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" + diff --git a/src/Language/Haskell/Liquid/Parse.hs b/src/Language/Haskell/Liquid/Parse.hs --- a/src/Language/Haskell/Liquid/Parse.hs +++ b/src/Language/Haskell/Liquid/Parse.hs @@ -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) --} diff --git a/src/Language/Haskell/Liquid/PredType.hs b/src/Language/Haskell/Liquid/PredType.hs --- a/src/Language/Haskell/Liquid/PredType.hs +++ b/src/Language/Haskell/Liquid/PredType.hs @@ -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) - diff --git a/src/Language/Haskell/Liquid/PrettyPrint.hs b/src/Language/Haskell/Liquid/PrettyPrint.hs --- a/src/Language/Haskell/Liquid/PrettyPrint.hs +++ b/src/Language/Haskell/Liquid/PrettyPrint.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Qualifier.hs b/src/Language/Haskell/Liquid/Qualifier.hs --- a/src/Language/Haskell/Liquid/Qualifier.hs +++ b/src/Language/Haskell/Liquid/Qualifier.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/RefType.hs b/src/Language/Haskell/Liquid/RefType.hs --- a/src/Language/Haskell/Liquid/RefType.hs +++ b/src/Language/Haskell/Liquid/RefType.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Strata.hs b/src/Language/Haskell/Liquid/Strata.hs --- a/src/Language/Haskell/Liquid/Strata.hs +++ b/src/Language/Haskell/Liquid/Strata.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Tidy.hs b/src/Language/Haskell/Liquid/Tidy.hs --- a/src/Language/Haskell/Liquid/Tidy.hs +++ b/src/Language/Haskell/Liquid/Tidy.hs @@ -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 _) = [] diff --git a/src/Language/Haskell/Liquid/TransformRec.hs b/src/Language/Haskell/Liquid/TransformRec.hs --- a/src/Language/Haskell/Liquid/TransformRec.hs +++ b/src/Language/Haskell/Liquid/TransformRec.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Types.hs b/src/Language/Haskell/Liquid/Types.hs --- a/src/Language/Haskell/Liquid/Types.hs +++ b/src/Language/Haskell/Liquid/Types.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Variance.hs b/src/Language/Haskell/Liquid/Variance.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Variance.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/WiredIn.hs b/src/Language/Haskell/Liquid/WiredIn.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/WiredIn.hs @@ -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_" + diff --git a/syntax/liquid-tip.el b/syntax/liquid-tip.el --- a/syntax/liquid-tip.el +++ b/syntax/liquid-tip.el @@ -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) diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -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