liquid-fixpoint 0.8.10.7 → 0.9.0.2.1

raw patch · 459 files changed

+5429/−9737 lines, 459 filesdep +lens-familydep +optparse-applicativedep +taggeddep ~hashabledep ~megaparsecdep ~rest-rewritePVP ok

version bump matches the API change (PVP)

Dependencies added: lens-family, optparse-applicative, tagged, vector

Dependency ranges changed: hashable, megaparsec, rest-rewrite, tasty-hunit

API changes (from Hackage documentation)

- Language.Fixpoint.Defunctionalize: instance Language.Fixpoint.Defunctionalize.Defunc Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Graph.Types: data KVGraph

- Language.Fixpoint.Horn.Types: dummyBind :: Bind

- Language.Fixpoint.Horn.Types: instance Data.Data.Data Language.Fixpoint.Horn.Types.Bind

- Language.Fixpoint.Horn.Types: instance GHC.Classes.Eq Language.Fixpoint.Horn.Types.Bind

- Language.Fixpoint.Horn.Types: instance GHC.Generics.Generic Language.Fixpoint.Horn.Types.Bind

- Language.Fixpoint.Horn.Types: instance GHC.Show.Show Language.Fixpoint.Horn.Types.Bind

- Language.Fixpoint.Horn.Types: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Horn.Types.Bind

- Language.Fixpoint.Horn.Types: instance Language.Fixpoint.Types.Refinements.Subable Language.Fixpoint.Horn.Types.Bind

- Language.Fixpoint.Misc: (<$$>) :: Monad m => (a -> m b) -> [a] -> m [b]

- Language.Fixpoint.Misc: pair :: a -> a -> [a]

- Language.Fixpoint.Misc: revMapM :: Monad m => (a -> m b) -> [a] -> m [b]

- Language.Fixpoint.Misc: singleton :: a -> [a]

- Language.Fixpoint.Misc: triple :: a -> a -> a -> [a]

- Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable (Language.Fixpoint.Types.Errors.FixResult GHC.Integer.Type.Integer)

- Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable (Language.Fixpoint.Types.Errors.FixResult GHC.Integer.Type.Integer, Language.Fixpoint.Types.Constraints.FixSolution)

- Language.Fixpoint.Parse: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => GHC.Show.Show (Language.Fixpoint.Parse.Def a)

- Language.Fixpoint.Smt.Interface: [ctxCin] :: Context -> !Handle

- Language.Fixpoint.Smt.Interface: [ctxCout] :: Context -> !Handle

- Language.Fixpoint.Smt.Types: [ctxCin] :: Context -> !Handle

- Language.Fixpoint.Smt.Types: [ctxCout] :: Context -> !Handle

- Language.Fixpoint.Solver.Extensionality: instance (Language.Fixpoint.Solver.Extensionality.Extend a, Language.Fixpoint.Solver.Extensionality.Extend b) => Language.Fixpoint.Solver.Extensionality.Extend (a, b)

- Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend (Language.Fixpoint.Types.Constraints.SInfo a)

- Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend (Language.Fixpoint.Types.Constraints.SimpC a)

- Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend Language.Fixpoint.Types.Constraints.SubcId

- Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend a => Language.Fixpoint.Solver.Extensionality.Extend (Data.HashMap.Internal.HashMap Language.Fixpoint.Types.Constraints.SubcId a)

- Language.Fixpoint.Solver.PLE: instance Language.Fixpoint.Solver.PLE.Simplifiable Language.Fixpoint.Types.Refinements.Expr

- Language.Fixpoint.Solver.Solution: instance Language.Fixpoint.Types.Spans.Loc Language.Fixpoint.Solver.Solution.CombinedEnv

- Language.Fixpoint.SortCheck: exprSort_maybe :: Expr -> Maybe Sort

- Language.Fixpoint.SortCheck: instance Language.Fixpoint.SortCheck.Elaborate Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Config.Eliminate

- Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Config.SMTSolver

- Language.Fixpoint.Types.Constraints: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Refinements.SortedReft

- Language.Fixpoint.Types.Constraints: instance Data.Store.Impl.Store Language.Fixpoint.Types.Config.Eliminate

- Language.Fixpoint.Types.Constraints: instance Data.Store.Impl.Store Language.Fixpoint.Types.Config.SMTSolver

- Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Text.PrettyPrint.HughesPJ.Doc

- Language.Fixpoint.Types.Environments: data SEnv a

- Language.Fixpoint.Types.Environments: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Environments: instance Data.Store.Impl.Store Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Environments: instance GHC.Base.Monoid Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Environments: instance GHC.Base.Semigroup Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Environments.EBindEnv

- Language.Fixpoint.Types.Errors: instance GHC.Exception.Type.Exception (Language.Fixpoint.Types.Errors.FixResult Language.Fixpoint.Types.Errors.Error)

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Gradual Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique Language.Fixpoint.Types.Environments.BindId

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique Language.Fixpoint.Types.Environments.IBindEnv

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique Language.Fixpoint.Types.Refinements.Expr

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique Language.Fixpoint.Types.Refinements.Reft

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique Language.Fixpoint.Types.Refinements.SortedReft

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique a => Language.Fixpoint.Types.Graduals.Unique (Data.HashMap.Internal.HashMap Language.Fixpoint.Types.Constraints.SubcId a)

- Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Spans.Loc a => Language.Fixpoint.Types.Graduals.Unique (Language.Fixpoint.Types.Constraints.SimpC a)

- Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint GHC.Integer.Type.Integer

- Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint GHC.Integer.Type.Integer

- Language.Fixpoint.Types.Refinements: data SymConst

- Language.Fixpoint.Types.Refinements: instance (GHC.Classes.Eq a, Data.Hashable.Class.Hashable a, Data.Binary.Class.Binary a) => Data.Binary.Class.Binary (Language.Fixpoint.Types.Sorts.TCEmb a)

- Language.Fixpoint.Types.Refinements: instance (GHC.Classes.Eq a, Data.Hashable.Class.Hashable a, Data.Store.Impl.Store a) => Data.Store.Impl.Store (Language.Fixpoint.Types.Sorts.TCEmb a)

- Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Spans.SrcSpan

- Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Sorts.TCArgs

- Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Spans.SrcSpan

- Language.Fixpoint.Types.Refinements: instance Data.Store.Impl.Store Language.Fixpoint.Types.Spans.SrcSpan

- Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Sorts.Sort

- Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Types.Sorts.TCEmb a)

- Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression GHC.Integer.Type.Integer

- Language.Fixpoint.Types.Sorts: instance (Data.Data.Data a, GHC.Classes.Eq a, Data.Hashable.Class.Hashable a) => Data.Data.Data (Language.Fixpoint.Types.Sorts.TCEmb a)

- Language.Fixpoint.Types.Visitor: (<$$>) :: Monad m => (a -> m b) -> [a] -> m [b]

- Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable (Language.Fixpoint.Types.Names.Symbol, Language.Fixpoint.Types.Refinements.SortedReft)

- Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable Language.Fixpoint.Types.Environments.BindEnv

- Language.Fixpoint.Utils.Trie: data Trie a

+ Language.Fixpoint.Defunctionalize: instance Language.Fixpoint.Defunctionalize.Defunc (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Graph.Types: newtype KVGraph

+ Language.Fixpoint.Horn.Types: [bMeta] :: Bind a -> !a

+ Language.Fixpoint.Horn.Types: instance Data.Data.Data a => Data.Data.Data (Language.Fixpoint.Horn.Types.Bind a)

+ Language.Fixpoint.Horn.Types: instance GHC.Base.Functor Language.Fixpoint.Horn.Types.Bind

+ Language.Fixpoint.Horn.Types: instance GHC.Classes.Eq a => GHC.Classes.Eq (Language.Fixpoint.Horn.Types.Bind a)

+ Language.Fixpoint.Horn.Types: instance GHC.Generics.Generic (Language.Fixpoint.Horn.Types.Bind a)

+ Language.Fixpoint.Horn.Types: instance GHC.Show.Show (Language.Fixpoint.Horn.Types.Bind a)

+ Language.Fixpoint.Horn.Types: instance Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Horn.Types.Bind a)

+ Language.Fixpoint.Horn.Types: instance Language.Fixpoint.Types.Refinements.Subable (Language.Fixpoint.Horn.Types.Bind a)

+ Language.Fixpoint.Misc: infixl 9 <<=

+ Language.Fixpoint.Parse: instance (Language.Fixpoint.Types.PrettyPrint.Fixpoint a, GHC.Show.Show a) => GHC.Show.Show (Language.Fixpoint.Parse.Def a)

+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable (Language.Fixpoint.Types.Errors.FixResult GHC.Num.Integer.Integer)

+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable (Language.Fixpoint.Types.Errors.FixResult GHC.Num.Integer.Integer, Language.Fixpoint.Types.Constraints.FixSolution)

+ Language.Fixpoint.Smt.Interface: [ctxIn] :: Context -> !Handle

+ Language.Fixpoint.Smt.Interface: [ctxOut] :: Context -> !Handle

+ Language.Fixpoint.Smt.Types: [ctxIn] :: Context -> !Handle

+ Language.Fixpoint.Smt.Types: [ctxOut] :: Context -> !Handle

+ Language.Fixpoint.Solver.Common: askSMT :: Config -> Context -> [(Symbol, Sort)] -> Expr -> IO Bool

+ Language.Fixpoint.Solver.Common: toSMT :: String -> Config -> Context -> [(Symbol, Sort)] -> Expr -> Pred

+ Language.Fixpoint.Solver.EnvironmentReduction: inlineInExpr :: (Symbol -> Maybe SortedReft) -> Expr -> Expr

+ Language.Fixpoint.Solver.EnvironmentReduction: undoANFAndVV :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)

+ Language.Fixpoint.Solver.EnvironmentReduction: undoANFSimplifyingWith :: (SortedReft -> SortedReft) -> Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v

+ Language.Fixpoint.Solver.Extensionality: instance (Language.Fixpoint.Solver.Extensionality.Extend ann a, Language.Fixpoint.Solver.Extensionality.Extend ann b) => Language.Fixpoint.Solver.Extensionality.Extend ann (a, b)

+ Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend a (Language.Fixpoint.Types.Constraints.SInfo a)

+ Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend a (Language.Fixpoint.Types.Constraints.SimpC a)

+ Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend ann Language.Fixpoint.Types.Constraints.SubcId

+ Language.Fixpoint.Solver.Extensionality: instance Language.Fixpoint.Solver.Extensionality.Extend ann a => Language.Fixpoint.Solver.Extensionality.Extend ann (Data.HashMap.Internal.HashMap Language.Fixpoint.Types.Constraints.SubcId a)

+ Language.Fixpoint.Solver.GradualSolve: solveGradual :: (NFData a, Fixpoint a) => Config -> SInfo a -> IO (Result (Integer, a))

+ Language.Fixpoint.Solver.Interpreter: ICtx :: HashSet Expr -> EvAccum -> HashSet Expr -> !ConstMap -> Maybe SubcId -> ICtx

+ Language.Fixpoint.Solver.Interpreter: KN :: HashMap (Symbol, Symbol) Rewrite -> HashMap Symbol Equation -> ![(Symbol, Sort)] -> ![(Symbol, Int)] -> !HashSet Symbol -> !HashSet Symbol -> !SelectorMap -> !ConstDCMap -> Knowledge

+ Language.Fixpoint.Solver.Interpreter: [icCands] :: ICtx -> HashSet Expr

+ Language.Fixpoint.Solver.Interpreter: [icEquals] :: ICtx -> EvAccum

+ Language.Fixpoint.Solver.Interpreter: [icSimpl] :: ICtx -> !ConstMap

+ Language.Fixpoint.Solver.Interpreter: [icSolved] :: ICtx -> HashSet Expr

+ Language.Fixpoint.Solver.Interpreter: [icSubcId] :: ICtx -> Maybe SubcId

+ Language.Fixpoint.Solver.Interpreter: [knAllDCs] :: Knowledge -> !HashSet Symbol

+ Language.Fixpoint.Solver.Interpreter: [knAms] :: Knowledge -> HashMap Symbol Equation

+ Language.Fixpoint.Solver.Interpreter: [knConsts] :: Knowledge -> !ConstDCMap

+ Language.Fixpoint.Solver.Interpreter: [knDCs] :: Knowledge -> !HashSet Symbol

+ Language.Fixpoint.Solver.Interpreter: [knLams] :: Knowledge -> ![(Symbol, Sort)]

+ Language.Fixpoint.Solver.Interpreter: [knSels] :: Knowledge -> !SelectorMap

+ Language.Fixpoint.Solver.Interpreter: [knSims] :: Knowledge -> HashMap (Symbol, Symbol) Rewrite

+ Language.Fixpoint.Solver.Interpreter: [knSummary] :: Knowledge -> ![(Symbol, Int)]

+ Language.Fixpoint.Solver.Interpreter: class Simplifiable a

+ Language.Fixpoint.Solver.Interpreter: data ICtx

+ Language.Fixpoint.Solver.Interpreter: data Knowledge

+ Language.Fixpoint.Solver.Interpreter: instInterpreter :: Loc a => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)

+ Language.Fixpoint.Solver.Interpreter: instance Language.Fixpoint.Solver.Interpreter.Normalizable (Language.Fixpoint.Types.Constraints.GInfo c a)

+ Language.Fixpoint.Solver.Interpreter: instance Language.Fixpoint.Solver.Interpreter.Normalizable Language.Fixpoint.Types.Constraints.AxiomEnv

+ Language.Fixpoint.Solver.Interpreter: instance Language.Fixpoint.Solver.Interpreter.Normalizable Language.Fixpoint.Types.Constraints.Equation

+ Language.Fixpoint.Solver.Interpreter: instance Language.Fixpoint.Solver.Interpreter.Normalizable Language.Fixpoint.Types.Constraints.Rewrite

+ Language.Fixpoint.Solver.Interpreter: instance Language.Fixpoint.Solver.Interpreter.Simplifiable Language.Fixpoint.Types.Refinements.Expr

+ Language.Fixpoint.Solver.Interpreter: interpret :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> Expr

+ Language.Fixpoint.Solver.Interpreter: simplify :: Simplifiable a => Knowledge -> ICtx -> a -> a

+ Language.Fixpoint.Solver.PLE: FC :: HashMap Symbol Int -> Maybe Int -> FuelCount

+ Language.Fixpoint.Solver.PLE: ICtx :: HashSet Pred -> HashSet Expr -> EvEqualities -> !ConstMap -> Maybe SubcId -> [[(Symbol, SortedReft)]] -> ICtx

+ Language.Fixpoint.Solver.PLE: KN :: Map Symbol [(Rewrite, IsUserDataSMeasure)] -> Map Symbol Equation -> Context -> (Context -> [(Symbol, Sort)] -> Expr -> IO Bool) -> ![(Symbol, Sort)] -> ![(Symbol, Int)] -> !HashSet Symbol -> !HashMap Symbol DataCtor -> !SelectorMap -> !ConstDCMap -> HashMap SubcId [AutoRewrite] -> RWTerminationOpts -> Knowledge

+ Language.Fixpoint.Solver.PLE: [fcMap] :: FuelCount -> HashMap Symbol Int

+ Language.Fixpoint.Solver.PLE: [fcMax] :: FuelCount -> Maybe Int

+ Language.Fixpoint.Solver.PLE: [icANFs] :: ICtx -> [[(Symbol, SortedReft)]]

+ Language.Fixpoint.Solver.PLE: [icAssms] :: ICtx -> HashSet Pred

+ Language.Fixpoint.Solver.PLE: [icCands] :: ICtx -> HashSet Expr

+ Language.Fixpoint.Solver.PLE: [icEquals] :: ICtx -> EvEqualities

+ Language.Fixpoint.Solver.PLE: [icSimpl] :: ICtx -> !ConstMap

+ Language.Fixpoint.Solver.PLE: [icSubcId] :: ICtx -> Maybe SubcId

+ Language.Fixpoint.Solver.PLE: [knAms] :: Knowledge -> Map Symbol Equation

+ Language.Fixpoint.Solver.PLE: [knAutoRWs] :: Knowledge -> HashMap SubcId [AutoRewrite]

+ Language.Fixpoint.Solver.PLE: [knConsts] :: Knowledge -> !ConstDCMap

+ Language.Fixpoint.Solver.PLE: [knContext] :: Knowledge -> Context

+ Language.Fixpoint.Solver.PLE: [knDCs] :: Knowledge -> !HashSet Symbol

+ Language.Fixpoint.Solver.PLE: [knDataCtors] :: Knowledge -> !HashMap Symbol DataCtor

+ Language.Fixpoint.Solver.PLE: [knLams] :: Knowledge -> ![(Symbol, Sort)]

+ Language.Fixpoint.Solver.PLE: [knPreds] :: Knowledge -> Context -> [(Symbol, Sort)] -> Expr -> IO Bool

+ Language.Fixpoint.Solver.PLE: [knRWTerminationOpts] :: Knowledge -> RWTerminationOpts

+ Language.Fixpoint.Solver.PLE: [knSels] :: Knowledge -> !SelectorMap

+ Language.Fixpoint.Solver.PLE: [knSims] :: Knowledge -> Map Symbol [(Rewrite, IsUserDataSMeasure)]

+ Language.Fixpoint.Solver.PLE: [knSummary] :: Knowledge -> ![(Symbol, Int)]

+ Language.Fixpoint.Solver.PLE: data FuelCount

+ Language.Fixpoint.Solver.PLE: data ICtx

+ Language.Fixpoint.Solver.PLE: data Knowledge

+ Language.Fixpoint.Solver.PLE: instance GHC.Classes.Eq Language.Fixpoint.Solver.PLE.IsUserDataSMeasure

+ Language.Fixpoint.Solver.PLE: instance GHC.Show.Show Language.Fixpoint.Solver.PLE.IsUserDataSMeasure

+ Language.Fixpoint.Solver.PLE: simplify :: Knowledge -> ICtx -> Expr -> Expr

+ Language.Fixpoint.Solver.Rewrite: RESTFuel :: Int -> RESTOrdering

+ Language.Fixpoint.Solver.Rewrite: RESTKBO :: RESTOrdering

+ Language.Fixpoint.Solver.Rewrite: RESTLPO :: RESTOrdering

+ Language.Fixpoint.Solver.Rewrite: RESTRPO :: RESTOrdering

+ Language.Fixpoint.Solver.Rewrite: data OCType

+ Language.Fixpoint.Solver.Rewrite: data RESTOrdering

+ Language.Fixpoint.Solver.Rewrite: instance Data.Hashable.Class.Hashable Language.Fixpoint.Solver.Rewrite.OCType

+ Language.Fixpoint.Solver.Rewrite: instance GHC.Classes.Eq Language.Fixpoint.Solver.Rewrite.OCType

+ Language.Fixpoint.Solver.Rewrite: instance GHC.Generics.Generic Language.Fixpoint.Solver.Rewrite.OCType

+ Language.Fixpoint.Solver.Rewrite: instance GHC.Show.Show Language.Fixpoint.Solver.Rewrite.OCType

+ Language.Fixpoint.Solver.Simplify: applyBooleanFolding :: Brel -> Expr -> Expr -> Expr

+ Language.Fixpoint.Solver.Simplify: applyConstantFolding :: Bop -> Expr -> Expr -> Expr

+ Language.Fixpoint.Solver.Simplify: applySetFolding :: Expr -> Expr -> Expr

+ Language.Fixpoint.Solver.Simplify: isSetPred :: Expr -> Bool

+ Language.Fixpoint.Solver.Solution: instance Language.Fixpoint.Types.Spans.Loc (Language.Fixpoint.Solver.Solution.CombinedEnv a)

+ Language.Fixpoint.SortCheck: elabApply :: SymEnv -> Expr -> Expr

+ Language.Fixpoint.SortCheck: elabExpr :: Located String -> SymEnv -> Expr -> Expr

+ Language.Fixpoint.SortCheck: elabNumeric :: Expr -> Expr

+ Language.Fixpoint.SortCheck: exprSortMaybe :: Expr -> Maybe Sort

+ Language.Fixpoint.SortCheck: instance Language.Fixpoint.Types.Spans.Loc a => Language.Fixpoint.SortCheck.Elaborate (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.SortCheck: unApply :: Expr -> Expr

+ Language.Fixpoint.SortCheck: unApplySortedReft :: SortedReft -> SortedReft

+ Language.Fixpoint.Types.Config: RESTFuel :: Int -> RESTOrdering

+ Language.Fixpoint.Types.Config: RESTKBO :: RESTOrdering

+ Language.Fixpoint.Types.Config: RESTLPO :: RESTOrdering

+ Language.Fixpoint.Types.Config: RESTRPO :: RESTOrdering

+ Language.Fixpoint.Types.Config: [interpreter] :: Config -> Bool

+ Language.Fixpoint.Types.Config: [pleWithUndecidedGuards] :: Config -> Bool

+ Language.Fixpoint.Types.Config: [restOrdering] :: Config -> String

+ Language.Fixpoint.Types.Config: data RESTOrdering

+ Language.Fixpoint.Types.Config: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Config.Eliminate

+ Language.Fixpoint.Types.Config: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Config.SMTSolver

+ Language.Fixpoint.Types.Config: instance Data.Data.Data Language.Fixpoint.Types.Config.RESTOrdering

+ Language.Fixpoint.Types.Config: instance Data.Store.Impl.Store Language.Fixpoint.Types.Config.Eliminate

+ Language.Fixpoint.Types.Config: instance Data.Store.Impl.Store Language.Fixpoint.Types.Config.SMTSolver

+ Language.Fixpoint.Types.Config: instance GHC.Classes.Eq Language.Fixpoint.Types.Config.RESTOrdering

+ Language.Fixpoint.Types.Config: instance GHC.Generics.Generic Language.Fixpoint.Types.Config.RESTOrdering

+ Language.Fixpoint.Types.Config: instance GHC.Read.Read Language.Fixpoint.Types.Config.RESTOrdering

+ Language.Fixpoint.Types.Config: instance GHC.Show.Show Language.Fixpoint.Types.Config.RESTOrdering

+ Language.Fixpoint.Types.Config: instance System.Console.CmdArgs.Default.Default Language.Fixpoint.Types.Config.RESTOrdering

+ Language.Fixpoint.Types.Config: restOC :: Config -> RESTOrdering

+ Language.Fixpoint.Types.Environments: SE :: HashMap Symbol a -> SEnv a

+ Language.Fixpoint.Types.Environments: [seBinds] :: SEnv a -> HashMap Symbol a

+ Language.Fixpoint.Types.Environments: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Environments: instance Data.Store.Impl.Store a => Data.Store.Impl.Store (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Environments: instance GHC.Base.Monoid (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Environments: instance GHC.Base.Semigroup (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Environments.EBindEnv a)

+ Language.Fixpoint.Types.Environments: newtype SEnv a

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Gradual (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique ann Language.Fixpoint.Types.Environments.BindId

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique ann Language.Fixpoint.Types.Environments.IBindEnv

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique ann Language.Fixpoint.Types.Refinements.Expr

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique ann Language.Fixpoint.Types.Refinements.Reft

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique ann Language.Fixpoint.Types.Refinements.SortedReft

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Graduals.Unique ann a => Language.Fixpoint.Types.Graduals.Unique ann (Data.HashMap.Internal.HashMap Language.Fixpoint.Types.Constraints.SubcId a)

+ Language.Fixpoint.Types.Graduals: instance Language.Fixpoint.Types.Spans.Loc a => Language.Fixpoint.Types.Graduals.Unique a (Language.Fixpoint.Types.Constraints.SimpC a)

+ Language.Fixpoint.Types.Names: isFixKey :: Text -> Bool

+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint GHC.Num.Integer.Integer

+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint GHC.Num.Integer.Integer

+ Language.Fixpoint.Types.Refinements: dropECst :: Expr -> Expr

+ Language.Fixpoint.Types.Refinements: eCst :: Expr -> Sort -> Expr

+ Language.Fixpoint.Types.Refinements: infixl 9 |.|

+ Language.Fixpoint.Types.Refinements: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Refinements.SortedReft

+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Text.PrettyPrint.HughesPJ.Doc

+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression GHC.Num.Integer.Integer

+ Language.Fixpoint.Types.Refinements: newtype SymConst

+ Language.Fixpoint.Types.Refinements: splitEAppThroughECst :: Expr -> (Expr, [Expr])

+ Language.Fixpoint.Types.Sorts: instance (Data.Data.Data a, Data.Hashable.Class.Hashable a) => Data.Data.Data (Language.Fixpoint.Types.Sorts.TCEmb a)

+ Language.Fixpoint.Types.Sorts: instance (GHC.Classes.Eq a, Data.Hashable.Class.Hashable a, Data.Binary.Class.Binary (Data.HashMap.Internal.HashMap a (Language.Fixpoint.Types.Sorts.Sort, Language.Fixpoint.Types.Sorts.TCArgs))) => Data.Binary.Class.Binary (Language.Fixpoint.Types.Sorts.TCEmb a)

+ Language.Fixpoint.Types.Sorts: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Sorts.TCArgs

+ Language.Fixpoint.Types.Sorts: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Sorts.Sort

+ Language.Fixpoint.Types.Sorts: instance Language.Fixpoint.Types.PrettyPrint.PPrint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Types.Sorts.TCEmb a)

+ Language.Fixpoint.Types.Spans: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Spans.SrcSpan

+ Language.Fixpoint.Types.Spans: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Spans.SrcSpan

+ Language.Fixpoint.Types.Spans: instance Data.Store.Impl.Store Language.Fixpoint.Types.Spans.SrcSpan

+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable (Language.Fixpoint.Types.Environments.BindEnv a)

+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable (Language.Fixpoint.Types.Names.Symbol, Language.Fixpoint.Types.Refinements.SortedReft, a)

+ Language.Fixpoint.Utils.Builder: infixl 9 <+>

+ Language.Fixpoint.Utils.Trie: newtype Trie a

- Language.Fixpoint.Horn.Types: All :: !Bind -> !Cstr a -> Cstr a

+ Language.Fixpoint.Horn.Types: All :: !Bind a -> !Cstr a -> Cstr a

- Language.Fixpoint.Horn.Types: Any :: !Bind -> !Cstr a -> Cstr a

+ Language.Fixpoint.Horn.Types: Any :: !Bind a -> !Cstr a -> Cstr a

- Language.Fixpoint.Horn.Types: Bind :: !Symbol -> !Sort -> !Pred -> Bind

+ Language.Fixpoint.Horn.Types: Bind :: !Symbol -> !Sort -> !Pred -> !a -> Bind a

- Language.Fixpoint.Horn.Types: Head :: !Pred -> a -> Cstr a

+ Language.Fixpoint.Horn.Types: Head :: !Pred -> !a -> Cstr a

- Language.Fixpoint.Horn.Types: [bPred] :: Bind -> !Pred

+ Language.Fixpoint.Horn.Types: [bPred] :: Bind a -> !Pred

- Language.Fixpoint.Horn.Types: [bSort] :: Bind -> !Sort

+ Language.Fixpoint.Horn.Types: [bSort] :: Bind a -> !Sort

- Language.Fixpoint.Horn.Types: [bSym] :: Bind -> !Symbol

+ Language.Fixpoint.Horn.Types: [bSym] :: Bind a -> !Symbol

- Language.Fixpoint.Horn.Types: data Bind

+ Language.Fixpoint.Horn.Types: data Bind a

- Language.Fixpoint.Solver.EnvironmentReduction: inlineInSortedReft :: HashMap Symbol (m, SortedReft) -> SortedReft -> SortedReft

+ Language.Fixpoint.Solver.EnvironmentReduction: inlineInSortedReft :: (Symbol -> Maybe SortedReft) -> SortedReft -> SortedReft

- Language.Fixpoint.Solver.EnvironmentReduction: undoANF :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)

+ Language.Fixpoint.Solver.EnvironmentReduction: undoANF :: Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v

- Language.Fixpoint.Solver.Monad: SS :: !Context -> !BindEnv -> !Stats -> SolverState

+ Language.Fixpoint.Solver.Monad: SS :: !Context -> !BindEnv ann -> !Stats -> SolverState ann

- Language.Fixpoint.Solver.Monad: [ssBinds] :: SolverState -> !BindEnv

+ Language.Fixpoint.Solver.Monad: [ssBinds] :: SolverState ann -> !BindEnv ann

- Language.Fixpoint.Solver.Monad: [ssCtx] :: SolverState -> !Context

+ Language.Fixpoint.Solver.Monad: [ssCtx] :: SolverState ann -> !Context

- Language.Fixpoint.Solver.Monad: [ssStats] :: SolverState -> !Stats

+ Language.Fixpoint.Solver.Monad: [ssStats] :: SolverState ann -> !Stats

- Language.Fixpoint.Solver.Monad: checkSat :: Expr -> SolveM Bool

+ Language.Fixpoint.Solver.Monad: checkSat :: Expr -> SolveM ann Bool

- Language.Fixpoint.Solver.Monad: data SolverState

+ Language.Fixpoint.Solver.Monad: data SolverState ann

- Language.Fixpoint.Solver.Monad: filterRequired :: Cand a -> Expr -> SolveM [a]

+ Language.Fixpoint.Solver.Monad: filterRequired :: Cand a -> Expr -> SolveM ann [a]

- Language.Fixpoint.Solver.Monad: filterValid :: SrcSpan -> Expr -> Cand a -> SolveM [a]

+ Language.Fixpoint.Solver.Monad: filterValid :: SrcSpan -> Expr -> Cand a -> SolveM ann [a]

- Language.Fixpoint.Solver.Monad: filterValidGradual :: [Expr] -> Cand a -> SolveM [a]

+ Language.Fixpoint.Solver.Monad: filterValidGradual :: [Expr] -> Cand a -> SolveM ann [a]

- Language.Fixpoint.Solver.Monad: getBinds :: SolveM BindEnv

+ Language.Fixpoint.Solver.Monad: getBinds :: SolveM ann (BindEnv ann)

- Language.Fixpoint.Solver.Monad: runSolverM :: Config -> SolverInfo b c -> SolveM a -> IO a

+ Language.Fixpoint.Solver.Monad: runSolverM :: Config -> SolverInfo ann c -> SolveM ann a -> IO a

- Language.Fixpoint.Solver.Monad: sendConcreteBindingsToSMT :: IBindEnv -> (IBindEnv -> SolveM a) -> SolveM a

+ Language.Fixpoint.Solver.Monad: sendConcreteBindingsToSMT :: IBindEnv -> (IBindEnv -> SolveM ann a) -> SolveM ann a

- Language.Fixpoint.Solver.Monad: smtEnablembqi :: SolveM ()

+ Language.Fixpoint.Solver.Monad: smtEnablembqi :: SolveM ann ()

- Language.Fixpoint.Solver.Monad: stats :: SolveM Stats

+ Language.Fixpoint.Solver.Monad: stats :: SolveM ann Stats

- Language.Fixpoint.Solver.Monad: tickIter :: Bool -> SolveM Int

+ Language.Fixpoint.Solver.Monad: tickIter :: Bool -> SolveM ann Int

- Language.Fixpoint.Solver.Monad: type SolveM = StateT SolverState IO

+ Language.Fixpoint.Solver.Monad: type SolveM ann = StateT (SolverState ann) IO

- Language.Fixpoint.Solver.Rewrite: getRewrite :: AbstractOC oc Expr IO -> RewriteArgs -> oc -> SubExpr -> AutoRewrite -> MaybeT IO (Expr, oc)

+ Language.Fixpoint.Solver.Rewrite: getRewrite :: OCAlgebra oc Expr IO -> RewriteArgs -> oc -> SubExpr -> AutoRewrite -> MaybeT IO ((Expr, Expr), Expr, oc)

- Language.Fixpoint.Solver.Rewrite: ordConstraints :: (Handle, Handle) -> AbstractOC (ConstraintsADT Op) Expr IO

+ Language.Fixpoint.Solver.Rewrite: ordConstraints :: RESTOrdering -> (Handle, Handle) -> OCAlgebra OCType RuntimeTerm IO

- Language.Fixpoint.Solver.Rewrite: passesTerminationCheck :: AbstractOC oc a IO -> RewriteArgs -> oc -> IO Bool

+ Language.Fixpoint.Solver.Rewrite: passesTerminationCheck :: OCAlgebra oc a IO -> RewriteArgs -> oc -> IO Bool

- Language.Fixpoint.Solver.Solution: lhsPred :: Loc a => IBindEnv -> BindEnv -> Solution -> SimpC a -> Expr

+ Language.Fixpoint.Solver.Solution: lhsPred :: Loc a => IBindEnv -> BindEnv a -> Solution -> SimpC a -> Expr

- Language.Fixpoint.Solver.Solution: nonCutsResult :: BindEnv -> Sol a QBind -> HashMap KVar Expr

+ Language.Fixpoint.Solver.Solution: nonCutsResult :: BindEnv ann -> Sol a QBind -> HashMap KVar Expr

- Language.Fixpoint.Solver.UniqifyBinds: renameAll :: SInfo a -> SInfo a

+ Language.Fixpoint.Solver.UniqifyBinds: renameAll :: NFData a => SInfo a -> SInfo a

- Language.Fixpoint.Types.Config: Config :: FilePath -> Maybe Int -> Int -> Int -> SMTSolver -> Bool -> Bool -> Bool -> Bool -> Bool -> Eliminate -> Maybe Int -> Maybe Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> [Integer] -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe Int -> Config

+ Language.Fixpoint.Types.Config: Config :: FilePath -> Maybe Int -> Int -> Int -> SMTSolver -> Bool -> Bool -> Bool -> Bool -> Bool -> Eliminate -> Maybe Int -> Maybe Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> [Integer] -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe Int -> String -> Config

- Language.Fixpoint.Types.Constraints: FI :: !HashMap SubcId (c a) -> !HashMap KVar (WfC a) -> !BindEnv -> ![BindId] -> !SEnv Sort -> !SEnv Sort -> !Kuts -> ![Qualifier] -> !HashMap BindId a -> ![DataDecl] -> !HOInfo -> ![Triggered Expr] -> AxiomEnv -> GInfo c a

+ Language.Fixpoint.Types.Constraints: FI :: !HashMap SubcId (c a) -> !HashMap KVar (WfC a) -> !BindEnv a -> ![BindId] -> !SEnv Sort -> !SEnv Sort -> !Kuts -> ![Qualifier] -> !HashMap BindId a -> ![DataDecl] -> !HOInfo -> ![Triggered Expr] -> AxiomEnv -> GInfo c a

- Language.Fixpoint.Types.Constraints: [bs] :: GInfo c a -> !BindEnv

+ Language.Fixpoint.Types.Constraints: [bs] :: GInfo c a -> !BindEnv a

- Language.Fixpoint.Types.Constraints: clhs :: TaggedC c a => BindEnv -> c a -> [(Symbol, SortedReft)]

+ Language.Fixpoint.Types.Constraints: clhs :: TaggedC c a => BindEnv a -> c a -> [(Symbol, SortedReft)]

- Language.Fixpoint.Types.Constraints: fi :: [SubC a] -> [WfC a] -> BindEnv -> SEnv Sort -> SEnv Sort -> Kuts -> [Qualifier] -> HashMap BindId a -> Bool -> Bool -> [Triggered Expr] -> AxiomEnv -> [DataDecl] -> [BindId] -> GInfo SubC a

+ Language.Fixpoint.Types.Constraints: fi :: [SubC a] -> [WfC a] -> BindEnv a -> SEnv Sort -> SEnv Sort -> Kuts -> [Qualifier] -> HashMap BindId a -> Bool -> Bool -> [Triggered Expr] -> AxiomEnv -> [DataDecl] -> [BindId] -> GInfo SubC a

- Language.Fixpoint.Types.Environments: adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv

+ Language.Fixpoint.Types.Environments: adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv a -> BindEnv a

- Language.Fixpoint.Types.Environments: bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv

+ Language.Fixpoint.Types.Environments: bindEnvFromList :: [(BindId, (Symbol, SortedReft, a))] -> BindEnv a

- Language.Fixpoint.Types.Environments: bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)]

+ Language.Fixpoint.Types.Environments: bindEnvToList :: BindEnv a -> [(BindId, (Symbol, SortedReft, a))]

- Language.Fixpoint.Types.Environments: data EBindEnv

+ Language.Fixpoint.Types.Environments: data EBindEnv a

- Language.Fixpoint.Types.Environments: deleteBindEnv :: BindId -> BindEnv -> BindEnv

+ Language.Fixpoint.Types.Environments: deleteBindEnv :: BindId -> BindEnv a -> BindEnv a

- Language.Fixpoint.Types.Environments: elemsBindEnv :: BindEnv -> [BindId]

+ Language.Fixpoint.Types.Environments: elemsBindEnv :: BindEnv a -> [BindId]

- Language.Fixpoint.Types.Environments: emptyBindEnv :: BindEnv

+ Language.Fixpoint.Types.Environments: emptyBindEnv :: BindEnv a

- Language.Fixpoint.Types.Environments: envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)]

+ Language.Fixpoint.Types.Environments: envCs :: BindEnv a -> IBindEnv -> [(Symbol, SortedReft)]

- Language.Fixpoint.Types.Environments: filterBindEnv :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv -> BindEnv

+ Language.Fixpoint.Types.Environments: filterBindEnv :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv a -> BindEnv a

- Language.Fixpoint.Types.Environments: fromListBindEnv :: [(BindId, (Symbol, SortedReft))] -> BindEnv

+ Language.Fixpoint.Types.Environments: fromListBindEnv :: [(BindId, (Symbol, SortedReft, a))] -> BindEnv a

- Language.Fixpoint.Types.Environments: insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv)

+ Language.Fixpoint.Types.Environments: insertBindEnv :: Symbol -> SortedReft -> a -> BindEnv a -> (BindId, BindEnv a)

- Language.Fixpoint.Types.Environments: lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft)

+ Language.Fixpoint.Types.Environments: lookupBindEnv :: BindId -> BindEnv a -> (Symbol, SortedReft, a)

- Language.Fixpoint.Types.Environments: mapBindEnv :: (BindId -> (Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv

+ Language.Fixpoint.Types.Environments: mapBindEnv :: (BindId -> (Symbol, SortedReft, a) -> (Symbol, SortedReft, a)) -> BindEnv a -> BindEnv a

- Language.Fixpoint.Types.Environments: mapWithKeyMBindEnv :: Monad m => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv -> m BindEnv

+ Language.Fixpoint.Types.Environments: mapWithKeyMBindEnv :: Monad m => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv a -> m (BindEnv a)

- Language.Fixpoint.Types.Environments: splitByQuantifiers :: BindEnv -> [BindId] -> (BindEnv, EBindEnv)

+ Language.Fixpoint.Types.Environments: splitByQuantifiers :: BindEnv a -> [BindId] -> (BindEnv a, EBindEnv a)

- Language.Fixpoint.Types.Environments: type BindEnv = SizedEnv (Symbol, SortedReft)

+ Language.Fixpoint.Types.Environments: type BindEnv a = SizedEnv (Symbol, SortedReft, a)

- Language.Fixpoint.Types.Errors: Crash :: [a] -> String -> FixResult a

+ Language.Fixpoint.Types.Errors: Crash :: [(a, Maybe String)] -> String -> FixResult a

- Language.Fixpoint.Types.Refinements: SL :: !Text -> SymConst

+ Language.Fixpoint.Types.Refinements: SL :: Text -> SymConst

- Language.Fixpoint.Types.Visitor: envKVars :: TaggedC c a => BindEnv -> c a -> [KVar]

+ Language.Fixpoint.Types.Visitor: envKVars :: TaggedC c a => BindEnv a -> c a -> [KVar]

- Language.Fixpoint.Types.Visitor: envKVarsN :: TaggedC c a => BindEnv -> c a -> [(KVar, Int)]

+ Language.Fixpoint.Types.Visitor: envKVarsN :: TaggedC c a => BindEnv a -> c a -> [(KVar, Int)]

- Language.Fixpoint.Utils.Trie: Node :: ![Branch a] -> Trie a

+ Language.Fixpoint.Utils.Trie: Node :: [Branch a] -> Trie a

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

Files

.circleci/config.yml +0/−53
.ghci +0/−1
CHANGES.md +0/−47
README.md +0/−366
TODO.md +0/−2
bin/Fixpoint.hs +11/−11
default.nix +0/−52
dist/build/Data/ShareMap.dyn_hi binary
dist/build/Data/ShareMap.dyn_o binary
dist/build/Data/ShareMap.hi binary
dist/build/Data/ShareMap.o binary
dist/build/Language/Fixpoint/Defunctionalize.dyn_hi binary
dist/build/Language/Fixpoint/Defunctionalize.dyn_o binary
dist/build/Language/Fixpoint/Defunctionalize.hi binary
dist/build/Language/Fixpoint/Defunctionalize.o binary
dist/build/Language/Fixpoint/Graph.dyn_hi binary
dist/build/Language/Fixpoint/Graph.dyn_o binary
dist/build/Language/Fixpoint/Graph.hi binary
dist/build/Language/Fixpoint/Graph.o binary
dist/build/Language/Fixpoint/Graph/Deps.dyn_hi binary
dist/build/Language/Fixpoint/Graph/Deps.dyn_o binary
dist/build/Language/Fixpoint/Graph/Deps.hi binary
dist/build/Language/Fixpoint/Graph/Deps.o binary
dist/build/Language/Fixpoint/Graph/Indexed.dyn_hi binary
dist/build/Language/Fixpoint/Graph/Indexed.dyn_o binary
dist/build/Language/Fixpoint/Graph/Indexed.hi binary
dist/build/Language/Fixpoint/Graph/Indexed.o binary
dist/build/Language/Fixpoint/Graph/Partition.dyn_hi binary
dist/build/Language/Fixpoint/Graph/Partition.dyn_o binary
dist/build/Language/Fixpoint/Graph/Partition.hi binary
dist/build/Language/Fixpoint/Graph/Partition.o binary
dist/build/Language/Fixpoint/Graph/Reducible.dyn_hi binary
dist/build/Language/Fixpoint/Graph/Reducible.dyn_o binary
dist/build/Language/Fixpoint/Graph/Reducible.hi binary
dist/build/Language/Fixpoint/Graph/Reducible.o binary
dist/build/Language/Fixpoint/Graph/Types.dyn_hi binary
dist/build/Language/Fixpoint/Graph/Types.dyn_o binary
dist/build/Language/Fixpoint/Graph/Types.hi binary
dist/build/Language/Fixpoint/Graph/Types.o binary
dist/build/Language/Fixpoint/Horn/Info.dyn_hi binary
dist/build/Language/Fixpoint/Horn/Info.dyn_o binary
dist/build/Language/Fixpoint/Horn/Info.hi binary
dist/build/Language/Fixpoint/Horn/Info.o binary
dist/build/Language/Fixpoint/Horn/Parse.dyn_hi binary
dist/build/Language/Fixpoint/Horn/Parse.dyn_o binary
dist/build/Language/Fixpoint/Horn/Parse.hi binary
dist/build/Language/Fixpoint/Horn/Parse.o binary
dist/build/Language/Fixpoint/Horn/Solve.dyn_hi binary
dist/build/Language/Fixpoint/Horn/Solve.dyn_o binary
dist/build/Language/Fixpoint/Horn/Solve.hi binary
dist/build/Language/Fixpoint/Horn/Solve.o binary
dist/build/Language/Fixpoint/Horn/Transformations.dyn_hi binary
dist/build/Language/Fixpoint/Horn/Transformations.dyn_o binary
dist/build/Language/Fixpoint/Horn/Transformations.hi binary
dist/build/Language/Fixpoint/Horn/Transformations.o binary
dist/build/Language/Fixpoint/Horn/Types.dyn_hi binary
dist/build/Language/Fixpoint/Horn/Types.dyn_o binary
dist/build/Language/Fixpoint/Horn/Types.hi binary
dist/build/Language/Fixpoint/Horn/Types.o binary
dist/build/Language/Fixpoint/Minimize.dyn_hi binary
dist/build/Language/Fixpoint/Minimize.dyn_o binary
dist/build/Language/Fixpoint/Minimize.hi binary
dist/build/Language/Fixpoint/Minimize.o binary
dist/build/Language/Fixpoint/Misc.dyn_hi binary
dist/build/Language/Fixpoint/Misc.dyn_o binary
dist/build/Language/Fixpoint/Misc.hi binary
dist/build/Language/Fixpoint/Misc.o binary
dist/build/Language/Fixpoint/Parse.dyn_hi binary
dist/build/Language/Fixpoint/Parse.dyn_o too large to diff
dist/build/Language/Fixpoint/Parse.hi binary
dist/build/Language/Fixpoint/Parse.o too large to diff
dist/build/Language/Fixpoint/Smt/Bitvector.dyn_hi binary
dist/build/Language/Fixpoint/Smt/Bitvector.dyn_o binary
dist/build/Language/Fixpoint/Smt/Bitvector.hi binary
dist/build/Language/Fixpoint/Smt/Bitvector.o binary
dist/build/Language/Fixpoint/Smt/Interface.dyn_hi binary
dist/build/Language/Fixpoint/Smt/Interface.dyn_o binary
dist/build/Language/Fixpoint/Smt/Interface.hi binary
dist/build/Language/Fixpoint/Smt/Interface.o binary
dist/build/Language/Fixpoint/Smt/Serialize.dyn_hi binary
dist/build/Language/Fixpoint/Smt/Serialize.dyn_o binary
dist/build/Language/Fixpoint/Smt/Serialize.hi binary
dist/build/Language/Fixpoint/Smt/Serialize.o binary
dist/build/Language/Fixpoint/Smt/Theories.dyn_hi binary
dist/build/Language/Fixpoint/Smt/Theories.dyn_o binary
dist/build/Language/Fixpoint/Smt/Theories.hi binary
dist/build/Language/Fixpoint/Smt/Theories.o binary
dist/build/Language/Fixpoint/Smt/Types.dyn_hi binary
dist/build/Language/Fixpoint/Smt/Types.dyn_o binary
dist/build/Language/Fixpoint/Smt/Types.hi binary
dist/build/Language/Fixpoint/Smt/Types.o binary
dist/build/Language/Fixpoint/Solver.dyn_hi binary
dist/build/Language/Fixpoint/Solver.dyn_o binary
dist/build/Language/Fixpoint/Solver.hi binary
dist/build/Language/Fixpoint/Solver.o binary
dist/build/Language/Fixpoint/Solver/Eliminate.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Eliminate.dyn_o binary
dist/build/Language/Fixpoint/Solver/Eliminate.hi binary
dist/build/Language/Fixpoint/Solver/Eliminate.o binary
dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_hi binary
dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_o binary
dist/build/Language/Fixpoint/Solver/EnvironmentReduction.hi binary
dist/build/Language/Fixpoint/Solver/EnvironmentReduction.o binary
dist/build/Language/Fixpoint/Solver/Extensionality.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Extensionality.dyn_o binary
dist/build/Language/Fixpoint/Solver/Extensionality.hi binary
dist/build/Language/Fixpoint/Solver/Extensionality.o binary
dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_hi binary
dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_o binary
dist/build/Language/Fixpoint/Solver/GradualSolution.hi binary
dist/build/Language/Fixpoint/Solver/GradualSolution.o binary
dist/build/Language/Fixpoint/Solver/Instantiate.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Instantiate.dyn_o binary
dist/build/Language/Fixpoint/Solver/Instantiate.hi binary
dist/build/Language/Fixpoint/Solver/Instantiate.o binary
dist/build/Language/Fixpoint/Solver/Monad.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Monad.dyn_o binary
dist/build/Language/Fixpoint/Solver/Monad.hi binary
dist/build/Language/Fixpoint/Solver/Monad.o binary
dist/build/Language/Fixpoint/Solver/PLE.dyn_hi binary
dist/build/Language/Fixpoint/Solver/PLE.dyn_o binary
dist/build/Language/Fixpoint/Solver/PLE.hi binary
dist/build/Language/Fixpoint/Solver/PLE.o binary
dist/build/Language/Fixpoint/Solver/Prettify.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Prettify.dyn_o binary
dist/build/Language/Fixpoint/Solver/Prettify.hi binary
dist/build/Language/Fixpoint/Solver/Prettify.o binary
dist/build/Language/Fixpoint/Solver/Rewrite.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Rewrite.dyn_o binary
dist/build/Language/Fixpoint/Solver/Rewrite.hi binary
dist/build/Language/Fixpoint/Solver/Rewrite.o binary
dist/build/Language/Fixpoint/Solver/Sanitize.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Sanitize.dyn_o binary
dist/build/Language/Fixpoint/Solver/Sanitize.hi binary
dist/build/Language/Fixpoint/Solver/Sanitize.o binary
dist/build/Language/Fixpoint/Solver/Solution.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Solution.dyn_o binary
dist/build/Language/Fixpoint/Solver/Solution.hi binary
dist/build/Language/Fixpoint/Solver/Solution.o binary
dist/build/Language/Fixpoint/Solver/Solve.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Solve.dyn_o binary
dist/build/Language/Fixpoint/Solver/Solve.hi binary
dist/build/Language/Fixpoint/Solver/Solve.o binary
dist/build/Language/Fixpoint/Solver/Stats.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Stats.dyn_o binary
dist/build/Language/Fixpoint/Solver/Stats.hi binary
dist/build/Language/Fixpoint/Solver/Stats.o binary
dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_hi binary
dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_o binary
dist/build/Language/Fixpoint/Solver/TrivialSort.hi binary
dist/build/Language/Fixpoint/Solver/TrivialSort.o binary
dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_hi binary
dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_o binary
dist/build/Language/Fixpoint/Solver/UniqifyBinds.hi binary
dist/build/Language/Fixpoint/Solver/UniqifyBinds.o binary
dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_hi binary
dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_o binary
dist/build/Language/Fixpoint/Solver/UniqifyKVars.hi binary
dist/build/Language/Fixpoint/Solver/UniqifyKVars.o binary
dist/build/Language/Fixpoint/Solver/Worklist.dyn_hi binary
dist/build/Language/Fixpoint/Solver/Worklist.dyn_o binary
dist/build/Language/Fixpoint/Solver/Worklist.hi binary
dist/build/Language/Fixpoint/Solver/Worklist.o binary
dist/build/Language/Fixpoint/SortCheck.dyn_hi binary
dist/build/Language/Fixpoint/SortCheck.dyn_o binary
dist/build/Language/Fixpoint/SortCheck.hi binary
dist/build/Language/Fixpoint/SortCheck.o binary
dist/build/Language/Fixpoint/Types.dyn_hi binary
dist/build/Language/Fixpoint/Types.dyn_o binary
dist/build/Language/Fixpoint/Types.hi binary
dist/build/Language/Fixpoint/Types.o binary
dist/build/Language/Fixpoint/Types/Config.dyn_hi binary
dist/build/Language/Fixpoint/Types/Config.dyn_o binary
dist/build/Language/Fixpoint/Types/Config.hi binary
dist/build/Language/Fixpoint/Types/Config.o binary
dist/build/Language/Fixpoint/Types/Constraints.dyn_hi binary
dist/build/Language/Fixpoint/Types/Constraints.dyn_o binary
dist/build/Language/Fixpoint/Types/Constraints.hi binary
dist/build/Language/Fixpoint/Types/Constraints.o binary
dist/build/Language/Fixpoint/Types/Environments.dyn_hi binary
dist/build/Language/Fixpoint/Types/Environments.dyn_o binary
dist/build/Language/Fixpoint/Types/Environments.hi binary
dist/build/Language/Fixpoint/Types/Environments.o binary
dist/build/Language/Fixpoint/Types/Errors.dyn_hi binary
dist/build/Language/Fixpoint/Types/Errors.dyn_o binary
dist/build/Language/Fixpoint/Types/Errors.hi binary
dist/build/Language/Fixpoint/Types/Errors.o binary
dist/build/Language/Fixpoint/Types/Graduals.dyn_hi binary
dist/build/Language/Fixpoint/Types/Graduals.dyn_o binary
dist/build/Language/Fixpoint/Types/Graduals.hi binary
dist/build/Language/Fixpoint/Types/Graduals.o binary
dist/build/Language/Fixpoint/Types/Names.dyn_hi binary
dist/build/Language/Fixpoint/Types/Names.dyn_o binary
dist/build/Language/Fixpoint/Types/Names.hi binary
dist/build/Language/Fixpoint/Types/Names.o binary
dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_hi binary
dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_o binary
dist/build/Language/Fixpoint/Types/PrettyPrint.hi binary
dist/build/Language/Fixpoint/Types/PrettyPrint.o binary
dist/build/Language/Fixpoint/Types/Refinements.dyn_hi binary
dist/build/Language/Fixpoint/Types/Refinements.dyn_o binary
dist/build/Language/Fixpoint/Types/Refinements.hi binary
dist/build/Language/Fixpoint/Types/Refinements.o binary
dist/build/Language/Fixpoint/Types/Solutions.dyn_hi binary
dist/build/Language/Fixpoint/Types/Solutions.dyn_o binary
dist/build/Language/Fixpoint/Types/Solutions.hi binary
dist/build/Language/Fixpoint/Types/Solutions.o binary
dist/build/Language/Fixpoint/Types/Sorts.dyn_hi binary
dist/build/Language/Fixpoint/Types/Sorts.dyn_o binary
dist/build/Language/Fixpoint/Types/Sorts.hi binary
dist/build/Language/Fixpoint/Types/Sorts.o binary
dist/build/Language/Fixpoint/Types/Spans.dyn_hi binary
dist/build/Language/Fixpoint/Types/Spans.dyn_o binary
dist/build/Language/Fixpoint/Types/Spans.hi binary
dist/build/Language/Fixpoint/Types/Spans.o binary
dist/build/Language/Fixpoint/Types/Substitutions.dyn_hi binary
dist/build/Language/Fixpoint/Types/Substitutions.dyn_o binary
dist/build/Language/Fixpoint/Types/Substitutions.hi binary
dist/build/Language/Fixpoint/Types/Substitutions.o binary
dist/build/Language/Fixpoint/Types/Templates.dyn_hi binary
dist/build/Language/Fixpoint/Types/Templates.dyn_o binary
dist/build/Language/Fixpoint/Types/Templates.hi binary
dist/build/Language/Fixpoint/Types/Templates.o binary
dist/build/Language/Fixpoint/Types/Theories.dyn_hi binary
dist/build/Language/Fixpoint/Types/Theories.dyn_o binary
dist/build/Language/Fixpoint/Types/Theories.hi binary
dist/build/Language/Fixpoint/Types/Theories.o binary
dist/build/Language/Fixpoint/Types/Triggers.dyn_hi binary
dist/build/Language/Fixpoint/Types/Triggers.dyn_o binary
dist/build/Language/Fixpoint/Types/Triggers.hi binary
dist/build/Language/Fixpoint/Types/Triggers.o binary
dist/build/Language/Fixpoint/Types/Utils.dyn_hi binary
dist/build/Language/Fixpoint/Types/Utils.dyn_o binary
dist/build/Language/Fixpoint/Types/Utils.hi binary
dist/build/Language/Fixpoint/Types/Utils.o binary
dist/build/Language/Fixpoint/Types/Visitor.dyn_hi binary
dist/build/Language/Fixpoint/Types/Visitor.dyn_o binary
dist/build/Language/Fixpoint/Types/Visitor.hi binary
dist/build/Language/Fixpoint/Types/Visitor.o binary
dist/build/Language/Fixpoint/Utils/Builder.dyn_hi binary
dist/build/Language/Fixpoint/Utils/Builder.dyn_o binary
dist/build/Language/Fixpoint/Utils/Builder.hi binary
dist/build/Language/Fixpoint/Utils/Builder.o binary
dist/build/Language/Fixpoint/Utils/Files.dyn_hi binary
dist/build/Language/Fixpoint/Utils/Files.dyn_o binary
dist/build/Language/Fixpoint/Utils/Files.hi binary
dist/build/Language/Fixpoint/Utils/Files.o binary
dist/build/Language/Fixpoint/Utils/Progress.dyn_hi binary
dist/build/Language/Fixpoint/Utils/Progress.dyn_o binary
dist/build/Language/Fixpoint/Utils/Progress.hi binary
dist/build/Language/Fixpoint/Utils/Progress.o binary
dist/build/Language/Fixpoint/Utils/Statistics.dyn_hi binary
dist/build/Language/Fixpoint/Utils/Statistics.dyn_o binary
dist/build/Language/Fixpoint/Utils/Statistics.hi binary
dist/build/Language/Fixpoint/Utils/Statistics.o binary
dist/build/Language/Fixpoint/Utils/Trie.dyn_hi binary
dist/build/Language/Fixpoint/Utils/Trie.dyn_o binary
dist/build/Language/Fixpoint/Utils/Trie.hi binary
dist/build/Language/Fixpoint/Utils/Trie.o binary
dist/build/Paths_liquid_fixpoint.dyn_hi binary
dist/build/Paths_liquid_fixpoint.dyn_o binary
dist/build/Paths_liquid_fixpoint.hi binary
dist/build/Paths_liquid_fixpoint.o binary
dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_hi binary
dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_o binary
dist/build/Text/PrettyPrint/HughesPJ/Compat.hi binary
dist/build/Text/PrettyPrint/HughesPJ/Compat.o binary
dist/build/autogen/Paths_liquid_fixpoint.hs +0/−50
dist/build/autogen/cabal_macros.h +0/−495
dist/build/fixpoint/autogen/Paths_liquid_fixpoint.hs +0/−50
dist/build/fixpoint/autogen/cabal_macros.h +0/−162
dist/build/fixpoint/fixpoint too large to diff
dist/build/fixpoint/fixpoint-tmp/Main.hi binary
dist/build/fixpoint/fixpoint-tmp/Main.o binary
dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-ghc9.0.1.dylib too large to diff
dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.a too large to diff
dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM-ghc9.0.1.dylib too large to diff
dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM.a too large to diff
dist/package.conf.inplace/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.conf +0/−126
dist/package.conf.inplace/package.cache binary
dist/package.conf.inplace/package.cache.lock +0/−0
dist/setup-config binary
git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch +0/−13
hie.yaml +0/−8
liquid-fixpoint.cabal +70/−44
scripts/travis +0/−137
shell.nix +0/−1
src/Language/Fixpoint/Congruence/Closure.hs +0/−67
src/Language/Fixpoint/Congruence/Types.hs +0/−100
src/Language/Fixpoint/Defunctionalize.hs +33/−34
src/Language/Fixpoint/Graph/Deps.hs +11/−16
src/Language/Fixpoint/Graph/Indexed.hs +0/−1
src/Language/Fixpoint/Graph/Partition.hs +8/−14
src/Language/Fixpoint/Graph/Reducible.hs +6/−4
src/Language/Fixpoint/Graph/Types.hs +2/−2
src/Language/Fixpoint/Horn/Info.hs +47/−35
src/Language/Fixpoint/Horn/Parse.hs +8/−11
src/Language/Fixpoint/Horn/Solve.hs +5/−4
src/Language/Fixpoint/Horn/Transformations.hs +81/−71
src/Language/Fixpoint/Horn/Types.hs +84/−81
src/Language/Fixpoint/Minimize.hs +10/−7
src/Language/Fixpoint/Misc.hs +29/−52
src/Language/Fixpoint/Parse.hs +46/−51
src/Language/Fixpoint/Smt/Bitvector.hs +2/−1
src/Language/Fixpoint/Smt/Interface.hs +57/−62
src/Language/Fixpoint/Smt/Serialize.hs +21/−22
src/Language/Fixpoint/Smt/Theories.hs +137/−38
src/Language/Fixpoint/Smt/Types.hs +10/−7
src/Language/Fixpoint/Solver.hs +54/−32
src/Language/Fixpoint/Solver/Common.hs +34/−0
src/Language/Fixpoint/Solver/Eliminate.hs +3/−2
src/Language/Fixpoint/Solver/EnvironmentReduction.hs +112/−81
src/Language/Fixpoint/Solver/Extensionality.hs +138/−132
src/Language/Fixpoint/Solver/GradualSolution.hs +19/−19
src/Language/Fixpoint/Solver/GradualSolve.hs +0/−3
src/Language/Fixpoint/Solver/Instantiate.hs +232/−242
src/Language/Fixpoint/Solver/Interpreter.hs +733/−0
src/Language/Fixpoint/Solver/Monad.hs +27/−28
src/Language/Fixpoint/Solver/PLE.hs +1214/−1163
src/Language/Fixpoint/Solver/Prettify.hs +28/−22
src/Language/Fixpoint/Solver/Rewrite.hs +155/−65
src/Language/Fixpoint/Solver/Sanitize.hs +44/−40
src/Language/Fixpoint/Solver/Simplify.hs +163/−0
src/Language/Fixpoint/Solver/Solution.hs +97/−114
src/Language/Fixpoint/Solver/Solve.hs +60/−31
src/Language/Fixpoint/Solver/Stats.hs +2/−6
src/Language/Fixpoint/Solver/TrivialSort.hs +8/−6
src/Language/Fixpoint/Solver/UniqifyBinds.hs +28/−25
src/Language/Fixpoint/Solver/UniqifyKVars.hs +15/−12
src/Language/Fixpoint/Solver/Worklist.hs +0/−1
src/Language/Fixpoint/SortCheck.hs +168/−160
src/Language/Fixpoint/Types/Binary.hs +0/−8
src/Language/Fixpoint/Types/Config.hs +60/−7
src/Language/Fixpoint/Types/Constraints.hs +91/−99
src/Language/Fixpoint/Types/Environments.hs +49/−46
src/Language/Fixpoint/Types/Errors.hs +18/−33
src/Language/Fixpoint/Types/Graduals.hs +41/−47
src/Language/Fixpoint/Types/Names.hs +10/−16
src/Language/Fixpoint/Types/PrettyPrint.hs +1/−5
src/Language/Fixpoint/Types/Refinements.hs +54/−42
src/Language/Fixpoint/Types/Solutions.hs +37/−39
src/Language/Fixpoint/Types/Sorts.hs +58/−52
src/Language/Fixpoint/Types/Spans.hs +10/−5
src/Language/Fixpoint/Types/Substitutions.hs +7/−9
src/Language/Fixpoint/Types/Templates.hs +49/−49
src/Language/Fixpoint/Types/Theories.hs +15/−15
src/Language/Fixpoint/Types/Triggers.hs +4/−5
src/Language/Fixpoint/Types/Utils.hs +15/−15
src/Language/Fixpoint/Types/Visitor.hs +95/−95
src/Language/Fixpoint/Utils/Builder.hs +3/−1
src/Language/Fixpoint/Utils/Files.hs +1/−1
src/Language/Fixpoint/Utils/Trie.hs +34/−34
stack.yaml +0/−20
tests/crash/EqConstr0.fq +0/−9
tests/crash/EqConstr1.fq +0/−12
tests/crash/num00.fq +0/−29
tests/crash/sort00.fq +0/−12
tests/crash/sort01.fq +0/−13
tests/cut/test00-tx.fq +0/−12
tests/cut/test00.fq +0/−28
tests/cut/test00a-tx.fq +0/−43
tests/cut/test00a.fq +0/−29
tests/cut/test1-tx.fq +0/−43
tests/cut/test1.fq +0/−29
tests/cut/test2-tx.fq +0/−112
tests/cut/test2.fq +0/−51
tests/elim/div00.fq +0/−23
tests/elim/elim00.fq +0/−1494
tests/elim/kvparam00.fq +0/−20
tests/elim/len00.fq +0/−23
tests/elim/test00-tx.fq +0/−12
tests/elim/test00.fq +0/−26
tests/elim/test00a.fq +0/−28
tests/elim/test1.fq +0/−29
tests/elim/test2.fq +0/−53
tests/elim/tuple00.fq +0/−114
tests/elim/tuple01.fq +0/−137
tests/horn/neg/abs02-re.smt2 +0/−29
tests/horn/neg/ebind03.smt2 +0/−16
tests/horn/neg/irregular_adt_00.smt2 +0/−36
tests/horn/neg/ple0.smt2 +0/−13
tests/horn/neg/ple_list00.smt2 +0/−12
tests/horn/neg/ple_list01_adt.smt2 +0/−22
tests/horn/neg/ple_list03.smt2 +0/−45
tests/horn/neg/ple_sum.smt2 +0/−12
tests/horn/neg/ple_sum_fuel.5.smt2 +0/−14
tests/horn/neg/tag00.smt2 +0/−16
tests/horn/neg/test00.smt2 +0/−10
tests/horn/neg/test01.smt2 +0/−16
tests/horn/neg/test02.smt2 +0/−18
tests/horn/neg/test03.smt2 +0/−24
tests/horn/pos/abs02-re.smt2 +0/−13
tests/horn/pos/constant.smt2 +0/−13
tests/horn/pos/ebind01.smt2 +0/−6
tests/horn/pos/ebind02.smt2 +0/−11
tests/horn/pos/ebind03.smt2 +0/−14
tests/horn/pos/icfp17-ex1.smt2 +0/−14
tests/horn/pos/icfp17-ex2.smt2 +0/−19
tests/horn/pos/icfp17-ex3.smt2 +0/−16
tests/horn/pos/ple0.smt2 +0/−13
tests/horn/pos/ple_list00.smt2 too large to diff
tests/horn/pos/ple_list01_adt.smt2 too large to diff
tests/horn/pos/ple_sum.smt2 too large to diff
tests/horn/pos/ple_sum_fuel.5.smt2 too large to diff
tests/horn/pos/sum-rec-ok.smt2 too large to diff
tests/horn/pos/sum-rec.smt2 too large to diff
tests/horn/pos/test00.smt2 too large to diff
tests/horn/pos/test01.smt2 too large to diff
tests/horn/pos/test02.smt2 too large to diff
tests/horn/pos/test03.smt2 too large to diff
tests/minimize/two-cores.fq too large to diff
tests/neg/maps02.fq too large to diff
tests/pos/maps02.fq too large to diff
tests/pos/maps03.fq too large to diff
tests/pos/maps04.fq too large to diff
tests/pos/maps05.fq too large to diff
tests/proof/GADTs.fq too large to diff
tests/proof/IndPal00.fq too large to diff
tests/proof/IndPal000.fq too large to diff
tests/proof/LH1424.fq too large to diff
tests/proof/T387.fq too large to diff
tests/proof/T414.fq too large to diff
tests/proof/contra.fq too large to diff
tests/proof/even.fq too large to diff
tests/proof/evenA.fq too large to diff
tests/proof/intId.fq too large to diff
tests/proof/list00.fq too large to diff
tests/proof/list01.fq too large to diff
tests/proof/list01_adt.fq too large to diff
tests/proof/list02.fq too large to diff
tests/proof/list03.fq too large to diff
tests/proof/ple0.fq too large to diff
tests/proof/ple1.fq too large to diff
tests/proof/ple2.fq too large to diff
tests/proof/ple3.fq too large to diff
tests/proof/ple4.fq too large to diff
tests/proof/pleBool.fq too large to diff
tests/proof/pleBoolA.fq too large to diff
tests/proof/pleBoolB.fq too large to diff
tests/proof/pleBoolC.fq too large to diff
tests/proof/pleSubst.fq too large to diff
tests/proof/rewrite.fq too large to diff
tests/proof/sum.fq too large to diff
tests/rankNTypes/T407.hs.fq too large to diff
tests/tasty/Arbitrary.hs too large to diff
tests/tasty/InterpretTests.hs too large to diff
tests/tasty/Main.hs too large to diff
tests/tasty/ShareMapReference.hs too large to diff
tests/tasty/ShareMapTests.hs too large to diff
tests/tasty/SimplifyInterpreter.hs too large to diff
tests/tasty/SimplifyPLE.hs too large to diff
tests/tasty/SimplifyTests.hs too large to diff
tests/tasty/UndoANFTests.hs too large to diff
tests/test.hs too large to diff
tests/todo-crash/wl01.fq too large to diff
tests/todo/LH1090.fq too large to diff
tests/todo/T1371-short.fq too large to diff
tests/todo/ebind-kvar-chain.fq too large to diff
unix/Language/Fixpoint/Utils/Progress.hs too large to diff

− .circleci/config.yml

@@ -1,53 +0,0 @@-----version: 2.0--jobs:-  build:-    machine:-      image: ubuntu-2004:202107-02-    steps:-      - run: sudo apt-get update && sudo apt-get install -y curl git ssh unzip wget libtinfo-dev gcc make-      - add_ssh_keys-      - run: -          name: Install z3 -          command: |-            wget https://github.com/Z3Prover/z3/releases/download/z3-4.8.7/z3-4.8.7-x64-ubuntu-16.04.zip-            unzip z3-4.8.7-x64-ubuntu-16.04.zip-            rm -f z3-4.8.7-x64-ubuntu-16.04.zip-            sudo cp z3-4.8.7-x64-ubuntu-16.04/bin/libz3.a /usr/local/lib-            sudo cp z3-4.8.7-x64-ubuntu-16.04/bin/z3 /usr/local/bin-            sudo cp z3-4.8.7-x64-ubuntu-16.04/include/* /usr/local/include-            rm -rf z3-4.8.7-x64-ubuntu-16.04-            z3 --version--      - checkout-      - restore_cache:-          keys:-            - stack-cache-v1-{{ checksum "stack.yaml" }}-{{ checksum "liquid-fixpoint.cabal" }}-            - stack-cache-v1-{{ checksum "stack.yaml" }}-      - run:-          name: Dependencies-          command: |-            wget -qO- https://get.haskellstack.org/ | sudo sh-            stack --no-terminal setup-            stack --no-terminal build -j2 liquid-fixpoint --only-dependencies --test --no-run-tests-      - save_cache:-          key: stack-cache-v1-{{ checksum "stack.yaml" }}-{{ checksum "liquid-fixpoint.cabal" }}-          paths:-            - ~/.stack-            - ./.stack-work-      - run:-          name: Compile-          command : |-            stack --no-terminal build -j2 liquid-fixpoint --flag liquid-fixpoint:devel --test --no-run-tests-      - run:-          name: Test-          command: |-            mkdir -p /tmp/junit-            stack --no-terminal test -j2 liquid-fixpoint:test --flag liquid-fixpoint:devel --test-arguments="--xml=/tmp/junit/main-test-results.xml":-            stack --no-terminal haddock --flag liquid-fixpoint:devel --test --no-run-tests --no-haddock-deps --haddock-arguments="--no-print-missing-docs"-            # mkdir -p $CIRCLE_TEST_REPORTS/tasty-            # cp -r tests/logs/cur $CIRCLE_TEST_REPORTS/tasty/log-      - run:-          name: Dist-          command: stack --no-terminal sdist

− .ghci

@@ -1,1 +0,0 @@-:set -isrc

− CHANGES.md

@@ -1,47 +0,0 @@-# CHANGES--## NEXT--- Fix bugs in PLE-- Move to GHC 8.6.4 -- Add `fuel` parameter to debug unfolding in PLE--## 0.8.0.1 --- Support for HORN-NNF format clauses, see `tests/horn/{pos,neg}/*.smt2`-- Support for "existential binders", see `tests/pos/ebind-*.fq` for example.-  This only works with `--eliminate`.-- Move to GHC 8.4.3 --## 0.7.0.0--- New `eliminate` based solver (see ICFP 2017 paper for algorithm)-- Proof by Logical Evaluation see `tests/proof`-- SMTLIB2 ADTs to make data constructors injective -- Uniformly support polymorphic functions via `apply` and elaborate--## 0.3.0.0--- Make interpreted mul and div the default, when `solver = z3`-- Use `higherorder` flag to allow higher order binders into the environment --## 0.2.2.0--- Added support for theory of Arrays `Map_t`, `Map_select`, `Map_store`--- Added support for theory of Bitvectors -- see `Language.Fixpoint.Smt.Bitvector`--- Added support for string literals--## 0.2.1.0--- Pre-compiled binaries of the underlying ocaml solver are now-  provided for Linux, Mac OSX, and Windows.--  No more need to install Ocaml!--## 0.2.0.0--- Parsing has been improved to require *much* fewer parentheses.--- Experimental support for Z3's theory of real numbers with the `--real` flag.

− README.md

@@ -1,366 +0,0 @@-Liquid Fixpoint [![Hackage](https://img.shields.io/hackage/v/liquid-fixpoint.svg)](https://hackage.haskell.org/package/liquid-fixpoint) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/liquid-fixpoint.svg)](http://packdeps.haskellers.com/feed?needle=liquid-fixpoint) -[![CircleCI](https://circleci.com/gh/ucsd-progsys/liquid-fixpoint.svg?style=svg)](https://circleci.com/gh/ucsd-progsys/liquid-fixpoint)-===============------This package implements a Horn-Clause/Logical Implication constraint solver used-for various Liquid Types. The solver uses SMTLIB2 to implement an algorithm similar to:--+ [Houdini](https://users.soe.ucsc.edu/~cormac/papers/fme01.pdf)-+ [Cartesian predicate abstraction](http://swt.informatik.uni-freiburg.de/berit/papers/boolean-and-cartesian-....pdf)---Requirements---------------In addition to the .cabal dependencies you require an SMTLIB2 compatible solver binary:--- [Z3](http://z3.codeplex.com)-- [CVC4](http://cvc4.cs.nyu.edu)-- [MathSat](http://mathsat.fbk.eu/download.html)--If on Windows, please make sure to place the binary and any associated DLLs somewhere-in your path.--How To Build and Install----------------------------Simply do:--```-$ git clone https://github.com/ucsd-progsys/liquid-fixpoint.git-$ cd liquid-fixpoint-$ stack install-```--or (`cabal` instead of `stack` if you prefer.)---Using SMTLIB-based SMT Solvers---------------------------------You can use one of several SMTLIB2 compliant solvers, by:--    fixpoint --smtsolver=z3 path/to/file.hs--Currently, we support--    * Z3-    * CVC4-    * MathSat--"Horn" Format ----------------See the examples in `tests/horn/{pos, neg}` eg--- [sum](tests/horn/pos/ple_sum.smt2)-- [list00](tests/horn/pos/ple_list00.smt2)-- [list03](tests/horn/pos/ple_list03.smt2)--For how to write VCs "by hand".--See [this tutorial](https://arxiv.org/abs/2010.07763) -with [accompanying code](https://github.com/ranjitjhala/sprite-lang) -for an example of how to generate Horn queries.--The main datatypes are described in [src/Language/Fixpoint/Horn/Types.hs](src/Language/Fixpoint/Horn/Types.hs)---Configuration Management---------------------------It is very important that the version of Liquid Fixpoint be maintained properly.--Suppose that the current version of Liquid Haskell is `A.B.C.D`:--+ After a release to hackage is made, if any of the components `B`, `C`, or `D` are missing, they shall be added and set to `0`. Then the `D` component of Liquid Fixpoint shall be incremented by `1`. The version of Liquid Fixpoint is now `A.B.C.(D + 1)`--+ The first time a new function or type is exported from Liquid Fixpoint, if any of the components `B`, or `C` are missing, they shall be added and set to `0`. Then the `C` component shall be incremented by `1`, and the `D` component shall stripped. The version of Liquid Fixpoint is now `A.B.(C + 1)`--+ The first time the signature of an exported function or type is changed, or an exported function or type is removed (this includes functions or types that Liquid Fixpoint re-exports from its own dependencies), if the `B` component is missing, it shall be added and set to `0`. Then the `B` component shall be incremented by `1`, and the `C` and `D` components shall be stripped. The version of Liquid Fixpoint is now `A.(B + 1)`--+ The `A` component shall be updated at the sole discretion of the project owners.--It is recommended to use the [Bumper](https://hackage.haskell.org/package/bumper) utility to manage the versioning of Liquid Fixpoint. Bumper will automatically do the correct update to the cabal file. Additionally, it will update any packages that you have the source for that depend on Liquid Fixpoint.--To update Liquid Fixpoint and Liquid Haskell, first clone Liquid Haskell and Liquid Fixpoint to a common location:--```-git clone https://github.com/ucsd-progsys/liquidhaskell.git-git clone https://github.com/ucsd-progsys/liquid-fixpoint.git-```--To increment the `D` component of Liquid Fixpoint:--```-./path/to/bumper -3 liquid-fixpoint-```--This will update the `D` component of Liquid Fixpoint. If necessary, this will update the `Build-Depends` of Liquid Haskell. If the `Build-Depends` was updated, Liquid Haskell's `D` component will be incremented.--To increment the `C` component of Liquid Fixpoint, and strip the `D` component:--```-./path/to/bumper --minor liquid-fixpoint-```--As before, this will update Liquid Fixpoint and, if necessary, Liquid Haskell.--To increment the `B` component of Liquid Fixpoint, and strip the `D` and `C` components:--```-./path/to/bumper --major liquid-fixpoint-```--As before, this will update Liquid Fixpoint and, if necessary, Liquid Haskell--## SMTLIB2 Interface--There is a new SMTLIB2 interface directly from Haskell:--+ Language.Fixpoint.SmtLib2--See `tests/smt2/{Smt.hs, foo.smt2}` for an example of how to use it.--### Command Line for SMT2 interface--You can use the `.smt2` interface from the command-line as follows:--Use `--stdin` to read files from `stdin`--```-$ more tests/horn/pos/test01.smt | fixpoint --stdin--Liquid-Fixpoint Copyright 2013-15 Regents of the University of California.-All Rights Reserved.--Working 175% [==================================================================================================================]-Safe ( 3  constraints checked)-```--Use `-q` to disable all output (banner, progress bar etc.)--```-$ more tests/horn/pos/test01.smt | fixpoint -q --stdin-```--Use `--json` to get the output as a JSON object (rendered to `stdout`)--```-$ more tests/horn/pos/abs02-re.smt2 | stack exec -- fixpoint -q --json --stdin-"{\"result\":\"safe\"}"-```---## Options--`--higherorder` allows higher order binders into the environment--`--extsolver` runs the **deprecated** external solver.--`--parts` Partitions an `FInfo` into a `[FInfo]` and emits a bunch of files. So:--    $ fixpoint -n -p path/to/foo.fq--will now emit files:--    path/to/.liquid/foo.1.fq-    path/to/.liquid/foo.2.fq-    . . .-    path/to/.liquid/foo.k.fq--and also a dot file with the constraint dependency graph:--    path/to/.liquid/foo.fq.dot---## FInfo Invariants--### Binders--This is the field--```-     , bs       :: !BindEnv         -- ^ Bind  |-> (Symbol, SortedReft)-```--or in the .fq files as--```-bind 1 x : ...-bind 2 y : ...-```--* Each `BindId` must be a distinct `Int`,-* Each `BindId` that appears in a constraint-  environment i.e. inside _any_ `IBindEnv`-  must appear inside the `bs`--### Environments--* Each constraint's environment is a set of `BindId`-  which must be defined in the `bindInfo`. Furthermore--* Each constraint should not have _duplicate_ names in its-  environment, that is if you have two binders--```-  bind 1 x : ...-  bind 12 x : ...-```--  Then a single `IBindEnv` should only mention _at most_-  one of `1` or `12`.--* There is also a "tree-shape" property that its a bit hard-  to describe ... TODO     --### LHS--Each `slhs` of a constraint is a `SortedReft`.--- Each `SortredReft` is basically a `Reft` -- a logical predicate.-  The important bit is that a `KVar` i.e. terms of the formalized--```-     $k1[x1:=y1][x2:=y2]...[xn:=yn]-```--  That is represented in the `Expr` type as--```-  | PKVar  !KVar !Subst-```--  must appear _only_ at the **top-level** that is not under _any_-  other operators, i.e. not as a sub-`Expr` of other expressions.---- This is basically a predicate that needs to be "well sorted"-  with respect to the `BindId`, intuitively--```-    x:int, y:int |- x + y : int-```--  is well sorted. but--```-    x:int  |- x + y : int-```--  is not, and--```-    x:int, y: list |- x + y : int-```--  is not. The exact definition is formalized in `Language.Fixpoint.SortCheck`---### RHS--Similarly each `rhs` of a `SubC` must either be a single `$k[...]` or an plain `$k`-free `Expr`.--### Global vs. Distinct Literals--```-     , gLits    :: !(SEnv Sort)               -- ^ Global Constant symbols-     , dLits    :: !(SEnv Sort)       -```--The _global_ literals `gLits` are symbols that-are in scope _everywhere_ i.e. need not be separately-defined in individual environments. These include things like--- uninterpreted _measure_ functions `len`, `height`,-- uninterpreted _data constructor_ literals `True`, `False`--Suppose you have an enumerated type like:--```-data Day = Sun | Mon | Tue | Wed | ... | Sat-```--You can model the above values in fixpoint as:--```-constant lit#Sun : Day-constant lit#Mon : Day-constant lit#Tue : Day-constant lit#Wed : Day-```--The _distinct_ literals are a subset of the above where we-want to tell the SMT solver that the values are *distinct*-i.e. **not equal** to each other, for example, you can-**additionally** specify this as:--```-distinct lit#Sun : Day-distinct lit#Mon : Day-distinct lit#Tue : Day-distinct lit#Wed : Day-```--The above two are represented programmatically by generating-suitable `Symbol` values (for the literals  see `litSymbol`)-and `Sort` values as `FTC FTycon` and then making an `SEnv`-from the `[(Symbol, Sort)]`.--### Sorts--> What's the difference between an FTC and an FObj?--In early versions of fixpoint, there was support for -three sorts for expressions (`Expr`) that were sent -to the SMT solver:--1. `int`-2. `bool`-3. "other"--The `FObj` sort was introduced to represent essentially _all_ -non-int and non-bool values (e.g. tuples, lists, trees, pointers...)--However, we later realized that it is valuable to keep _more_-precise information for `Expr`s and so we introduced the `FTC`-(fixpoint type constructor), which lets us represent the above-respectively as:--- `FTC "String" []`                   -- in Haskell `String`-- `FTC "Tuple"  [FInt, Bool]`         -- in Haskell `(Int, Bool)`-- `FTC "List" [FTC "List" [FInt]]`    -- in Haskell `[[Int]]`--> There is a comment that says FObj's are uninterpretted types;-> so probably a type the SMT solver doesn't know about?-> Does that then make FTC types that the SMT solver does-> know about (bools, ints, lists, sets, etc.)?--The SMT solver knows about `bool`, `int` and `set` (also `bitvector` -and `map`) but _all_ other types are _currently_ represented as plain -`Int` inside the SMT solver. However, we _will be_ changing this -to make use of SMT support for ADTs ...--To sum up: the `FObj` is there for historical reasons; it has been -subsumed by `FTC` which is what I recomend you use. However `FObj` -is there if you want a simple "unitype" / "any" type for terms -that are not "interpreted".--## Qualifier Patterns --```haskell-λ> doParse' (qualParamP sortP) "" "z as (mon . $1) : int"-QP {qpSym = "z", qpPat = PatPrefix "mon" 1, qpSort = FInt}-λ> doParse' (qualParamP sortP) "" "z as ($1 . mon) : int"-QP {qpSym = "z", qpPat = PatSuffix 1 "mon", qpSort = FInt}-λ> doParse' (qualParamP sortP) "" "z as mon : int"-QP {qpSym = "z", qpPat = PatExact "mon", qpSort = FInt}-λ> doParse' (qualParamP sortP) "" "z : int"-QP {qpSym = "z", qpPat = PatNone, qpSort = FInt}-```

− TODO.md

@@ -1,2 +0,0 @@-# TODO-

bin/Fixpoint.hs view

@@ -1,12 +1,12 @@  import           Language.Fixpoint.Solver        (solveFQ) import           Language.Fixpoint.Horn.Solve    (solveHorn)-import qualified Language.Fixpoint.Misc         as Misc -import qualified Language.Fixpoint.Types        as F -import qualified Language.Fixpoint.Types.Config as F -import qualified Language.Fixpoint.Utils.Files  as F +import qualified Language.Fixpoint.Misc         as Misc+import qualified Language.Fixpoint.Types        as F+import qualified Language.Fixpoint.Types.Config as F+import qualified Language.Fixpoint.Utils.Files  as F import           System.Exit-import qualified Control.Exception              as Ex +import qualified Control.Exception              as Ex  main :: IO () main = do@@ -18,13 +18,13 @@ --------------------------------------------------------------------------- solveQuery :: F.Config -> IO ExitCode solveQuery cfg     = solver cfg `Ex.catch` errorExit-  where -    solver     -      | isHorn cfg = solveHorn -      | otherwise  = solveFQ +  where+    solver+      | isHorn cfg = solveHorn+      | otherwise  = solveFQ -isHorn :: F.Config -> Bool -isHorn cfg = F.isExtFile F.Smt2 (F.srcFile cfg) || F.stdin cfg +isHorn :: F.Config -> Bool+isHorn cfg = F.isExtFile F.Smt2 (F.srcFile cfg) || F.stdin cfg  errorExit :: F.Error -> IO ExitCode errorExit e = do

− default.nix

@@ -1,52 +0,0 @@-{ makeEnv ? false, config ? { allowBroken = true; }, ... }:-let-  # fetch pinned version of nixpkgs-  nixpkgs = import (-    builtins.fetchTarball {-      # fetch latest nixpkgs https://github.com/NixOS/nixpkgs-channels/tree/nixos-20.03 as of Tue 18 Aug 2020 02:51:27 PM UTC-      url = "https://github.com/NixOS/nixpkgs-channels/archive/cb1996818edf506c0d1665ab147c253c558a7426.tar.gz";-      sha256 = "0lb6idvg2aj61nblr41x0ixwbphih2iz8xxc05m69hgsn261hk3j";-    }-  ) { inherit config; };-  # override haskell compiler version, add and override dependencies in nixpkgs-  haskellPackages = nixpkgs.haskell.packages."ghc8101".override (-    old: {-      all-cabal-hashes = nixpkgs.fetchurl {-        # fetch latest cabal hashes https://github.com/commercialhaskell/all-cabal-hashes/tree/hackage as of Tue 18 Aug 2020 02:51:27 PM UTC-        url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/112fef7b4bf392d4d4c36fbbe00ed061685ba26c.tar.gz";-        sha256 = "0x0mkpwnndw7n62l089gimd76n9gy749giban9pacf5kxbsfxrdc";-      };-      overrides = self: super: with nixpkgs.haskell.lib; rec {-        mkDerivation = args: super.mkDerivation (-          args // {-            doCheck = false;-            doHaddock = false;-            jailbreak = true;-          }-        );-        # test dependencies-        git = overrideCabal (self.callHackage "git" "0.3.0" {}) (-          old: {-            patches = [ ./git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch ]; # git-0.3.0 defines a Monad a fail function, which is incompatible with ghc-8.10.1 https://hackage.haskell.org/package/git-0.3.0/docs/src/Data.Git.Monad.html#line-240-          }-        );-        # build dependencies; using latest hackage releases as of Tue 18 Aug 2020 02:51:27 PM UTC-        memory = self.callHackage "memory" "0.15.0" {};-      };-    }-  );-  # function to bring devtools in to a package environment-  devtools = old: { nativeBuildInputs = old.nativeBuildInputs ++ [ nixpkgs.cabal-install nixpkgs.ghcid ]; }; # ghc and hpack are automatically included-  # ignore files specified by gitignore in nix-build-  source = nixpkgs.nix-gitignore.gitignoreSource [] ./.;-  # use overridden-haskellPackages to call gitignored-source-  drv = nixpkgs.haskell.lib.overrideCabal (haskellPackages.callCabal2nix "liquid-fixpoint" source {}) (-    old: {-      buildTools = [ nixpkgs.z3 ];-      doCheck = true;-      doHaddock = true;-      preCheck = ''export PATH="$PWD/dist/build/fixpoint:$PATH"''; # bring the `fixpoint` binary into scope for tests run by nix-build-    }-  );-in-if makeEnv then drv.env.overrideAttrs devtools else drv

− dist/build/Data/ShareMap.dyn_hi

binary file changed (17413 → absent bytes)

− dist/build/Data/ShareMap.dyn_o

binary file changed (66592 → absent bytes)

− dist/build/Data/ShareMap.hi

binary file changed (17410 → absent bytes)

− dist/build/Data/ShareMap.o

binary file changed (66448 → absent bytes)

− dist/build/Language/Fixpoint/Defunctionalize.dyn_hi

binary file changed (44400 → absent bytes)

− dist/build/Language/Fixpoint/Defunctionalize.dyn_o

binary file changed (113908 → absent bytes)

− dist/build/Language/Fixpoint/Defunctionalize.hi

binary file changed (44397 → absent bytes)

− dist/build/Language/Fixpoint/Defunctionalize.o

binary file changed (113668 → absent bytes)

− dist/build/Language/Fixpoint/Graph.dyn_hi

binary file changed (9980 → absent bytes)

− dist/build/Language/Fixpoint/Graph.dyn_o

binary file changed (1356 → absent bytes)

− dist/build/Language/Fixpoint/Graph.hi

binary file changed (9977 → absent bytes)

− dist/build/Language/Fixpoint/Graph.o

binary file changed (1356 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Deps.dyn_hi

binary file changed (51164 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Deps.dyn_o

binary file changed (376204 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Deps.hi

binary file changed (51161 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Deps.o

binary file changed (374276 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Indexed.dyn_hi

binary file changed (25482 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Indexed.dyn_o

binary file changed (80552 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Indexed.hi

binary file changed (25479 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Indexed.o

binary file changed (80256 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Partition.dyn_hi

binary file changed (32095 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Partition.dyn_o

binary file changed (130244 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Partition.hi

binary file changed (32092 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Partition.o

binary file changed (129716 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Reducible.dyn_hi

binary file changed (12798 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Reducible.dyn_o

binary file changed (51544 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Reducible.hi

binary file changed (12795 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Reducible.o

binary file changed (51328 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Types.dyn_hi

binary file changed (89544 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Types.dyn_o

binary file changed (150772 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Types.hi

binary file changed (89541 → absent bytes)

− dist/build/Language/Fixpoint/Graph/Types.o

binary file changed (150220 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Info.dyn_hi

binary file changed (34157 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Info.dyn_o

binary file changed (90016 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Info.hi

binary file changed (34154 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Info.o

binary file changed (89672 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Parse.dyn_hi

binary file changed (39999 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Parse.dyn_o

binary file changed (417748 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Parse.hi

binary file changed (39996 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Parse.o

binary file changed (416428 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Solve.dyn_hi

binary file changed (22643 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Solve.dyn_o

binary file changed (68160 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Solve.hi

binary file changed (22640 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Solve.o

binary file changed (67608 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Transformations.dyn_hi

binary file changed (33255 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Transformations.dyn_o

binary file changed (331764 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Transformations.hi

binary file changed (33252 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Transformations.o

binary file changed (329772 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Types.dyn_hi

binary file changed (229983 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Types.dyn_o

binary file changed (526944 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Types.hi

binary file changed (229980 → absent bytes)

− dist/build/Language/Fixpoint/Horn/Types.o

binary file changed (523864 → absent bytes)

− dist/build/Language/Fixpoint/Minimize.dyn_hi

binary file changed (16957 → absent bytes)

− dist/build/Language/Fixpoint/Minimize.dyn_o

binary file changed (79308 → absent bytes)

− dist/build/Language/Fixpoint/Minimize.hi

binary file changed (16954 → absent bytes)

− dist/build/Language/Fixpoint/Minimize.o

binary file changed (78820 → absent bytes)

− dist/build/Language/Fixpoint/Misc.dyn_hi

binary file changed (78935 → absent bytes)

− dist/build/Language/Fixpoint/Misc.dyn_o

binary file changed (236924 → absent bytes)

− dist/build/Language/Fixpoint/Misc.hi

binary file changed (78932 → absent bytes)

− dist/build/Language/Fixpoint/Misc.o

binary file changed (236020 → absent bytes)

− dist/build/Language/Fixpoint/Parse.dyn_hi

binary file changed (436974 → absent bytes)

− dist/build/Language/Fixpoint/Parse.dyn_o

file too large to diff

− dist/build/Language/Fixpoint/Parse.hi

binary file changed (436971 → absent bytes)

− dist/build/Language/Fixpoint/Parse.o

file too large to diff

− dist/build/Language/Fixpoint/Smt/Bitvector.dyn_hi

binary file changed (45247 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Bitvector.dyn_o

binary file changed (99752 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Bitvector.hi

binary file changed (45244 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Bitvector.o

binary file changed (99552 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Interface.dyn_hi

binary file changed (57483 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Interface.dyn_o

binary file changed (362036 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Interface.hi

binary file changed (57480 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Interface.o

binary file changed (360068 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Serialize.dyn_hi

binary file changed (45724 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Serialize.dyn_o

binary file changed (260264 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Serialize.hi

binary file changed (45721 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Serialize.o

binary file changed (258704 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Theories.dyn_hi

binary file changed (164399 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Theories.dyn_o

binary file changed (446636 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Theories.hi

binary file changed (164396 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Theories.o

binary file changed (445692 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Types.dyn_hi

binary file changed (29739 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Types.dyn_o

binary file changed (155360 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Types.hi

binary file changed (29736 → absent bytes)

− dist/build/Language/Fixpoint/Smt/Types.o

binary file changed (154432 → absent bytes)

− dist/build/Language/Fixpoint/Solver.dyn_hi

binary file changed (28234 → absent bytes)

− dist/build/Language/Fixpoint/Solver.dyn_o

binary file changed (166664 → absent bytes)

− dist/build/Language/Fixpoint/Solver.hi

binary file changed (28231 → absent bytes)

− dist/build/Language/Fixpoint/Solver.o

binary file changed (165360 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Eliminate.dyn_hi

binary file changed (9917 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Eliminate.dyn_o

binary file changed (78788 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Eliminate.hi

binary file changed (9914 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Eliminate.o

binary file changed (78324 → absent bytes)

− dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_hi

binary file changed (27644 → absent bytes)

− dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_o

binary file changed (447540 → absent bytes)

− dist/build/Language/Fixpoint/Solver/EnvironmentReduction.hi

binary file changed (27641 → absent bytes)

− dist/build/Language/Fixpoint/Solver/EnvironmentReduction.o

binary file changed (445268 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Extensionality.dyn_hi

binary file changed (32713 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Extensionality.dyn_o

binary file changed (153208 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Extensionality.hi

binary file changed (32710 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Extensionality.o

binary file changed (152920 → absent bytes)

− dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_hi

binary file changed (10043 → absent bytes)

− dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_o

binary file changed (52588 → absent bytes)

− dist/build/Language/Fixpoint/Solver/GradualSolution.hi

binary file changed (10040 → absent bytes)

− dist/build/Language/Fixpoint/Solver/GradualSolution.o

binary file changed (52292 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Instantiate.dyn_hi

binary file changed (58349 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Instantiate.dyn_o

binary file changed (422312 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Instantiate.hi

binary file changed (58346 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Instantiate.o

binary file changed (420512 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Monad.dyn_hi

binary file changed (21971 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Monad.dyn_o

binary file changed (70260 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Monad.hi

binary file changed (21968 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Monad.o

binary file changed (69996 → absent bytes)

− dist/build/Language/Fixpoint/Solver/PLE.dyn_hi

binary file changed (85893 → absent bytes)

− dist/build/Language/Fixpoint/Solver/PLE.dyn_o

binary file changed (667040 → absent bytes)

− dist/build/Language/Fixpoint/Solver/PLE.hi

binary file changed (85890 → absent bytes)

− dist/build/Language/Fixpoint/Solver/PLE.o

binary file changed (663768 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Prettify.dyn_hi

binary file changed (13759 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Prettify.dyn_o

binary file changed (192076 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Prettify.hi

binary file changed (13756 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Prettify.o

binary file changed (190948 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Rewrite.dyn_hi

binary file changed (23621 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Rewrite.dyn_o

binary file changed (182456 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Rewrite.hi

binary file changed (23618 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Rewrite.o

binary file changed (181680 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Sanitize.dyn_hi

binary file changed (23108 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Sanitize.dyn_o

binary file changed (312520 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Sanitize.hi

binary file changed (23105 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Sanitize.o

binary file changed (310688 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solution.dyn_hi

binary file changed (39339 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solution.dyn_o

binary file changed (266728 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solution.hi

binary file changed (39336 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solution.o

binary file changed (265640 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solve.dyn_hi

binary file changed (20047 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solve.dyn_o

binary file changed (157064 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solve.hi

binary file changed (20044 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Solve.o

binary file changed (156128 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Stats.dyn_hi

binary file changed (178510 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Stats.dyn_o

binary file changed (197256 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Stats.hi

binary file changed (178507 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Stats.o

binary file changed (196408 → absent bytes)

− dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_hi

binary file changed (49850 → absent bytes)

− dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_o

binary file changed (133016 → absent bytes)

− dist/build/Language/Fixpoint/Solver/TrivialSort.hi

binary file changed (49847 → absent bytes)

− dist/build/Language/Fixpoint/Solver/TrivialSort.o

binary file changed (132400 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_hi

binary file changed (34113 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_o

binary file changed (149828 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyBinds.hi

binary file changed (34110 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyBinds.o

binary file changed (149148 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_hi

binary file changed (14463 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_o

binary file changed (65580 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyKVars.hi

binary file changed (14460 → absent bytes)

− dist/build/Language/Fixpoint/Solver/UniqifyKVars.o

binary file changed (65244 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Worklist.dyn_hi

binary file changed (41733 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Worklist.dyn_o

binary file changed (142512 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Worklist.hi

binary file changed (41730 → absent bytes)

− dist/build/Language/Fixpoint/Solver/Worklist.o

binary file changed (141928 → absent bytes)

− dist/build/Language/Fixpoint/SortCheck.dyn_hi

binary file changed (74070 → absent bytes)

− dist/build/Language/Fixpoint/SortCheck.dyn_o

binary file changed (467932 → absent bytes)

− dist/build/Language/Fixpoint/SortCheck.hi

binary file changed (74067 → absent bytes)

− dist/build/Language/Fixpoint/SortCheck.o

binary file changed (464996 → absent bytes)

− dist/build/Language/Fixpoint/Types.dyn_hi

binary file changed (34425 → absent bytes)

− dist/build/Language/Fixpoint/Types.dyn_o

binary file changed (1356 → absent bytes)

− dist/build/Language/Fixpoint/Types.hi

binary file changed (34422 → absent bytes)

− dist/build/Language/Fixpoint/Types.o

binary file changed (1356 → absent bytes)

− dist/build/Language/Fixpoint/Types/Config.dyn_hi

binary file changed (241186 → absent bytes)

− dist/build/Language/Fixpoint/Types/Config.dyn_o

binary file changed (499060 → absent bytes)

− dist/build/Language/Fixpoint/Types/Config.hi

binary file changed (241183 → absent bytes)

− dist/build/Language/Fixpoint/Types/Config.o

binary file changed (497060 → absent bytes)

− dist/build/Language/Fixpoint/Types/Constraints.dyn_hi

binary file changed (818478 → absent bytes)

− dist/build/Language/Fixpoint/Types/Constraints.dyn_o

binary file changed (1981416 → absent bytes)

− dist/build/Language/Fixpoint/Types/Constraints.hi

binary file changed (818475 → absent bytes)

− dist/build/Language/Fixpoint/Types/Constraints.o

binary file changed (1970304 → absent bytes)

− dist/build/Language/Fixpoint/Types/Environments.dyn_hi

binary file changed (201165 → absent bytes)

− dist/build/Language/Fixpoint/Types/Environments.dyn_o

binary file changed (579012 → absent bytes)

− dist/build/Language/Fixpoint/Types/Environments.hi

binary file changed (201162 → absent bytes)

− dist/build/Language/Fixpoint/Types/Environments.o

binary file changed (576276 → absent bytes)

− dist/build/Language/Fixpoint/Types/Errors.dyn_hi

binary file changed (207227 → absent bytes)

− dist/build/Language/Fixpoint/Types/Errors.dyn_o

binary file changed (463352 → absent bytes)

− dist/build/Language/Fixpoint/Types/Errors.hi

binary file changed (207224 → absent bytes)

− dist/build/Language/Fixpoint/Types/Errors.o

binary file changed (461176 → absent bytes)

− dist/build/Language/Fixpoint/Types/Graduals.dyn_hi

binary file changed (57840 → absent bytes)

− dist/build/Language/Fixpoint/Types/Graduals.dyn_o

binary file changed (187740 → absent bytes)

− dist/build/Language/Fixpoint/Types/Graduals.hi

binary file changed (57837 → absent bytes)

− dist/build/Language/Fixpoint/Types/Graduals.o

binary file changed (187084 → absent bytes)

− dist/build/Language/Fixpoint/Types/Names.dyn_hi

binary file changed (118363 → absent bytes)

− dist/build/Language/Fixpoint/Types/Names.dyn_o

binary file changed (596704 → absent bytes)

− dist/build/Language/Fixpoint/Types/Names.hi

binary file changed (118360 → absent bytes)

− dist/build/Language/Fixpoint/Types/Names.o

binary file changed (594168 → absent bytes)

− dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_hi

binary file changed (53955 → absent bytes)

− dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_o

binary file changed (188032 → absent bytes)

− dist/build/Language/Fixpoint/Types/PrettyPrint.hi

binary file changed (53952 → absent bytes)

− dist/build/Language/Fixpoint/Types/PrettyPrint.o

binary file changed (186328 → absent bytes)

binary file changed (965529 → absent bytes)

binary file changed (2089388 → absent bytes)

binary file changed (965526 → absent bytes)

binary file changed (2078268 → absent bytes)

− dist/build/Language/Fixpoint/Types/Solutions.dyn_hi

binary file changed (257706 → absent bytes)

− dist/build/Language/Fixpoint/Types/Solutions.dyn_o

binary file changed (496668 → absent bytes)

− dist/build/Language/Fixpoint/Types/Solutions.hi

binary file changed (257703 → absent bytes)

− dist/build/Language/Fixpoint/Types/Solutions.o

binary file changed (494556 → absent bytes)

− dist/build/Language/Fixpoint/Types/Sorts.dyn_hi

binary file changed (516993 → absent bytes)

− dist/build/Language/Fixpoint/Types/Sorts.dyn_o

binary file changed (974572 → absent bytes)

− dist/build/Language/Fixpoint/Types/Sorts.hi

binary file changed (516990 → absent bytes)

− dist/build/Language/Fixpoint/Types/Sorts.o

binary file changed (970612 → absent bytes)

− dist/build/Language/Fixpoint/Types/Spans.dyn_hi

binary file changed (122832 → absent bytes)

− dist/build/Language/Fixpoint/Types/Spans.dyn_o

binary file changed (269672 → absent bytes)

− dist/build/Language/Fixpoint/Types/Spans.hi

binary file changed (122829 → absent bytes)

− dist/build/Language/Fixpoint/Types/Spans.o

binary file changed (268664 → absent bytes)

− dist/build/Language/Fixpoint/Types/Substitutions.dyn_hi

binary file changed (61422 → absent bytes)

− dist/build/Language/Fixpoint/Types/Substitutions.dyn_o

binary file changed (313504 → absent bytes)

− dist/build/Language/Fixpoint/Types/Substitutions.hi

binary file changed (61419 → absent bytes)

− dist/build/Language/Fixpoint/Types/Substitutions.o

binary file changed (311480 → absent bytes)

− dist/build/Language/Fixpoint/Types/Templates.dyn_hi

binary file changed (15446 → absent bytes)

− dist/build/Language/Fixpoint/Types/Templates.dyn_o

binary file changed (51480 → absent bytes)

− dist/build/Language/Fixpoint/Types/Templates.hi

binary file changed (15443 → absent bytes)

− dist/build/Language/Fixpoint/Types/Templates.o

binary file changed (51264 → absent bytes)

− dist/build/Language/Fixpoint/Types/Theories.dyn_hi

binary file changed (308693 → absent bytes)

− dist/build/Language/Fixpoint/Types/Theories.dyn_o

binary file changed (643480 → absent bytes)

− dist/build/Language/Fixpoint/Types/Theories.hi

binary file changed (308690 → absent bytes)

− dist/build/Language/Fixpoint/Types/Theories.o

binary file changed (639560 → absent bytes)

− dist/build/Language/Fixpoint/Types/Triggers.dyn_hi

binary file changed (34614 → absent bytes)

− dist/build/Language/Fixpoint/Types/Triggers.dyn_o

binary file changed (71348 → absent bytes)

− dist/build/Language/Fixpoint/Types/Triggers.hi

binary file changed (34611 → absent bytes)

− dist/build/Language/Fixpoint/Types/Triggers.o

binary file changed (71124 → absent bytes)

− dist/build/Language/Fixpoint/Types/Utils.dyn_hi

binary file changed (23758 → absent bytes)

− dist/build/Language/Fixpoint/Types/Utils.dyn_o

binary file changed (72808 → absent bytes)

− dist/build/Language/Fixpoint/Types/Utils.hi

binary file changed (23755 → absent bytes)

− dist/build/Language/Fixpoint/Types/Utils.o

binary file changed (72528 → absent bytes)

− dist/build/Language/Fixpoint/Types/Visitor.dyn_hi

binary file changed (72464 → absent bytes)

− dist/build/Language/Fixpoint/Types/Visitor.dyn_o

binary file changed (221592 → absent bytes)

− dist/build/Language/Fixpoint/Types/Visitor.hi

binary file changed (72461 → absent bytes)

− dist/build/Language/Fixpoint/Types/Visitor.o

binary file changed (220656 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Builder.dyn_hi

binary file changed (21064 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Builder.dyn_o

binary file changed (47656 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Builder.hi

binary file changed (21061 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Builder.o

binary file changed (47592 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Files.dyn_hi

binary file changed (35209 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Files.dyn_o

binary file changed (138828 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Files.hi

binary file changed (35206 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Files.o

binary file changed (138524 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Progress.dyn_hi

binary file changed (8672 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Progress.dyn_o

binary file changed (18992 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Progress.hi

binary file changed (8669 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Progress.o

binary file changed (18824 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Statistics.dyn_hi

binary file changed (33429 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Statistics.dyn_o

binary file changed (68456 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Statistics.hi

binary file changed (33426 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Statistics.o

binary file changed (68048 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Trie.dyn_hi

binary file changed (14715 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Trie.dyn_o

binary file changed (48936 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Trie.hi

binary file changed (14712 → absent bytes)

− dist/build/Language/Fixpoint/Utils/Trie.o

binary file changed (48800 → absent bytes)

− dist/build/Paths_liquid_fixpoint.dyn_hi

binary file changed (13849 → absent bytes)

− dist/build/Paths_liquid_fixpoint.dyn_o

binary file changed (32764 → absent bytes)

− dist/build/Paths_liquid_fixpoint.hi

binary file changed (13846 → absent bytes)

− dist/build/Paths_liquid_fixpoint.o

binary file changed (32716 → absent bytes)

− dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_hi

binary file changed (2471 → absent bytes)

− dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_o

binary file changed (1948 → absent bytes)

− dist/build/Text/PrettyPrint/HughesPJ/Compat.hi

binary file changed (2468 → absent bytes)

− dist/build/Text/PrettyPrint/HughesPJ/Compat.o

binary file changed (1948 → absent bytes)

− dist/build/autogen/Paths_liquid_fixpoint.hs

@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}-module Paths_liquid_fixpoint (-    version,-    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,-    getDataFileName, getSysconfDir-  ) where--import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude--#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch--version :: Version-version = Version [0,8,10,7] []-bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath--bindir     = "/Users/niki.vazou/.cabal/bin"-libdir     = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF"-dynlibdir  = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1"-datadir    = "/Users/niki.vazou/.cabal/share/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7"-libexecdir = "/Users/niki.vazou/.cabal/libexec/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7"-sysconfdir = "/Users/niki.vazou/.cabal/etc"--getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath-getBinDir = catchIO (getEnv "liquid_fixpoint_bindir") (\_ -> return bindir)-getLibDir = catchIO (getEnv "liquid_fixpoint_libdir") (\_ -> return libdir)-getDynLibDir = catchIO (getEnv "liquid_fixpoint_dynlibdir") (\_ -> return dynlibdir)-getDataDir = catchIO (getEnv "liquid_fixpoint_datadir") (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "liquid_fixpoint_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "liquid_fixpoint_sysconfdir") (\_ -> return sysconfdir)--getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do-  dir <- getDataDir-  return (dir ++ "/" ++ name)

− dist/build/autogen/cabal_macros.h

@@ -1,495 +0,0 @@-/* DO NOT EDIT: This file is automatically generated by Cabal */--/* package liquid-fixpoint-0.8.10.7 */-#ifndef VERSION_liquid_fixpoint-#define VERSION_liquid_fixpoint "0.8.10.7"-#endif /* VERSION_liquid_fixpoint */-#ifndef MIN_VERSION_liquid_fixpoint-#define MIN_VERSION_liquid_fixpoint(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  8 || \-  (major1) == 0 && (major2) == 8 && (minor) <= 10)-#endif /* MIN_VERSION_liquid_fixpoint */--/* package base-4.15.0.0 */-#ifndef VERSION_base-#define VERSION_base "4.15.0.0"-#endif /* VERSION_base */-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(major1,major2,minor) (\-  (major1) <  4 || \-  (major1) == 4 && (major2) <  15 || \-  (major1) == 4 && (major2) == 15 && (minor) <= 0)-#endif /* MIN_VERSION_base */--/* package ansi-terminal-0.11 */-#ifndef VERSION_ansi_terminal-#define VERSION_ansi_terminal "0.11"-#endif /* VERSION_ansi_terminal */-#ifndef MIN_VERSION_ansi_terminal-#define MIN_VERSION_ansi_terminal(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  11 || \-  (major1) == 0 && (major2) == 11 && (minor) <= 0)-#endif /* MIN_VERSION_ansi_terminal */--/* package array-0.5.4.0 */-#ifndef VERSION_array-#define VERSION_array "0.5.4.0"-#endif /* VERSION_array */-#ifndef MIN_VERSION_array-#define MIN_VERSION_array(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  5 || \-  (major1) == 0 && (major2) == 5 && (minor) <= 4)-#endif /* MIN_VERSION_array */--/* package async-2.2.4 */-#ifndef VERSION_async-#define VERSION_async "2.2.4"-#endif /* VERSION_async */-#ifndef MIN_VERSION_async-#define MIN_VERSION_async(major1,major2,minor) (\-  (major1) <  2 || \-  (major1) == 2 && (major2) <  2 || \-  (major1) == 2 && (major2) == 2 && (minor) <= 4)-#endif /* MIN_VERSION_async */--/* package attoparsec-0.14.2 */-#ifndef VERSION_attoparsec-#define VERSION_attoparsec "0.14.2"-#endif /* VERSION_attoparsec */-#ifndef MIN_VERSION_attoparsec-#define MIN_VERSION_attoparsec(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  14 || \-  (major1) == 0 && (major2) == 14 && (minor) <= 2)-#endif /* MIN_VERSION_attoparsec */--/* package binary-0.8.8.0 */-#ifndef VERSION_binary-#define VERSION_binary "0.8.8.0"-#endif /* VERSION_binary */-#ifndef MIN_VERSION_binary-#define MIN_VERSION_binary(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  8 || \-  (major1) == 0 && (major2) == 8 && (minor) <= 8)-#endif /* MIN_VERSION_binary */--/* package store-0.7.12 */-#ifndef VERSION_store-#define VERSION_store "0.7.12"-#endif /* VERSION_store */-#ifndef MIN_VERSION_store-#define MIN_VERSION_store(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  7 || \-  (major1) == 0 && (major2) == 7 && (minor) <= 12)-#endif /* MIN_VERSION_store */--/* package bytestring-0.10.12.1 */-#ifndef VERSION_bytestring-#define VERSION_bytestring "0.10.12.1"-#endif /* VERSION_bytestring */-#ifndef MIN_VERSION_bytestring-#define MIN_VERSION_bytestring(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  10 || \-  (major1) == 0 && (major2) == 10 && (minor) <= 12)-#endif /* MIN_VERSION_bytestring */--/* package boxes-0.1.5 */-#ifndef VERSION_boxes-#define VERSION_boxes "0.1.5"-#endif /* VERSION_boxes */-#ifndef MIN_VERSION_boxes-#define MIN_VERSION_boxes(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  1 || \-  (major1) == 0 && (major2) == 1 && (minor) <= 5)-#endif /* MIN_VERSION_boxes */--/* package cereal-0.5.8.1 */-#ifndef VERSION_cereal-#define VERSION_cereal "0.5.8.1"-#endif /* VERSION_cereal */-#ifndef MIN_VERSION_cereal-#define MIN_VERSION_cereal(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  5 || \-  (major1) == 0 && (major2) == 5 && (minor) <= 8)-#endif /* MIN_VERSION_cereal */--/* package cmdargs-0.10.21 */-#ifndef VERSION_cmdargs-#define VERSION_cmdargs "0.10.21"-#endif /* VERSION_cmdargs */-#ifndef MIN_VERSION_cmdargs-#define MIN_VERSION_cmdargs(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  10 || \-  (major1) == 0 && (major2) == 10 && (minor) <= 21)-#endif /* MIN_VERSION_cmdargs */--/* package containers-0.6.4.1 */-#ifndef VERSION_containers-#define VERSION_containers "0.6.4.1"-#endif /* VERSION_containers */-#ifndef MIN_VERSION_containers-#define MIN_VERSION_containers(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  6 || \-  (major1) == 0 && (major2) == 6 && (minor) <= 4)-#endif /* MIN_VERSION_containers */--/* package deepseq-1.4.5.0 */-#ifndef VERSION_deepseq-#define VERSION_deepseq "1.4.5.0"-#endif /* VERSION_deepseq */-#ifndef MIN_VERSION_deepseq-#define MIN_VERSION_deepseq(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  4 || \-  (major1) == 1 && (major2) == 4 && (minor) <= 5)-#endif /* MIN_VERSION_deepseq */--/* package directory-1.3.6.1 */-#ifndef VERSION_directory-#define VERSION_directory "1.3.6.1"-#endif /* VERSION_directory */-#ifndef MIN_VERSION_directory-#define MIN_VERSION_directory(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  3 || \-  (major1) == 1 && (major2) == 3 && (minor) <= 6)-#endif /* MIN_VERSION_directory */--/* package fgl-5.7.0.3 */-#ifndef VERSION_fgl-#define VERSION_fgl "5.7.0.3"-#endif /* VERSION_fgl */-#ifndef MIN_VERSION_fgl-#define MIN_VERSION_fgl(major1,major2,minor) (\-  (major1) <  5 || \-  (major1) == 5 && (major2) <  7 || \-  (major1) == 5 && (major2) == 7 && (minor) <= 0)-#endif /* MIN_VERSION_fgl */--/* package filepath-1.4.2.1 */-#ifndef VERSION_filepath-#define VERSION_filepath "1.4.2.1"-#endif /* VERSION_filepath */-#ifndef MIN_VERSION_filepath-#define MIN_VERSION_filepath(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  4 || \-  (major1) == 1 && (major2) == 4 && (minor) <= 2)-#endif /* MIN_VERSION_filepath */--/* package hashable-1.3.3.0 */-#ifndef VERSION_hashable-#define VERSION_hashable "1.3.3.0"-#endif /* VERSION_hashable */-#ifndef MIN_VERSION_hashable-#define MIN_VERSION_hashable(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  3 || \-  (major1) == 1 && (major2) == 3 && (minor) <= 3)-#endif /* MIN_VERSION_hashable */--/* package intern-0.9.4 */-#ifndef VERSION_intern-#define VERSION_intern "0.9.4"-#endif /* VERSION_intern */-#ifndef MIN_VERSION_intern-#define MIN_VERSION_intern(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  9 || \-  (major1) == 0 && (major2) == 9 && (minor) <= 4)-#endif /* MIN_VERSION_intern */--/* package mtl-2.2.2 */-#ifndef VERSION_mtl-#define VERSION_mtl "2.2.2"-#endif /* VERSION_mtl */-#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(major1,major2,minor) (\-  (major1) <  2 || \-  (major1) == 2 && (major2) <  2 || \-  (major1) == 2 && (major2) == 2 && (minor) <= 2)-#endif /* MIN_VERSION_mtl */--/* package parallel-3.2.2.0 */-#ifndef VERSION_parallel-#define VERSION_parallel "3.2.2.0"-#endif /* VERSION_parallel */-#ifndef MIN_VERSION_parallel-#define MIN_VERSION_parallel(major1,major2,minor) (\-  (major1) <  3 || \-  (major1) == 3 && (major2) <  2 || \-  (major1) == 3 && (major2) == 2 && (minor) <= 2)-#endif /* MIN_VERSION_parallel */--/* package parser-combinators-1.3.0 */-#ifndef VERSION_parser_combinators-#define VERSION_parser_combinators "1.3.0"-#endif /* VERSION_parser_combinators */-#ifndef MIN_VERSION_parser_combinators-#define MIN_VERSION_parser_combinators(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  3 || \-  (major1) == 1 && (major2) == 3 && (minor) <= 0)-#endif /* MIN_VERSION_parser_combinators */--/* package megaparsec-8.0.0 */-#ifndef VERSION_megaparsec-#define VERSION_megaparsec "8.0.0"-#endif /* VERSION_megaparsec */-#ifndef MIN_VERSION_megaparsec-#define MIN_VERSION_megaparsec(major1,major2,minor) (\-  (major1) <  8 || \-  (major1) == 8 && (major2) <  0 || \-  (major1) == 8 && (major2) == 0 && (minor) <= 0)-#endif /* MIN_VERSION_megaparsec */--/* package pretty-1.1.3.6 */-#ifndef VERSION_pretty-#define VERSION_pretty "1.1.3.6"-#endif /* VERSION_pretty */-#ifndef MIN_VERSION_pretty-#define MIN_VERSION_pretty(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  1 || \-  (major1) == 1 && (major2) == 1 && (minor) <= 3)-#endif /* MIN_VERSION_pretty */--/* package process-1.6.11.0 */-#ifndef VERSION_process-#define VERSION_process "1.6.11.0"-#endif /* VERSION_process */-#ifndef MIN_VERSION_process-#define MIN_VERSION_process(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  6 || \-  (major1) == 1 && (major2) == 6 && (minor) <= 11)-#endif /* MIN_VERSION_process */--/* package stm-2.5.0.0 */-#ifndef VERSION_stm-#define VERSION_stm "2.5.0.0"-#endif /* VERSION_stm */-#ifndef MIN_VERSION_stm-#define MIN_VERSION_stm(major1,major2,minor) (\-  (major1) <  2 || \-  (major1) == 2 && (major2) <  5 || \-  (major1) == 2 && (major2) == 5 && (minor) <= 0)-#endif /* MIN_VERSION_stm */--/* package syb-0.7.2.1 */-#ifndef VERSION_syb-#define VERSION_syb "0.7.2.1"-#endif /* VERSION_syb */-#ifndef MIN_VERSION_syb-#define MIN_VERSION_syb(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  7 || \-  (major1) == 0 && (major2) == 7 && (minor) <= 2)-#endif /* MIN_VERSION_syb */--/* package text-1.2.4.1 */-#ifndef VERSION_text-#define VERSION_text "1.2.4.1"-#endif /* VERSION_text */-#ifndef MIN_VERSION_text-#define MIN_VERSION_text(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  2 || \-  (major1) == 1 && (major2) == 2 && (minor) <= 4)-#endif /* MIN_VERSION_text */--/* package transformers-0.5.6.2 */-#ifndef VERSION_transformers-#define VERSION_transformers "0.5.6.2"-#endif /* VERSION_transformers */-#ifndef MIN_VERSION_transformers-#define MIN_VERSION_transformers(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  5 || \-  (major1) == 0 && (major2) == 5 && (minor) <= 6)-#endif /* MIN_VERSION_transformers */--/* package unordered-containers-0.2.14.0 */-#ifndef VERSION_unordered_containers-#define VERSION_unordered_containers "0.2.14.0"-#endif /* VERSION_unordered_containers */-#ifndef MIN_VERSION_unordered_containers-#define MIN_VERSION_unordered_containers(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  2 || \-  (major1) == 0 && (major2) == 2 && (minor) <= 14)-#endif /* MIN_VERSION_unordered_containers */--/* package aeson-1.5.6.0 */-#ifndef VERSION_aeson-#define VERSION_aeson "1.5.6.0"-#endif /* VERSION_aeson */-#ifndef MIN_VERSION_aeson-#define MIN_VERSION_aeson(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  5 || \-  (major1) == 1 && (major2) == 5 && (minor) <= 6)-#endif /* MIN_VERSION_aeson */--/* package rest-rewrite-0.1.1 */-#ifndef VERSION_rest_rewrite-#define VERSION_rest_rewrite "0.1.1"-#endif /* VERSION_rest_rewrite */-#ifndef MIN_VERSION_rest_rewrite-#define MIN_VERSION_rest_rewrite(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  1 || \-  (major1) == 0 && (major2) == 1 && (minor) <= 1)-#endif /* MIN_VERSION_rest_rewrite */--/* package ascii-progress-0.3.3.0 */-#ifndef VERSION_ascii_progress-#define VERSION_ascii_progress "0.3.3.0"-#endif /* VERSION_ascii_progress */-#ifndef MIN_VERSION_ascii_progress-#define MIN_VERSION_ascii_progress(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  3 || \-  (major1) == 0 && (major2) == 3 && (minor) <= 3)-#endif /* MIN_VERSION_ascii_progress */--/* tool alex-3.2.4 */-#ifndef TOOL_VERSION_alex-#define TOOL_VERSION_alex "3.2.4"-#endif /* TOOL_VERSION_alex */-#ifndef MIN_TOOL_VERSION_alex-#define MIN_TOOL_VERSION_alex(major1,major2,minor) (\-  (major1) <  3 || \-  (major1) == 3 && (major2) <  2 || \-  (major1) == 3 && (major2) == 2 && (minor) <= 4)-#endif /* MIN_TOOL_VERSION_alex */--/* tool gcc-12.0.5 */-#ifndef TOOL_VERSION_gcc-#define TOOL_VERSION_gcc "12.0.5"-#endif /* TOOL_VERSION_gcc */-#ifndef MIN_TOOL_VERSION_gcc-#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\-  (major1) <  12 || \-  (major1) == 12 && (major2) <  0 || \-  (major1) == 12 && (major2) == 0 && (minor) <= 5)-#endif /* MIN_TOOL_VERSION_gcc */--/* tool ghc-9.0.1 */-#ifndef TOOL_VERSION_ghc-#define TOOL_VERSION_ghc "9.0.1"-#endif /* TOOL_VERSION_ghc */-#ifndef MIN_TOOL_VERSION_ghc-#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\-  (major1) <  9 || \-  (major1) == 9 && (major2) <  0 || \-  (major1) == 9 && (major2) == 0 && (minor) <= 1)-#endif /* MIN_TOOL_VERSION_ghc */--/* tool ghc-pkg-9.0.1 */-#ifndef TOOL_VERSION_ghc_pkg-#define TOOL_VERSION_ghc_pkg "9.0.1"-#endif /* TOOL_VERSION_ghc_pkg */-#ifndef MIN_TOOL_VERSION_ghc_pkg-#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\-  (major1) <  9 || \-  (major1) == 9 && (major2) <  0 || \-  (major1) == 9 && (major2) == 0 && (minor) <= 1)-#endif /* MIN_TOOL_VERSION_ghc_pkg */--/* tool haddock-2.24.0 */-#ifndef TOOL_VERSION_haddock-#define TOOL_VERSION_haddock "2.24.0"-#endif /* TOOL_VERSION_haddock */-#ifndef MIN_TOOL_VERSION_haddock-#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\-  (major1) <  2 || \-  (major1) == 2 && (major2) <  24 || \-  (major1) == 2 && (major2) == 24 && (minor) <= 0)-#endif /* MIN_TOOL_VERSION_haddock */--/* tool happy-1.19.9 */-#ifndef TOOL_VERSION_happy-#define TOOL_VERSION_happy "1.19.9"-#endif /* TOOL_VERSION_happy */-#ifndef MIN_TOOL_VERSION_happy-#define MIN_TOOL_VERSION_happy(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  19 || \-  (major1) == 1 && (major2) == 19 && (minor) <= 9)-#endif /* MIN_TOOL_VERSION_happy */--/* tool hpc-0.68 */-#ifndef TOOL_VERSION_hpc-#define TOOL_VERSION_hpc "0.68"-#endif /* TOOL_VERSION_hpc */-#ifndef MIN_TOOL_VERSION_hpc-#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  68 || \-  (major1) == 0 && (major2) == 68 && (minor) <= 0)-#endif /* MIN_TOOL_VERSION_hpc */--/* tool hsc2hs-0.68.7 */-#ifndef TOOL_VERSION_hsc2hs-#define TOOL_VERSION_hsc2hs "0.68.7"-#endif /* TOOL_VERSION_hsc2hs */-#ifndef MIN_TOOL_VERSION_hsc2hs-#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  68 || \-  (major1) == 0 && (major2) == 68 && (minor) <= 7)-#endif /* MIN_TOOL_VERSION_hsc2hs */--/* tool hscolour-1.24 */-#ifndef TOOL_VERSION_hscolour-#define TOOL_VERSION_hscolour "1.24"-#endif /* TOOL_VERSION_hscolour */-#ifndef MIN_TOOL_VERSION_hscolour-#define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  24 || \-  (major1) == 1 && (major2) == 24 && (minor) <= 0)-#endif /* MIN_TOOL_VERSION_hscolour */--/* tool pkg-config-0.29.2 */-#ifndef TOOL_VERSION_pkg_config-#define TOOL_VERSION_pkg_config "0.29.2"-#endif /* TOOL_VERSION_pkg_config */-#ifndef MIN_TOOL_VERSION_pkg_config-#define MIN_TOOL_VERSION_pkg_config(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  29 || \-  (major1) == 0 && (major2) == 29 && (minor) <= 2)-#endif /* MIN_TOOL_VERSION_pkg_config */--/* tool runghc-9.0.1 */-#ifndef TOOL_VERSION_runghc-#define TOOL_VERSION_runghc "9.0.1"-#endif /* TOOL_VERSION_runghc */-#ifndef MIN_TOOL_VERSION_runghc-#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\-  (major1) <  9 || \-  (major1) == 9 && (major2) <  0 || \-  (major1) == 9 && (major2) == 0 && (minor) <= 1)-#endif /* MIN_TOOL_VERSION_runghc */--#ifndef CURRENT_PACKAGE_KEY-#define CURRENT_PACKAGE_KEY "liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF"-#endif /* CURRENT_PACKAGE_KEY */-#ifndef CURRENT_COMPONENT_ID-#define CURRENT_COMPONENT_ID "liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF"-#endif /* CURRENT_COMPONENT_ID */-#ifndef CURRENT_PACKAGE_VERSION-#define CURRENT_PACKAGE_VERSION "0.8.10.7"-#endif /* CURRENT_PACKAGE_VERSION */

− dist/build/fixpoint/autogen/Paths_liquid_fixpoint.hs

@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}-module Paths_liquid_fixpoint (-    version,-    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,-    getDataFileName, getSysconfDir-  ) where--import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude--#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch--version :: Version-version = Version [0,8,10,7] []-bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath--bindir     = "/Users/niki.vazou/.cabal/bin"-libdir     = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF"-dynlibdir  = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1"-datadir    = "/Users/niki.vazou/.cabal/share/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7"-libexecdir = "/Users/niki.vazou/.cabal/libexec/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7"-sysconfdir = "/Users/niki.vazou/.cabal/etc"--getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath-getBinDir = catchIO (getEnv "liquid_fixpoint_bindir") (\_ -> return bindir)-getLibDir = catchIO (getEnv "liquid_fixpoint_libdir") (\_ -> return libdir)-getDynLibDir = catchIO (getEnv "liquid_fixpoint_dynlibdir") (\_ -> return dynlibdir)-getDataDir = catchIO (getEnv "liquid_fixpoint_datadir") (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "liquid_fixpoint_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "liquid_fixpoint_sysconfdir") (\_ -> return sysconfdir)--getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do-  dir <- getDataDir-  return (dir ++ "/" ++ name)

− dist/build/fixpoint/autogen/cabal_macros.h

@@ -1,162 +0,0 @@-/* DO NOT EDIT: This file is automatically generated by Cabal */--/* package liquid-fixpoint-0.8.10.7 */-#ifndef VERSION_liquid_fixpoint-#define VERSION_liquid_fixpoint "0.8.10.7"-#endif /* VERSION_liquid_fixpoint */-#ifndef MIN_VERSION_liquid_fixpoint-#define MIN_VERSION_liquid_fixpoint(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  8 || \-  (major1) == 0 && (major2) == 8 && (minor) <= 10)-#endif /* MIN_VERSION_liquid_fixpoint */--/* package base-4.15.0.0 */-#ifndef VERSION_base-#define VERSION_base "4.15.0.0"-#endif /* VERSION_base */-#ifndef MIN_VERSION_base-#define MIN_VERSION_base(major1,major2,minor) (\-  (major1) <  4 || \-  (major1) == 4 && (major2) <  15 || \-  (major1) == 4 && (major2) == 15 && (minor) <= 0)-#endif /* MIN_VERSION_base */--/* package liquid-fixpoint-0.8.10.7 */-#ifndef VERSION_liquid_fixpoint-#define VERSION_liquid_fixpoint "0.8.10.7"-#endif /* VERSION_liquid_fixpoint */-#ifndef MIN_VERSION_liquid_fixpoint-#define MIN_VERSION_liquid_fixpoint(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  8 || \-  (major1) == 0 && (major2) == 8 && (minor) <= 10)-#endif /* MIN_VERSION_liquid_fixpoint */--/* tool alex-3.2.4 */-#ifndef TOOL_VERSION_alex-#define TOOL_VERSION_alex "3.2.4"-#endif /* TOOL_VERSION_alex */-#ifndef MIN_TOOL_VERSION_alex-#define MIN_TOOL_VERSION_alex(major1,major2,minor) (\-  (major1) <  3 || \-  (major1) == 3 && (major2) <  2 || \-  (major1) == 3 && (major2) == 2 && (minor) <= 4)-#endif /* MIN_TOOL_VERSION_alex */--/* tool gcc-12.0.5 */-#ifndef TOOL_VERSION_gcc-#define TOOL_VERSION_gcc "12.0.5"-#endif /* TOOL_VERSION_gcc */-#ifndef MIN_TOOL_VERSION_gcc-#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\-  (major1) <  12 || \-  (major1) == 12 && (major2) <  0 || \-  (major1) == 12 && (major2) == 0 && (minor) <= 5)-#endif /* MIN_TOOL_VERSION_gcc */--/* tool ghc-9.0.1 */-#ifndef TOOL_VERSION_ghc-#define TOOL_VERSION_ghc "9.0.1"-#endif /* TOOL_VERSION_ghc */-#ifndef MIN_TOOL_VERSION_ghc-#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\-  (major1) <  9 || \-  (major1) == 9 && (major2) <  0 || \-  (major1) == 9 && (major2) == 0 && (minor) <= 1)-#endif /* MIN_TOOL_VERSION_ghc */--/* tool ghc-pkg-9.0.1 */-#ifndef TOOL_VERSION_ghc_pkg-#define TOOL_VERSION_ghc_pkg "9.0.1"-#endif /* TOOL_VERSION_ghc_pkg */-#ifndef MIN_TOOL_VERSION_ghc_pkg-#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\-  (major1) <  9 || \-  (major1) == 9 && (major2) <  0 || \-  (major1) == 9 && (major2) == 0 && (minor) <= 1)-#endif /* MIN_TOOL_VERSION_ghc_pkg */--/* tool haddock-2.24.0 */-#ifndef TOOL_VERSION_haddock-#define TOOL_VERSION_haddock "2.24.0"-#endif /* TOOL_VERSION_haddock */-#ifndef MIN_TOOL_VERSION_haddock-#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\-  (major1) <  2 || \-  (major1) == 2 && (major2) <  24 || \-  (major1) == 2 && (major2) == 24 && (minor) <= 0)-#endif /* MIN_TOOL_VERSION_haddock */--/* tool happy-1.19.9 */-#ifndef TOOL_VERSION_happy-#define TOOL_VERSION_happy "1.19.9"-#endif /* TOOL_VERSION_happy */-#ifndef MIN_TOOL_VERSION_happy-#define MIN_TOOL_VERSION_happy(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  19 || \-  (major1) == 1 && (major2) == 19 && (minor) <= 9)-#endif /* MIN_TOOL_VERSION_happy */--/* tool hpc-0.68 */-#ifndef TOOL_VERSION_hpc-#define TOOL_VERSION_hpc "0.68"-#endif /* TOOL_VERSION_hpc */-#ifndef MIN_TOOL_VERSION_hpc-#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  68 || \-  (major1) == 0 && (major2) == 68 && (minor) <= 0)-#endif /* MIN_TOOL_VERSION_hpc */--/* tool hsc2hs-0.68.7 */-#ifndef TOOL_VERSION_hsc2hs-#define TOOL_VERSION_hsc2hs "0.68.7"-#endif /* TOOL_VERSION_hsc2hs */-#ifndef MIN_TOOL_VERSION_hsc2hs-#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  68 || \-  (major1) == 0 && (major2) == 68 && (minor) <= 7)-#endif /* MIN_TOOL_VERSION_hsc2hs */--/* tool hscolour-1.24 */-#ifndef TOOL_VERSION_hscolour-#define TOOL_VERSION_hscolour "1.24"-#endif /* TOOL_VERSION_hscolour */-#ifndef MIN_TOOL_VERSION_hscolour-#define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\-  (major1) <  1 || \-  (major1) == 1 && (major2) <  24 || \-  (major1) == 1 && (major2) == 24 && (minor) <= 0)-#endif /* MIN_TOOL_VERSION_hscolour */--/* tool pkg-config-0.29.2 */-#ifndef TOOL_VERSION_pkg_config-#define TOOL_VERSION_pkg_config "0.29.2"-#endif /* TOOL_VERSION_pkg_config */-#ifndef MIN_TOOL_VERSION_pkg_config-#define MIN_TOOL_VERSION_pkg_config(major1,major2,minor) (\-  (major1) <  0 || \-  (major1) == 0 && (major2) <  29 || \-  (major1) == 0 && (major2) == 29 && (minor) <= 2)-#endif /* MIN_TOOL_VERSION_pkg_config */--/* tool runghc-9.0.1 */-#ifndef TOOL_VERSION_runghc-#define TOOL_VERSION_runghc "9.0.1"-#endif /* TOOL_VERSION_runghc */-#ifndef MIN_TOOL_VERSION_runghc-#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\-  (major1) <  9 || \-  (major1) == 9 && (major2) <  0 || \-  (major1) == 9 && (major2) == 0 && (minor) <= 1)-#endif /* MIN_TOOL_VERSION_runghc */--#ifndef CURRENT_COMPONENT_ID-#define CURRENT_COMPONENT_ID "liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-fixpoint"-#endif /* CURRENT_COMPONENT_ID */-#ifndef CURRENT_PACKAGE_VERSION-#define CURRENT_PACKAGE_VERSION "0.8.10.7"-#endif /* CURRENT_PACKAGE_VERSION */

− dist/build/fixpoint/fixpoint

file too large to diff

− dist/build/fixpoint/fixpoint-tmp/Main.hi

binary file changed (9125 → absent bytes)

− dist/build/fixpoint/fixpoint-tmp/Main.o

binary file changed (13208 → absent bytes)

− dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-ghc9.0.1.dylib

file too large to diff

− dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.a

file too large to diff

− dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM-ghc9.0.1.dylib

file too large to diff

− dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM.a

file too large to diff

− dist/package.conf.inplace/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.conf

@@ -1,126 +0,0 @@-name: liquid-fixpoint-version: 0.8.10.7-id: liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-key: liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-license: BSD-3-Clause-copyright: 2010-17 Ranjit Jhala, University of California, San Diego.-maintainer: jhala@cs.ucsd.edu-author: Ranjit Jhala, Niki Vazou, Eric Seidel-homepage: https://github.com/ucsd-progsys/liquid-fixpoint-synopsis: Predicate Abstraction-based Horn-Clause/Implication Constraint Solver-description:-    This package implements an SMTLIB based Horn-Clause\/Logical Implication constraint-    solver used for Liquid Types.-    .-    The package includes:-    .-    1. Types for Expressions, Predicates, Constraints, Solutions-    2. Code for solving constraints-    .-    Requirements-    .-    In addition to the .cabal dependencies you require-    .-    * A Z3 (<http://z3.codeplex.com>) or CVC4 (<http://cvc4.cs.nyu.edu>) binary.-category: Language-abi: inplace-exposed: True-exposed-modules:-    Data.ShareMap Language.Fixpoint.Defunctionalize-    Language.Fixpoint.Graph Language.Fixpoint.Graph.Deps-    Language.Fixpoint.Graph.Indexed Language.Fixpoint.Graph.Partition-    Language.Fixpoint.Graph.Reducible Language.Fixpoint.Graph.Types-    Language.Fixpoint.Horn.Info Language.Fixpoint.Horn.Parse-    Language.Fixpoint.Horn.Solve Language.Fixpoint.Horn.Transformations-    Language.Fixpoint.Horn.Types Language.Fixpoint.Minimize-    Language.Fixpoint.Misc Language.Fixpoint.Parse-    Language.Fixpoint.Smt.Bitvector Language.Fixpoint.Smt.Interface-    Language.Fixpoint.Smt.Serialize Language.Fixpoint.Smt.Theories-    Language.Fixpoint.Smt.Types Language.Fixpoint.Solver-    Language.Fixpoint.Solver.Eliminate-    Language.Fixpoint.Solver.EnvironmentReduction-    Language.Fixpoint.Solver.Extensionality-    Language.Fixpoint.Solver.GradualSolution-    Language.Fixpoint.Solver.Instantiate Language.Fixpoint.Solver.Monad-    Language.Fixpoint.Solver.PLE Language.Fixpoint.Solver.Prettify-    Language.Fixpoint.Solver.Rewrite Language.Fixpoint.Solver.Sanitize-    Language.Fixpoint.Solver.Solution Language.Fixpoint.Solver.Solve-    Language.Fixpoint.Solver.Stats Language.Fixpoint.Solver.TrivialSort-    Language.Fixpoint.Solver.UniqifyBinds-    Language.Fixpoint.Solver.UniqifyKVars-    Language.Fixpoint.Solver.Worklist Language.Fixpoint.SortCheck-    Language.Fixpoint.Types Language.Fixpoint.Types.Config-    Language.Fixpoint.Types.Constraints-    Language.Fixpoint.Types.Environments Language.Fixpoint.Types.Errors-    Language.Fixpoint.Types.Graduals Language.Fixpoint.Types.Names-    Language.Fixpoint.Types.PrettyPrint-    Language.Fixpoint.Types.Refinements-    Language.Fixpoint.Types.Solutions Language.Fixpoint.Types.Sorts-    Language.Fixpoint.Types.Spans Language.Fixpoint.Types.Substitutions-    Language.Fixpoint.Types.Templates Language.Fixpoint.Types.Theories-    Language.Fixpoint.Types.Triggers Language.Fixpoint.Types.Utils-    Language.Fixpoint.Types.Visitor Language.Fixpoint.Utils.Builder-    Language.Fixpoint.Utils.Files Language.Fixpoint.Utils.Progress-    Language.Fixpoint.Utils.Statistics Language.Fixpoint.Utils.Trie-    Text.PrettyPrint.HughesPJ.Compat-hidden-modules: Paths_liquid_fixpoint-import-dirs: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/build-library-dirs: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/build-dynamic-library-dirs: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/build-data-dir: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7-hs-libraries: HSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-depends:-    base-4.15.0.0 ansi-terminal-0.11-DOUngjGM5e9DBdxKKdJoVq-    array-0.5.4.0 async-2.2.4-JeDGkdQL92SGvrTcykFE1G-    attoparsec-0.14.2-GRB4tkqiZ1lJ3VDtKSiDmp binary-0.8.8.0-    store-0.7.12-1jDuo34RRHF1Hy2bG8VuHK bytestring-0.10.12.1-    boxes-0.1.5-C3Kz8ochWvU21KQ3vfFzqc-    cereal-0.5.8.1-1rEYQzBD8E9DIUYY4RFjl8-    cmdargs-0.10.21-9JSptK8vQ5KGyQ5LWB6hlS containers-0.6.4.1-    deepseq-1.4.5.0 directory-1.3.6.1-    fgl-5.7.0.3-5OLLFynJZSREnalnrodEAD filepath-1.4.2.1-    hashable-1.3.3.0-D0do58bNrPk5L3yCngfJJ3-    intern-0.9.4-FjOGVQc5D9A9cT7GJ3znV mtl-2.2.2-    parallel-3.2.2.0-G9JTeCQCHda2yggytvFxi6-    parser-combinators-1.3.0-5jHqYWwdpCqFWQLuYLRvi6-    megaparsec-8.0.0-HpfmBpBmwaA25sr4odFZpU pretty-1.1.3.6-    process-1.6.11.0 stm-2.5.0.0 syb-0.7.2.1-1KAKIfi7jVfHb7rx2ko4wD-    text-1.2.4.1 transformers-0.5.6.2-    unordered-containers-0.2.14.0-L4skvY6vsWn5C5vZMnj1cY-    aeson-1.5.6.0-DHNSyhPFyS5bKQzGnVe65-    rest-rewrite-0.1.1-ExUfTOXktU57vIN1mThfaz-    ascii-progress-0.3.3.0-IvDhgho0XVI68QREgihigY-abi-depends: base-4.15.0.0=02cb1f9c5fbe783ec723114554c1a1bd-             ansi-terminal-0.11-DOUngjGM5e9DBdxKKdJoVq=d6c3710fa9fda55e0ebacd6cce99c895-             array-0.5.4.0=9a81a071217c73ead314239d931f3539-             async-2.2.4-JeDGkdQL92SGvrTcykFE1G=9b04d03d55892f910c05c503857c8315-             attoparsec-0.14.2-GRB4tkqiZ1lJ3VDtKSiDmp=1ac805cba81d1b6a4027ddfaa73a0f02-             binary-0.8.8.0=b29e0271e764eded9a7fe7f7efb29a00-             store-0.7.12-1jDuo34RRHF1Hy2bG8VuHK=3e81e9e2248a6603e4466219b77c99a6-             bytestring-0.10.12.1=bcf6a61abaf149418191c5b82a3f1f35-             boxes-0.1.5-C3Kz8ochWvU21KQ3vfFzqc=cb68f89029edf9163997bd4a9a25ebfb-             cereal-0.5.8.1-1rEYQzBD8E9DIUYY4RFjl8=9ad34802ac104316d41f1cbf1a6f5519-             cmdargs-0.10.21-9JSptK8vQ5KGyQ5LWB6hlS=9851f7363467bc98ccd2b7a763752398-             containers-0.6.4.1=9fdc55ef8690ff523eba389e5f991c4e-             deepseq-1.4.5.0=a3c53cf199b05b32e32750439c1fb094-             directory-1.3.6.1=69c9abca6e0cbd58b5dff3b7cc43d204-             fgl-5.7.0.3-5OLLFynJZSREnalnrodEAD=fbe6b7290463c97154a639b024be851a-             filepath-1.4.2.1=4dba1196734519d5fa5937d656a5f36a-             hashable-1.3.3.0-D0do58bNrPk5L3yCngfJJ3=30065752580855fe6ccd81f3bc4efcdd-             intern-0.9.4-FjOGVQc5D9A9cT7GJ3znV=657da685930e1d1a9dc583e8d6b2c5c7-             mtl-2.2.2=dbb5a8013d6af5aeb8382ab9f42b23e5-             parallel-3.2.2.0-G9JTeCQCHda2yggytvFxi6=639a5f668a4d607f889d7d7a865c37d8-             parser-combinators-1.3.0-5jHqYWwdpCqFWQLuYLRvi6=570d649fbaa64c76c448aba32cebadfb-             megaparsec-8.0.0-HpfmBpBmwaA25sr4odFZpU=7f6082726fd5ed2300d912861bbf6b71-             pretty-1.1.3.6=991926efc506d871d2b1df02dd84a1f3-             process-1.6.11.0=106f5dc09262f5ff85248631dfdbd424-             stm-2.5.0.0=1907802766f953b2b67d72785a26bcec-             syb-0.7.2.1-1KAKIfi7jVfHb7rx2ko4wD=5edc1b6becc78a39dd5d32482fc47761-             text-1.2.4.1=d3af972311c726304b525c2c823214fe-             transformers-0.5.6.2=6d61a65a7ab8e1f3ab98b9bf5aeaa056-             unordered-containers-0.2.14.0-L4skvY6vsWn5C5vZMnj1cY=869782fc6ea4d62ed36ae1c1536579d2-             aeson-1.5.6.0-DHNSyhPFyS5bKQzGnVe65=6425135f2ca91e6567b795bd3be87c9d-             rest-rewrite-0.1.1-ExUfTOXktU57vIN1mThfaz=4183a6c474b6a786b4d68be96afecbf5-             ascii-progress-0.3.3.0-IvDhgho0XVI68QREgihigY=c414b11a060f16e2c462cc641b7d66ec-haddock-interfaces: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/doc/html/liquid-fixpoint/liquid-fixpoint.haddock-haddock-html: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/doc/html/liquid-fixpoint

− dist/package.conf.inplace/package.cache

binary file changed (14951 → absent bytes)

− dist/package.conf.inplace/package.cache.lock

− dist/setup-config

binary file changed (754520 → absent bytes)

− git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch

@@ -1,13 +0,0 @@-diff --git a/Data/Git/Monad.hs b/Data/Git/Monad.hs-index 480af9f..27c3b3e 100644---- a/Data/Git/Monad.hs-+++ b/Data/Git/Monad.hs-@@ -130 +130 @@ instance Resolvable Git.RefName where--class (Functor m, Applicative m, Monad m) => GitMonad m where-+class (Functor m, Applicative m, Monad m, MonadFail m) => GitMonad m where-@@ -242,0 +243 @@ instance Monad GitM where-+instance MonadFail GitM where-@@ -315,0 +317 @@ instance Monad CommitAccessM where-+instance MonadFail CommitAccessM where-@@ -476,0 +479 @@ instance Monad CommitM where-+instance MonadFail CommitM where

− hie.yaml

@@ -1,8 +0,0 @@-cradle:-  stack:-    - path: "./src"-      component: "liquid-fixpoint:lib"-    - path: "./bin"-      component: "liquid-fixpoint:exe:fixpoint"-    - path: "./tests"-      component: "liquid-fixpoint:test:test"

liquid-fixpoint.cabal view

@@ -1,6 +1,6 @@-cabal-version:      2.2+cabal-version:      2.4 name:               liquid-fixpoint-version:            0.8.10.7+version:            0.9.0.2.1 synopsis:           Predicate Abstraction-based Horn-Clause/Implication Constraint Solver description:   This package implements an SMTLIB based Horn-Clause\/Logical Implication constraint@@ -16,15 +16,16 @@   In addition to the .cabal dependencies you require   .   * A Z3 (<http://z3.codeplex.com>) or CVC4 (<http://cvc4.cs.nyu.edu>) binary.-license:            BSD-3-Clause-license-file:       LICENSE-copyright:          2010-17 Ranjit Jhala, University of California, San Diego.+category:           Language+homepage:           https://github.com/ucsd-progsys/liquid-fixpoint#readme+bug-reports:        https://github.com/ucsd-progsys/liquid-fixpoint/issues author:             Ranjit Jhala, Niki Vazou, Eric Seidel maintainer:         jhala@cs.ucsd.edu-tested-with:        GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.3, GHC == 8.6.4, GHC == 8.10.1, GHC == 8.10.7-category:           Language-homepage:           https://github.com/ucsd-progsys/liquid-fixpoint+copyright:          2010-17 Ranjit Jhala, University of California, San Diego.+license:            BSD-3-Clause+license-file:       LICENSE build-type:         Simple+tested-with:        GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.3, GHC == 8.6.4, GHC == 8.10.1, GHC == 8.10.7 extra-source-files: tests/neg/*.fq                     tests/pos/*.fq                     unix/Language/Fixpoint/Utils/*.hs@@ -32,17 +33,21 @@                     tests/logs/cur/pin                     Makefile +common warnings+  ghc-options:+    -Wall+ source-repository head-  type:     git-  location: https://github.com/ucsd-progsys/liquid-fixpoint/+  type: git+  location: https://github.com/ucsd-progsys/liquid-fixpoint  flag devel-  default:     False-  manual:      True   description: turn on stricter error reporting for development+  manual: True+  default: False  library-  autogen-modules:  Paths_liquid_fixpoint+  import: warnings   exposed-modules:  Data.ShareMap                     Language.Fixpoint.Defunctionalize                     Language.Fixpoint.Graph@@ -51,11 +56,11 @@                     Language.Fixpoint.Graph.Partition                     Language.Fixpoint.Graph.Reducible                     Language.Fixpoint.Graph.Types+                    Language.Fixpoint.Horn.Info                     Language.Fixpoint.Horn.Parse                     Language.Fixpoint.Horn.Solve-                    Language.Fixpoint.Horn.Types                     Language.Fixpoint.Horn.Transformations-                    Language.Fixpoint.Horn.Info+                    Language.Fixpoint.Horn.Types                     Language.Fixpoint.Minimize                     Language.Fixpoint.Misc                     Language.Fixpoint.Parse@@ -65,15 +70,20 @@                     Language.Fixpoint.Smt.Theories                     Language.Fixpoint.Smt.Types                     Language.Fixpoint.Solver+                    Language.Fixpoint.Solver.Common                     Language.Fixpoint.Solver.Eliminate                     Language.Fixpoint.Solver.EnvironmentReduction+                    Language.Fixpoint.Solver.Extensionality                     Language.Fixpoint.Solver.GradualSolution+                    Language.Fixpoint.Solver.GradualSolve                     Language.Fixpoint.Solver.Instantiate-                    Language.Fixpoint.Solver.PLE+                    Language.Fixpoint.Solver.Interpreter                     Language.Fixpoint.Solver.Monad-                    Language.Fixpoint.Solver.Rewrite+                    Language.Fixpoint.Solver.PLE                     Language.Fixpoint.Solver.Prettify+                    Language.Fixpoint.Solver.Rewrite                     Language.Fixpoint.Solver.Sanitize+                    Language.Fixpoint.Solver.Simplify                     Language.Fixpoint.Solver.Solution                     Language.Fixpoint.Solver.Solve                     Language.Fixpoint.Solver.Stats@@ -81,7 +91,6 @@                     Language.Fixpoint.Solver.UniqifyBinds                     Language.Fixpoint.Solver.UniqifyKVars                     Language.Fixpoint.Solver.Worklist-                    Language.Fixpoint.Solver.Extensionality                     Language.Fixpoint.SortCheck                     Language.Fixpoint.Types                     Language.Fixpoint.Types.Config@@ -108,16 +117,18 @@                     Language.Fixpoint.Utils.Trie                     Text.PrettyPrint.HughesPJ.Compat   other-modules:    Paths_liquid_fixpoint+  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   src-  build-depends:    base                 >= 4.9.1.0 && < 5+  ghc-options:      -W -Wno-missing-methods -Wmissing-signatures+  build-depends:    aeson                   , ansi-terminal                   , array                   , async                   , attoparsec+                  , base                 >= 4.9.1.0 && < 5                   , binary-                  , store-                  , bytestring                   , boxes+                  , bytestring                   , cereal                   , cmdargs                   , containers@@ -125,86 +136,101 @@                   , directory                   , fgl                   , filepath-                  , hashable        >=1.3 && <1.3.4+                  , hashable                   , intern+                  , lens-family+                  , megaparsec           >= 7.0.0 && < 10                   , mtl                   , parallel                   , parser-combinators-                  , megaparsec           >= 7.0.0 && < 9                   , pretty               >= 1.1.3.1                   , process+                  , rest-rewrite >= 0.3.0                   , stm-                  , syb+                  , store+                  , vector < 0.13                   , syb                   , text                   , transformers                   , unordered-containers-                  , aeson-                  , rest-rewrite >= 0.1.1-  default-language: Haskell98-  ghc-options:      -W -fno-warn-missing-methods -fwarn-missing-signatures+  ghc-options:+    -fwrite-ide-info+    -hiedir=.hie    if flag(devel)     ghc-options: -Werror-   if !os(windows)     hs-source-dirs: unix     build-depends:  ascii-progress >= 0.3-   if os(windows)     hs-source-dirs: win+  default-language: Haskell98  executable fixpoint+  import: warnings   main-is:          Fixpoint.hs+  other-modules:    Paths_liquid_fixpoint+  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   bin+  ghc-options:      -threaded -W -Wno-missing-methods   build-depends:    base >= 4.9.1.0 && < 5, liquid-fixpoint-  default-language: Haskell98-  ghc-options:      -threaded -W -fno-warn-missing-methods-   if flag(devel)     ghc-options: -Werror+  default-language: Haskell98  test-suite test+  import: warnings   type:             exitcode-stdio-1.0   main-is:          test.hs   other-modules:    Paths_liquid_fixpoint+  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   tests-  build-tool-depends: liquid-fixpoint:fixpoint+  ghc-options:      -threaded   build-depends:    base          >= 4.9.1.0 && < 5                   , containers    >= 0.5                   , directory                   , filepath                   , mtl           >= 2.2.2+                  , optparse-applicative                   , process                   , stm           >= 2.4+                  , tagged                   , tasty         >= 0.10                   , tasty-ant-xml-                  , tasty-hunit                   , tasty-hunit   >= 0.9                   , tasty-rerun   >= 1.1.12                   , transformers  >= 0.5-  default-language: Haskell98-  ghc-options:      -threaded-   if flag(devel)     ghc-options: -Werror+  build-tool-depends: liquid-fixpoint:fixpoint+  default-language: Haskell98  test-suite tasty+  import: warnings   type:             exitcode-stdio-1.0   main-is:          Main.hs-  other-modules:    ParserTests+  other-modules:    Arbitrary+                    InterpretTests+                    ParserTests                     ShareMapReference                     ShareMapTests+                    SimplifyInterpreter+                    SimplifyPLE+                    SimplifyTests+                    UndoANFTests+                    Paths_liquid_fixpoint+  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   tests/tasty+  ghc-options:      -threaded   build-depends:    base            >= 4.9.1.0 && < 5-                  , hashable        >=1.3 && <1.3.4+                  , containers+                  , hashable                   , liquid-fixpoint                   , tasty           >= 0.10-                  , tasty-quickcheck                   , tasty-hunit     >= 0.9+                  , tasty-quickcheck+                  , text                   , unordered-containers-  default-language: Haskell98-  ghc-options:      -threaded-   if flag(devel)     ghc-options: -Werror+  default-language: Haskell98

− scripts/travis

@@ -1,137 +0,0 @@-#!/bin/bash--set -eu-set -o pipefail--## Helper Functions--function loud {-  echo "$ $@"-  $@-}--# Source: https://github.com/travis-ci/travis-build/blob/fc4ae8a2ffa1f2b3a2f62533bbc4f8a9be19a8ae/lib/travis/build/script/templates/header.sh#L104-L123-RED="\033[31;1m"-GREEN="\033[32;1m"-RESET="\033[0m"-function travis_retry {-  local result=0-  local count=1-  while [ $count -le 3 ]; do-    [ $result -ne 0 ] && {-      echo -e "\n${RED}The command \"$@\" failed. Retrying, $count of 3.${RESET}\n" >&2-    }-    set +e-    "$@"-    result=$?-    set -e-    [ $result -eq 0 ] && break-    count=$(($count + 1))-    sleep 1-  done--  [ $count -eq 4 ] && {-    echo "\n${RED}The command \"$@\" failed 3 times.${RESET}\n" >&2-  }--  return $result-}--function prevent_timeout {-  local cmd="$@"--  $cmd &-  local cmd_pid=$!--  poke_stdout &-  local poke_pid=$!--  wait $cmd_pid-  exit_code=$?--  kill $poke_pid-  (wait $poke_pid 2>/dev/null) || true--  return $exit_code-}--function poke_stdout {-  # Print an invisible character every minute-  while true; do-    echo -ne "\xE2\x80\x8B"-    sleep 60-  done-}--function pastebin {-  curl -s -F 'clbin=<-' https://clbin.com-}--## Testing Stages--function clean_cache {-  local smt="$1"--  loud ghc-pkg unregister liquid-fixpoint --force || true-  loud rm "$HOME/.cabal/bin/$smt" || true-}--function install_smt {-  local smt="$1"--  mkdir -p "$HOME/.cabal/bin"-  loud curl "http://goto.ucsd.edu/~gridaphobe/$smt" -o "$HOME/.cabal/bin/$smt"-  loud chmod a+x "$HOME/.cabal/bin/$smt"-}--function install_cabal_deps {-  if ! _install_cabal_deps; then-    echo " ==> Cabal install failed. Clearing dependency cache and retrying."-    loud rm -rf "$HOME/.cabal"-    loud rm -rf "$HOME/.ghc"-    _install_cabal_deps-  fi-}--function _install_cabal_deps {-  loud travis_retry cabal update || return 1-  loud travis_retry cabal install --only-dependencies --enable-tests || return 1-}--function do_build {-  loud cabal configure -fbuild-external --enable-tests -v2-  loud prevent_timeout cabal build -j2-  loud cabal haddock-}--function do_test {-  loud prevent_timeout ./dist/build/test/test-}--function dump_fail_logs {-  find . -type f -wholename '*/.liquid/*' -name '*.log' -print0 | while IFS= read -r -d $'\0' file; do-    echo "${file}:"-    echo "    $(pastebin < "${file}")"-  done-}--function test_source_pkg {-  loud cabal sdist--  local src_tgz="dist/$(cabal info . | awk '{print $2 ".tar.gz";exit}')"--  if [ -f "$src_tgz" ]; then-    loud prevent_timeout cabal install -j4 "$src_tgz"-  else-    echo "expected '$src_tgz' not found"-    return 1-  fi-}--## Run Test Stage--stage="$1"-shift--$stage "$@"-

− shell.nix

@@ -1,1 +0,0 @@-import ./. { makeEnv = true; }

− src/Language/Fixpoint/Congruence/Closure.hs

@@ -1,67 +0,0 @@-module Language.Fixpoint.Congruence.Closure where ---- import           Data.Hashable-import           Data.Interned-import           Control.Monad--- import           Control.Monad.Except      -- (MonadError(..))-import           Control.Monad.State.Strict-import qualified Data.HashMap.Strict        as M-import           Language.Fixpoint.Congruence.Types -import           Language.Fixpoint.Misc       (ifM)--sat :: CongQuery -> Bool -sat = undefined--type UF = State UFState--data UFState = U -  { ufPar   :: M.HashMap Id Term          -- ^ i :-> t      IF term 'i' has union-find parent 't'-  , ufPreds :: M.HashMap Id [(Int, Term)] -- ^ i :-> (j, t) IF term 'i' is 'j'-th arg in application 't'-  }--parent :: Term -> UF (Maybe Term)-parent u = M.lookup (identity u) <$> gets ufPar--find :: Term -> UF Id-find u = do -  mbU' <- parent u -  case mbU' of-    Nothing -> return (identity u) -    Just u' -> find u'  --union :: Term -> Term -> UF () -union _u _v = undefined -- _TODO --preds :: Id -> UF [(Int, Term)]-preds = undefined -- _TODO --isCong :: Term -> Term -> UF Bool -isCong = undefined -- _TODO --isEq :: Term -> Term -> UF Bool -isEq u v = do -  ui <- find u -  vi <- find v -  return (ui == vi)--congMerge :: (Int, Term) -> (Int, Term) -> UF ()-congMerge (i, u) (j, v) -  | i == j = ifM (isEq u v) -              (return ())-              (ifM (isCong u v) -                (merge u v)-                (return ()))-  | otherwise = return ()  --merge :: Term -> Term -> UF ()-merge u v = do -  ui <- find u-  vi <- find v -  unless (ui == vi) $ do -    uPs <- preds ui -    vPs <- preds vi -    union u v-    forM_ uPs $ \u' ->-      forM_ vPs $ \v' -> -        congMerge u' v'-

− src/Language/Fixpoint/Congruence/Types.hs

@@ -1,100 +0,0 @@-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}--module Language.Fixpoint.Congruence.Types -  ( -- * Queries -    CongQuery (..)-  , Equality (..)-  , Disequality (..)-    -    -- * Terms -  , Term -  , identity --    -- * Constructors-  , app-  , var-  ) where--import Data.Function (on)-import Data.Hashable-import Data.Interned--import qualified Language.Fixpoint.Types as F ---- 1.  x = y => f x = f y--- 2.  f(f(f(x))) = x => f(f(f(f(f(x))))) = x => f(x) = a --_examples = [t1, t2]-  where -    t1   = app "f" [var "x", var "y"] -    t2   = app "f" [var "x", var "y"] --data CongQuery   = Query [Equality] [Disequality]  -data Equality    = Eq    Term Term-data Disequality = Diseq Term Term------------------------------------------------------------------------------------- | Exported Constructors----------------------------------------------------------------------------------app :: F.Symbol -> [Term] -> Term-app f as = intern (BApp f as)--var :: F.Symbol -> Term-var x = intern (BVar x)------------------------------------------------------------------------------------- | Hash-consed Term DataType----------------------------------------------------------------------------------data Term -  = Var   {-# UNPACK #-} !Id !F.Symbol -  | App   {-# UNPACK #-} !Id !F.Symbol [Term]-----------------------------------------------------------------------------------data UninternedTerm-  = BVar !F.Symbol -  | BApp !F.Symbol [Term] --instance Interned Term where-  type Uninterned Term  = UninternedTerm-  data Description Term = DVar F.Symbol-                        | DApp F.Symbol [Id]-                          deriving Show-  describe (BApp f as)  = DApp f (identity <$> as) -  describe (BVar x)     = DVar x-  identify i            = go -    where-      go (BApp f as)    = App i f as-      go (BVar x)       = Var i x--  cache = termCache--identity :: Term -> Id-identity (App i _ _)   = i-identity (Var i _)     = i--instance Uninternable Term where-  unintern (App _ f as)  = BApp f as-  unintern (Var _ x)     = BVar x--termCache :: Cache Term-termCache = mkCache-{-# NOINLINE termCache #-}--instance Eq (Description Term) where-  DApp f as    == DApp f' as'    = f == f' && as == as'-  DVar x       == DVar x'       = x == x'-  _            == _             = False--instance Hashable (Description Term) where-  hashWithSalt s (DApp f a)   = s `hashWithSalt` (0 :: Int) `hashWithSalt` f `hashWithSalt` a-  hashWithSalt s (DVar n)     = s `hashWithSalt` (3 :: Int) `hashWithSalt` n--instance Eq Term where-  (==) = (==) `on` identity--instance Ord Term where-  compare = compare `on` identity-

src/Language/Fixpoint/Defunctionalize.hs view

@@ -1,10 +1,10 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE TupleSections        #-}-{-# LANGUAGE PatternGuards        #-} {-# LANGUAGE OverloadedStrings    #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -------------------------------------------------------------------------------- -- | `defunctionalize` traverses the query to: --      1. "normalize" lambda terms by renaming binders,@@ -18,18 +18,19 @@ --   `EApp` and `ELam` to determine the lambdas and redexes. -------------------------------------------------------------------------------- -module Language.Fixpoint.Defunctionalize +module Language.Fixpoint.Defunctionalize   ( defunctionalize   , Defunc(..)   , defuncAny-  ) where +  ) where  import qualified Data.HashMap.Strict as M import           Data.Hashable import           Control.Monad.State import           Language.Fixpoint.Misc            (fM, secondM, mapSnd) import           Language.Fixpoint.Solver.Sanitize (symbolEnv)-import           Language.Fixpoint.Types        hiding (allowHO)+import           Language.Fixpoint.Types        hiding (GInfo(..), allowHO, fi)+import qualified Language.Fixpoint.Types           as Types (GInfo(..)) import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.Visitor   (mapMExpr) -- import Debug.Trace (trace)@@ -54,7 +55,7 @@          >=> mapMExpr (fM normalizeLams)  reBind :: Expr -> DF Expr-reBind (ELam (x, s) e) = ((\y -> ELam (y, s) (subst1 e (x, EVar y))) <$> freshSym s)+reBind (ELam (x, s) e) = (\y -> ELam (y, s) (subst1 e (x, EVar y))) <$> freshSym s reBind e               = return e shiftLam :: Int -> Symbol -> Sort -> Expr -> Expr shiftLam i x t e = ELam (x_i, t) (e `subst1` (x, x_i_t))@@ -62,7 +63,10 @@     x_i          = lamArgSymbol i     x_i_t        = ECst (EVar x_i) t --- normalize lambda arguments [TODO: example]+-- | normalize lambda arguments [TODO: example]+--+-- Renames lambda bindings to lamb_arg##i. Each use of a lambda binding+-- is surrounded with a cast.  normalizeLams :: Expr -> Expr normalizeLams e = snd $ normalizeLamsFromTo 1 e@@ -70,7 +74,7 @@ normalizeLamsFromTo :: Int -> Expr -> (Int, Expr) normalizeLamsFromTo i   = go   where-    go (ELam (y, sy) e) = (i + 1, shiftLam i y sy e') where (i, e') = go e+    go (ELam (y, sy) e) = (i' + 1, shiftLam i' y sy e') where (i', e') = go e                           -- let (i', e') = go e                           --    y'       = lamArgSymbol i'  -- SHIFTLAM                           -- in (i' + 1, ELam (y', sy) (e' `subst1` (y, EVar y')))@@ -89,22 +93,22 @@ class Defunc a where   defunc :: a -> DF a -instance (Defunc (c a), TaggedC c a) => Defunc (GInfo c a) where+instance (Defunc (c a), TaggedC c a) => Defunc (Types.GInfo c a) where   defunc fi = do-    cm'    <- defunc $ cm    fi-    ws'    <- defunc $ ws    fi+    cm'    <- defunc $ Types.cm    fi+    ws'    <- defunc $ Types.ws    fi     -- NOPROP setBinds $ mconcat ((senv <$> M.elems (cm fi)) ++ (wenv <$> M.elems (ws fi)))-    gLits' <- defunc $ gLits fi-    dLits' <- defunc $ dLits fi-    bs'    <- defunc $ bs    fi-    ass'   <- defunc $ asserts fi+    gLits' <- defunc $ Types.gLits fi+    dLits' <- defunc $ Types.dLits fi+    bs'    <- defunc $ Types.bs    fi+    ass'   <- defunc $ Types.asserts fi     -- NOPROP quals' <- defunc $ quals fi-    return $ fi { cm      = cm'-                , ws      = ws'-                , gLits   = gLits'-                , dLits   = dLits'-                , bs      = bs'-                , asserts = ass'+    return $ fi { Types.cm      = cm'+                , Types.ws      = ws'+                , Types.gLits   = gLits'+                , Types.dLits   = dLits'+                , Types.bs      = bs'+                , Types.asserts = ass'                 }  instance (Defunc a) => Defunc (Triggered a) where@@ -114,12 +118,12 @@   defunc sc = do crhs' <- defunc $ _crhs sc                  return $ sc {_crhs = crhs'} -instance Defunc (WfC a)   where-  defunc wf@(WfC {}) = do+instance Defunc (WfC a) where+  defunc wf@WfC{} = do     let (x, t, k) = wrft wf     t' <- defunc t     return $ wf { wrft = (x, t', k) }-  defunc wf@(GWfC {}) = do+  defunc wf@GWfC{} = do     let (x, t, k) = wrft wf     t' <- defunc t     e' <- defunc $ wexpr wf@@ -143,7 +147,7 @@ instance Defunc a => Defunc (SEnv a) where   defunc = mapMSEnv defunc -instance Defunc BindEnv   where+instance Defunc (BindEnv a) where   defunc bs = do dfbs <- gets dfBEnv                  let f (i, xs) = if i `memberIBindEnv` dfbs                                        then  (i,) <$> defunc xs@@ -154,7 +158,7 @@     -- the bind does not appear in any contraint,     -- thus unique binders does not perform properly     -- The sort should be defunc, to ensure same sort on double binders-    matchSort (x, RR s r) = ((x,) . (`RR` r)) <$> defunc s+    matchSort (x, RR s r) = (x,) . (`RR` r) <$> defunc s  -- Sort defunctionalization [should be done by elaboration] instance Defunc Sort where@@ -166,7 +170,7 @@ instance (Defunc a, Eq k, Hashable k) => Defunc (M.HashMap k a) where   defunc m = M.fromList <$> mapM (secondM defunc) (M.toList m) -type DF    = State DFST+type DF = State DFST  data DFST = DFST   { dfFresh :: !Int@@ -184,7 +188,7 @@   , dfEnv   = env   , dfBEnv  = ibind   , dfHO    = allowHO cfg  || defunction cfg-  -- INVARIANT: lambads and redexes are not defunctionalized+  -- INVARIANT: lambdas and redexes are not defunctionalized   , dfLams  = []   , dfRedex = []   , dfBinds = mempty@@ -194,7 +198,7 @@ makeInitDFState cfg si   = makeDFState cfg       (symbolEnv cfg si)-      (mconcat ((senv <$> M.elems (cm si)) ++ (wenv <$> M.elems (ws si))))+      (mconcat ((senv <$> M.elems (Types.cm si)) ++ (wenv <$> M.elems (Types.ws si))))  -------------------------------------------------------------------------------- -- | Low level monad manipulation ----------------------------------------------@@ -205,8 +209,3 @@   let x = intSymbol "lambda_fun_" n   modify $ \s -> s {dfFresh = n + 1, dfBinds = insertSEnv x t (dfBinds s)}   return x----- | getLams and getRedexes return the (previously seen) lambdas and redexes,---   after "closing" them by quantifying out free vars corresponding to the---   fresh binders in `dfBinds`.

src/Language/Fixpoint/Graph/Deps.hs view

@@ -2,7 +2,6 @@ {-# LANGUAGE TupleSections         #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE RecordWildCards       #-}  module Language.Fixpoint.Graph.Deps (@@ -29,10 +28,6 @@  import           Prelude hiding (init) import           Data.Maybe                       (mapMaybe, fromMaybe)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup                   (Semigroup (..))-#endif- import           Data.Tree (flatten) import           Language.Fixpoint.Misc import           Language.Fixpoint.Utils.Files@@ -60,9 +55,9 @@ -------------------------------------------------------------------------------- slice :: (F.TaggedC c a) => Config -> F.GInfo c a -> F.GInfo c a ---------------------------------------------------------------------------------slice cfg fi -  | noslice cfg -  = fi +slice cfg fi+  | noslice cfg+  = fi   | otherwise   = fi { F.cm = cm'        , F.ws = ws' }@@ -82,7 +77,7 @@     be           = F.bs fi     cm           = F.cm fi -subcKVars :: (F.TaggedC c a) => F.BindEnv -> c a -> [F.KVar]+subcKVars :: (F.TaggedC c a) => F.BindEnv a -> c a -> [F.KVar] subcKVars be c = V.envKVars be c ++ V.rhsKVars c  --------------------------------------------------------------------------------@@ -225,22 +220,22 @@ fiKVars :: F.GInfo c a -> [F.KVar] fiKVars = M.keys . F.ws -ebindEdges :: (F.TaggedC c a) => [F.BindId] -> F.BindEnv -> c a -> [CEdge]+ebindEdges :: (F.TaggedC c a) => [F.BindId] -> F.BindEnv a -> c a -> [CEdge] ebindEdges ebs bs c =  [(EBind k, Cstr i ) | k  <- envEbinds xs bs c ]                     ++ [(Cstr i, EBind k') | k' <- rhsEbinds xs c ]   where     i          = F.subcId c-    xs         = fst . flip F.lookupBindEnv bs <$> ebs+    xs         = fst3 . flip F.lookupBindEnv bs <$> ebs  envEbinds :: (F.TaggedC c a, Foldable t) =>-             t F.Symbol -> F.BindEnv -> c a -> [F.Symbol]+             t F.Symbol -> F.BindEnv a -> c a -> [F.Symbol] envEbinds xs be c = [ x | x <- envBinds , x `elem` xs ]   where envBinds = fst <$> F.clhs be c rhsEbinds :: (Foldable t, F.TaggedC c a) =>              t F.Symbol -> c a -> [F.Symbol] rhsEbinds xs c = [ x | x <- F.syms (F.crhs c) , x `elem` xs ] -subcEdges :: (F.TaggedC c a) => F.BindEnv -> c a -> [CEdge]+subcEdges :: (F.TaggedC c a) => F.BindEnv a -> c a -> [CEdge] subcEdges bs c =  [(KVar k, Cstr i ) | k  <- V.envKVars bs c]                ++ [(Cstr i, KVar k') | k' <- V.rhsKVars c ]   where@@ -514,7 +509,7 @@ -- The returned map tells for each coonstraint writing a kvar -- which constraints are reading the kvar. cSuccM      :: [CEdge] -> CMap [F.SubcId]-cSuccM es    = (sortNub . concatMap kRdBy) <$> iWrites+cSuccM es    = sortNub . concatMap kRdBy <$> iWrites   where     kRdBy k  = M.lookupDefault [] k kReads     iWrites  = group [ (i, k) | (Cstr i, KVar k) <- es ]@@ -566,7 +561,7 @@   }  instance PTable Stats where-  ptable (Stats {..})  = DocTable [+  ptable Stats{..}  = DocTable [       ("# KVars [Cut]"    , pprint stNumKVCuts)     , ("# KVars [NonLin]" , pprint stNumKVNonLin)     , ("# KVars [All]"    , pprint stNumKVTotal)@@ -594,5 +589,5 @@     bs            = F.bs fi     cs            = M.elems (F.cm fi) -nlKVarsC :: (F.TaggedC c a) => F.BindEnv -> c a -> S.HashSet F.KVar+nlKVarsC :: (F.TaggedC c a) => F.BindEnv a -> c a -> S.HashSet F.KVar nlKVarsC bs c = S.fromList [ k |  (k, n) <- V.envKVarsN bs c, n >= 2]

src/Language/Fixpoint/Graph/Indexed.hs view

@@ -4,7 +4,6 @@ --   succ, pred lookup -------------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}  module Language.Fixpoint.Graph.Indexed (   -- * (Abstract) Indexed Graphs

src/Language/Fixpoint/Graph/Partition.hs view

@@ -39,12 +39,9 @@ -- import           Data.Function (on) import           Data.Maybe                     (fromMaybe) import           Data.Hashable-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup                 (Semigroup (..))-#endif- import           Text.PrettyPrint.HughesPJ.Compat import           Data.List (sortBy)+import           Data.Function (on) -- import qualified Data.HashSet              as S  -- import qualified Language.Fixpoint.Solver.Solution    as So@@ -59,7 +56,7 @@ data CPart c a = CPart { pws :: !(M.HashMap F.KVar (F.WfC a))                        , pcm :: !(M.HashMap Integer (c a))                        }-  + instance Semigroup (CPart c a) where   l <> r = CPart { pws = pws l <> pws r                  , pcm = pcm l <> pcm r@@ -68,7 +65,7 @@ instance Monoid (CPart c a) where    mempty      = CPart mempty mempty    mappend     = (<>)-   + -------------------------------------------------------------------------------- -- | Multicore info ------------------------------------------------------------ --------------------------------------------------------------------------------@@ -101,7 +98,7 @@ --   produce the maximum possible number of partitions. Or a MultiCore Info --   to control the partitioning -------------------------------------------------------------------------------partition' :: (F.TaggedC c a) +partition' :: (F.TaggedC c a)            => Maybe MCInfo -> F.GInfo c a -> [F.GInfo c a] ------------------------------------------------------------------------------ partition' mn fi  = case mn of@@ -113,8 +110,8 @@     pbc partF      = partitionByConstraints partF fi  -- | Partition an FInfo into a specific number of partitions of roughly equal--- amounts of work-partitionN :: MCInfo        -- ^ describes thresholds and partiton amounts+-- amounts of work.+partitionN :: MCInfo        -- ^ Describes thresholds and partition amounts            -> F.GInfo c a   -- ^ The originial FInfo            -> [CPart c a]   -- ^ A list of the smallest possible CParts            -> [F.GInfo c a] -- ^ At most N partitions of at least thresh work@@ -134,10 +131,7 @@       sortedParts = sortBy sortPredicate cp       unionFirstTwo (a:b:xs) = (a `mappend` b, xs)       unionFirstTwo _        = errorstar "Partition.partitionN.unionFirstTwo called on bad arguments"-      sortPredicate lhs rhs-         | cpartSize lhs < cpartSize rhs = GT-         | cpartSize lhs > cpartSize rhs = LT-         | otherwise = EQ+      sortPredicate = flip compare `on` cpartSize       insertSorted a []     = [a]       insertSorted a (x:xs) = if sortPredicate a x == LT                               then x : insertSorted a xs@@ -154,7 +148,7 @@  -- | Convert a CPart to an FInfo cpartToFinfo :: F.GInfo c a -> CPart c a -> F.GInfo c a-cpartToFinfo fi p = fi {F.ws = pws p, F.cm = pcm p} +cpartToFinfo fi p = fi {F.ws = pws p, F.cm = pcm p}  -- | Convert an FInfo to a CPart finfoToCpart :: F.GInfo c a -> CPart c a

src/Language/Fixpoint/Graph/Reducible.hs view

@@ -53,10 +53,12 @@ contains t x = x `elem` concatMap T.flatten t  isBackEdge :: [(Node, [Node])] -> Edge -> Bool-isBackEdge t (u,v) = v `elem` xs-  where-    (Just xs) = lookup u t+isBackEdge t (u,v) = case lookup u t of+  Just xs -> v `elem` xs+  -- REVIEW: Would False work instead of error?+  Nothing -> error "Unable to lookup back edge" -subcEdges' :: (F.TaggedC c a) => (F.KVar -> Node) -> F.BindEnv -> c a -> [(Node, Node)]++subcEdges' :: (F.TaggedC c a) => (F.KVar -> Node) -> F.BindEnv a -> c a -> [(Node, Node)] subcEdges' kvI be c = [(kvI k1, kvI k2) | k1 <- V.envKVars be c                                         , k2 <- V.kvarsExpr $ F.crhs c]

src/Language/Fixpoint/Graph/Types.hs view

@@ -72,14 +72,14 @@  instance PPrint CVertex where   pprintTidy _ (KVar k)  = doubleQuotes $ pprint $ kv k-  pprintTidy _ (EBind s)  = doubleQuotes $ pprint $ s+  pprintTidy _ (EBind s)  = doubleQuotes $ pprint s   pprintTidy _ (Cstr i)  = text "id_" <-> pprint i   pprintTidy _ (DKVar k) = pprint k   <-> text "*"   instance Hashable CVertex -data KVGraph    = KVGraph { kvgEdges :: [(CVertex, CVertex, [CVertex])] }+newtype KVGraph = KVGraph { kvgEdges :: [(CVertex, CVertex, [CVertex])] } type CEdge      = (CVertex, CVertex) type Comps a    = [[a]] type KVComps    = Comps CVertex

src/Language/Fixpoint/Horn/Info.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-} @@ -11,13 +8,13 @@ import qualified Data.HashMap.Strict            as M import qualified Data.List                      as L import qualified Data.Tuple                     as Tuple-import qualified Data.Maybe                     as Mb import           Data.Either                    (partitionEithers) import           GHC.Generics                   (Generic) import qualified Language.Fixpoint.Misc         as Misc import qualified Language.Fixpoint.Types        as F import qualified Language.Fixpoint.Types.Config as F import qualified Language.Fixpoint.Horn.Types   as H+import Data.Maybe (fromMaybe)  hornFInfo :: F.Config -> H.Query a -> F.FInfo a hornFInfo cfg q = mempty@@ -37,38 +34,38 @@     (be2, ebs, cs) = hornSubCs be1 kve hCst     hCst           = H.qCstr q -axEnv :: F.Config -> H.Query a -> M.HashMap F.SubcId b -> F.AxiomEnv -axEnv cfg q cs = mempty +axEnv :: F.Config -> H.Query a -> M.HashMap F.SubcId b -> F.AxiomEnv+axEnv cfg q cs = mempty   { F.aenvEqs    = H.qEqns q   , F.aenvSimpl  = H.qMats q-  , F.aenvExpand = if F.rewriteAxioms cfg then const True <$> cs else mempty-  } +  , F.aenvExpand = if F.rewriteAxioms cfg then True <$ cs else mempty+  }  -----------------------------------------------------------------------------------hornSubCs :: F.BindEnv -> KVEnv a -> H.Cstr a-          -> (F.BindEnv, [F.BindId], M.HashMap F.SubcId (F.SubC a))+hornSubCs :: F.BindEnv a -> KVEnv a -> H.Cstr a+          -> (F.BindEnv a, [F.BindId], M.HashMap F.SubcId (F.SubC a)) ---------------------------------------------------------------------------------- hornSubCs be kve c = (be', ebs, M.fromList (F.addIds cs))   where-    (be', ebs, cs)      = goS kve F.emptyIBindEnv lhs0 be c-    lhs0           = bindSortedReft kve H.dummyBind+    (be', ebs, cs) = goS kve F.emptyIBindEnv be c+    -- lhs0           = bindSortedReft kve H.dummyBind  -- | @goS@ recursively traverses the NNF constraint to build up a list --   of the vanilla @SubC@ constraints. -goS :: KVEnv a -> F.IBindEnv -> F.SortedReft -> F.BindEnv -> H.Cstr a-    -> (F.BindEnv, [F.BindId], [F.SubC a])+goS :: KVEnv a -> F.IBindEnv ->  F.BindEnv a -> H.Cstr a+    -> (F.BindEnv a, [F.BindId], [F.SubC a]) -goS kve env lhs be c = (be', mEbs, subcs)+goS kve env be c = (be', mEbs, subcs)   where-    (be', ecs) = goS' kve env lhs be c+    (be', ecs) = goS' kve env Nothing be c     (mEbs, subcs) = partitionEithers ecs -goS' :: KVEnv a -> F.IBindEnv -> F.SortedReft -> F.BindEnv -> H.Cstr a-    -> (F.BindEnv, [Either F.BindId (F.SubC a)])+goS' :: KVEnv a -> F.IBindEnv -> Maybe F.SortedReft -> F.BindEnv a -> H.Cstr a+    -> (F.BindEnv a, [Either F.BindId (F.SubC a)]) goS' kve env lhs be (H.Head p l) = (be, [Right subc])   where-    subc                        = F.mkSubC env lhs rhs Nothing [] l+    subc                        = myMkSubC env lhs rhs Nothing [] l     rhs                         = updSortedReft kve lhs p  goS' kve env lhs be (H.CAnd cs)  = (be', concat subcss)@@ -77,24 +74,38 @@  goS' kve env _   be (H.All b c)  = (be'', subcs)   where-    (be'', subcs)               = goS' kve env' bSR be' c-    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR be+    (be'', subcs)               = goS' kve env' (Just bSR) be' c+    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR (H.bMeta b) be     bSR                         = bindSortedReft kve b     env'                        = F.insertsIBindEnv [bId] env  goS' kve env _   be (H.Any b c)  = (be'', Left bId : subcs)   where-    (be'', subcs)               = goS' kve env' bSR be' c-    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR be+    (be'', subcs)               = goS' kve env' (Just bSR) be' c+    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR (H.bMeta b) be     bSR                         = bindSortedReft kve b     env'                        = F.insertsIBindEnv [bId] env -bindSortedReft :: KVEnv a -> H.Bind -> F.SortedReft-bindSortedReft kve (H.Bind x t p) = F.RR t (F.Reft (x, predExpr kve p))+myMkSubC :: F.IBindEnv -> Maybe F.SortedReft -> F.SortedReft -> Maybe Integer -> F.Tag -> a -> F.SubC a+myMkSubC be lhsMb rhs x y z = F.mkSubC be lhs rhs x y z+  where+    lhs = fromMaybe def lhsMb+    def = F.trueSortedReft (F.sr_sort rhs) -updSortedReft :: KVEnv a -> F.SortedReft -> H.Pred -> F.SortedReft-updSortedReft kve (F.RR s (F.Reft (v, _))) p = F.RR s (F.Reft (v, predExpr kve p))+bindSortedReft :: KVEnv a -> H.Bind a -> F.SortedReft+bindSortedReft kve (H.Bind x t p _) = F.RR t (F.Reft (x, predExpr kve p)) +updSortedReft :: KVEnv a -> Maybe F.SortedReft -> H.Pred -> F.SortedReft+updSortedReft kve lhs p = F.RR s (F.Reft (v, predExpr kve p))+   where+      (s, v) = case lhs of+                 Just (F.RR ss (F.Reft (vv, _))) -> (ss, vv)+                 Nothing                       -> (F.intSort, F.dummySymbol)++-- dummyBind :: a -> Bind a+-- dummyBind = Bind F.dummySymbol F.intSort (PAnd [])++ predExpr :: KVEnv a -> H.Pred -> F.Expr predExpr kve        = go   where@@ -106,11 +117,11 @@ kvApp kve k ys = F.PKVar (F.KV k) su   where     su         = F.mkSubst (zip params (F.eVar <$> ys))-    params     = Mb.fromMaybe err1 $ kvParams <$> M.lookup k kve+    params     = maybe err1 kvParams (M.lookup k kve)     err1       = F.panic ("Unknown Horn variable: " ++ F.showpp k)  -----------------------------------------------------------------------------------hornWfs :: F.BindEnv -> [H.Var a] -> (F.BindEnv, KVEnv a)+hornWfs :: F.BindEnv a -> [H.Var a] -> (F.BindEnv a, KVEnv a) ---------------------------------------------------------------------------------- hornWfs be vars = (be', kve)   where@@ -118,8 +129,8 @@     (be', is)   = L.mapAccumL kvInfo be vars     kname       = H.hvName . kvVar -kvInfo :: F.BindEnv -> H.Var a -> (F.BindEnv, KVInfo a)-kvInfo be k       = (be', KVInfo k (fst <$> xts) wfc)+kvInfo :: F.BindEnv a -> H.Var a -> (F.BindEnv a, KVInfo a)+kvInfo be k       = (be', KVInfo k (Misc.fst3 <$> xts) wfc)   where     -- make the WfC     wfc           = F.WfC wenv wrft  (H.hvMeta k)@@ -127,12 +138,13 @@     wrft          = (x, t, F.KV (H.hvName k))     -- add the binders     (be', ids)    = L.mapAccumL insertBE be xts'-    ((x,t), xts') = Misc.safeUncons "Horn var with no args" xts+    ((x,t,_), xts') = Misc.safeUncons "Horn var with no args" xts     -- make the parameters-    xts           = [ (hvarArg k i, t) | (t, i) <- zip (H.hvArgs k) [0..] ]+    xts           = [ (hvarArg k i, t', a) | (t', i) <- zip (H.hvArgs k) [0..] ]+    a             = H.hvMeta k -insertBE :: F.BindEnv -> (F.Symbol, F.Sort) -> (F.BindEnv, F.BindId)-insertBE be (x, t) = Tuple.swap $ F.insertBindEnv x (F.trueSortedReft t) be+insertBE :: F.BindEnv a -> (F.Symbol, F.Sort, a) -> (F.BindEnv a, F.BindId)+insertBE be (x, t, a) = Tuple.swap $ F.insertBindEnv x (F.trueSortedReft t) a be  ---------------------------------------------------------------------------------- -- | Data types and helpers for manipulating information about KVars

src/Language/Fixpoint/Horn/Parse.hs view

@@ -30,8 +30,8 @@   , H.qCstr  = H.CAnd     [ c     | HCstr c  <- things ]   , H.qCon   = M.fromList [ (x,t) | HCon x t <- things ]   , H.qDis   = M.fromList [ (x,t) | HDis x t <- things ]-  , H.qEqns  =            [ e     | HDef e  <- things ] -  , H.qMats  =            [ m     | HMat m  <- things ] +  , H.qEqns  =            [ e     | HDef e  <- things ]+  , H.qMats  =            [ m     | HMat m  <- things ]   , H.qData  =            [ dd    | HDat dd <- things ]   } @@ -46,9 +46,9 @@   -- for uninterpred functions and ADT constructors   | HCon  F.Symbol F.Sort   | HDis  F.Symbol F.Sort-  | HDef  F.Equation +  | HDef  F.Equation   | HMat  F.Rewrite-  | HDat  F.DataDecl+  | HDat !F.DataDecl   | HOpt !String   deriving (Functor) @@ -70,17 +70,16 @@ ------------------------------------------------------------------------------- hCstrP = parens body   where-    body =  H.CAnd <$> (reserved "and"    *> some hCstrP)+    body =  H.CAnd <$> (reserved "and"    *> many hCstrP)         <|> H.All  <$> (reserved "forall" *> hBindP)      <*> hCstrP         <|> H.Any  <$> (reserved "exists" *> hBindP)      <*> hCstrP         <|> H.Head <$> (reserved "tag"    *> hPredP)      <*> (H.Tag <$> stringLiteral)         <|> H.Head <$> hPredP                             <*> pure H.NoTag -hBindP :: Parser H.Bind+hBindP :: Parser (H.Bind H.Tag) hBindP   = parens $ do   (x, t) <- symSortP-  p      <- hPredP-  return  $ H.Bind x t p+  H.Bind x t <$> hPredP <*> pure H.NoTag  ------------------------------------------------------------------------------- hPredP :: Parser H.Pred@@ -113,7 +112,7 @@ -------------------------------------------------------------------------------  hVarP :: Parser (H.Var H.Tag)-hVarP = H.HVar <$> kvSymP <*> parens (some (parens sortP)) <*> pure H.NoTag +hVarP = H.HVar <$> kvSymP <*> parens (some (parens sortP)) <*> pure H.NoTag  ------------------------------------------------------------------------------- -- | Helpers@@ -121,5 +120,3 @@  symSortP :: Parser (F.Symbol, F.Sort) symSortP = parens ((,) <$> symbolP <*> sortP)--

src/Language/Fixpoint/Horn/Solve.hs view

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ ------------------------------------------------------------------------------- -- | This module defines a function to solve NNF constraints, --   by reducing them to the standard FInfo.@@ -29,12 +31,12 @@ ---------------------------------------------------------------------------------- solveHorn cfg = do   (q, opts) <- parseQuery cfg-  +   -- If you want to set --eliminate=none, you better make it a pragma   cfg <- if F.eliminate cfg == F.None            then pure (cfg { F.eliminate =  F.Some })            else pure cfg-  +   cfg <- F.withPragmas cfg opts    when (F.save cfg) (saveHornQuery cfg q)@@ -43,7 +45,7 @@   Solver.resultExitCode cfg r  parseQuery :: F.Config -> IO (H.Query H.Tag, [String])-parseQuery cfg +parseQuery cfg   | F.stdin cfg = Parse.parseFromStdIn H.hornP   | otherwise   = Parse.parseFromFile H.hornP (F.srcFile cfg) @@ -77,4 +79,3 @@   whenLoud $ putStrLn $ F.showpp c   q <- eliminate cfg ({- void $ -} q { H.qCstr = c })   Solver.solve cfg (hornFInfo cfg q)-

src/Language/Fixpoint/Horn/Transformations.hs view

@@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE LambdaCase  #-} {-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE TupleSections  #-}++{-# OPTIONS_GHC -Wno-orphans        #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Horn.Transformations (     uniq   , flatten@@ -22,7 +24,7 @@ import qualified Data.HashMap.Strict          as M import           Data.String                  (IsString (..)) import           Data.Either                  (partitionEithers, rights)-import           Data.List                    (nub)+import           Data.List                    (nub, foldl') import qualified Data.Set                     as S import qualified Data.HashSet                 as HS import qualified Data.Graph                   as DG@@ -30,7 +32,7 @@ import           Data.Maybe                   (catMaybes, mapMaybe, fromMaybe) import           Language.Fixpoint.Types.Visitor as V import           System.Console.CmdArgs.Verbosity-import           Data.Bifunctor (second)+import           Data.Bifunctor (first, second) import System.IO (hFlush, stdout) -- import qualified Debug.Trace as DBG @@ -50,13 +52,15 @@ printPiSols :: (F.PPrint a1, F.PPrint a2, F.PPrint a3) =>                M.HashMap a1 ((a4, a2), a3) -> IO () printPiSols piSols =-  sequence_ $ ((\(piVar, ((_, args), cstr)) -> do+  mapM_+    (\(piVar, ((_, args), cstr)) -> do                   putStr $ F.showpp piVar                   putStr " := "                   putStrLn $ F.showpp args                   putStrLn $ F.showpp cstr                   putStr "\n"-                  hFlush stdout) <$> M.toList piSols)+                  hFlush stdout)+    (M.toList piSols) ---------------  -- type Sol a = M.HashMap F.Symbol (Either (Either [[Bind]] (Cstr a)) F.Expr)@@ -85,9 +89,13 @@   whenLoud $ putStrLn $ F.showpp poked    whenLoud $ putStrLn "Skolemized + split:"-  let (Just _horn, Just _side) = split poked+  let (_horn, _side) = case split poked of+                        (Just h, Just s) -> (h, s)+                        _ -> error "Couldn't split poked in solveEbs"+   let horn = flatten . pruneTauts $ _horn   let side = flatten . pruneTauts $ _side+   whenLoud $ putStrLn $ F.showpp (horn, side)    -- collect predicate variables@@ -122,7 +130,7 @@   let solvedSide = substPiSols solvedPiCstrs side'   whenLoud $ putStrLn $ F.showpp solvedSide -  pure $ (Query qs vs (CAnd [solvedHorn, solvedSide]) cons dist eqns mats dds)+  pure (Query qs vs (CAnd [solvedHorn, solvedSide]) cons dist eqns mats dds)  -- | Collects the defining constraint for π -- that is, given `∀ Γ.∀ n.π => c`, returns `((π, n:Γ), c)`@@ -135,7 +143,7 @@      go :: Cstr a -> ([F.Symbol], [[F.Symbol]], Maybe (Cstr a))     go (CAnd cs) = (\(as, bs, cs) -> (concat as, concat bs, cAndMaybes cs)) $ unzip3 $ go <$> cs-    go (All b@(Bind n _ (Var k' xs)) c')+    go (All b@(Bind n _ (Var k' xs) _) c')       | k == k' = ([n], [S.toList $ S.fromList xs `S.difference` S.singleton n], Just c')       | otherwise = map3 (fmap (All b)) (go c')     go (All b c') = map3 (fmap (All b)) (go c')@@ -159,7 +167,7 @@  -- TODO: rewrite to use CC solPi :: S.Set F.Symbol -> F.Symbol -> F.Symbol -> S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> Cstr a -> Pred-solPi measures basePi n args piSols c = trace ("\n\nsolPi: " <> F.showpp basePi <> "\n\n" <> F.showpp n <> "\n" <> F.showpp (S.toList args) <> "\n" <> F.showpp ((\(a, _, c) -> (a, c)) <$> edges) <> "\n" <> F.showpp (sols n) <> "\n" <> F.showpp rewritten <> "\n" <> F.showpp c <> "\n\n") $ PAnd $ rewritten+solPi measures basePi n args piSols c = trace ("\n\nsolPi: " <> F.showpp basePi <> "\n\n" <> F.showpp n <> "\n" <> F.showpp (S.toList args) <> "\n" <> F.showpp ((\(a, _, c) -> (a, c)) <$> edges) <> "\n" <> F.showpp (sols n) <> "\n" <> F.showpp rewritten <> "\n" <> F.showpp c <> "\n\n") $ PAnd rewritten   where     rewritten = rewriteWithEqualities measures n args equalities     equalities = (nub . fst) $ go (S.singleton basePi) c@@ -171,14 +179,14 @@      go :: S.Set F.Symbol -> Cstr a -> ([(F.Symbol, F.Expr)], S.Set F.Symbol)     go visited (Head p _) = (collectEqualities p, visited)-    go visited (CAnd cs) = foldl (\(eqs, visited) c -> let (eqs', visited') = go visited c in (eqs' <> eqs, visited')) (mempty, visited) cs-    go visited (All (Bind _ _ (Var pi _)) c)+    go visited (CAnd cs) = foldl' (\(eqs, visited) c -> let (eqs', visited') = go visited c in (eqs' <> eqs, visited')) (mempty, visited) cs+    go visited (All (Bind _ _ (Var pi _) _) c)       | S.member pi visited = go visited c       | otherwise = let (_, defC) = (piSols M.! pi)                         (eqs', newVisited) = go (S.insert pi visited) defC                         (eqs'', newVisited') = go newVisited c in           (eqs' <> eqs'', newVisited')-    go visited (All (Bind _ _ p) c) = let (eqs, visited') = go visited c in+    go visited (All (Bind _ _ p _) c) = let (eqs, visited') = go visited c in       (eqs <> collectEqualities p, visited')     go _ Any{} = error "exists should not be present in piSols" @@ -233,11 +241,11 @@   where     go _ (Head c l) = Head c l     go xs (CAnd c)   = CAnd (go xs <$> c)-    go xs (All b c2) = All b $ go ((bSym b):xs) c2-    go xs (Any b@(Bind x t p) c2) = CAnd [All b' $ CAnd [Head p l, go (x:xs) c2], Any b (Head pi l)]+    go xs (All b c2) = All b $ go (bSym b : xs) c2+    go xs (Any b@(Bind x t p ann) c2) = CAnd [All b' $ CAnd [Head p l, go (x:xs) c2], Any b (Head pi l)]       -- TODO: actually use the renamer?       where-        b' = Bind x t pi+        b' = Bind x t pi ann         pi = piVar x xs         l  = cLabel c2 @@ -378,14 +386,17 @@ elimPis [] cc = cc elimPis (n:ns) (horn, side) = elimPis ns (apply horn, apply side) -- TODO: handle this error?-  where Just nSol = defs n horn+  where nSol = case defs n horn of+                 Just nSol -> nSol+                 Nothing -> error "Unexpected nothing elimPis"+         apply = applyPi (piSym n) nSol  -- TODO: PAnd may be a problem applyPi :: F.Symbol -> Cstr a -> Cstr a -> Cstr a-applyPi k defs (All (Bind x t (Var k' _xs)) c)+applyPi k defs (All (Bind x t (Var k' _xs) ann) c)   | k == k'-  = All (Bind x t (Reft $ cstrToExpr defs)) c+  = All (Bind x t (Reft $ cstrToExpr defs) ann) c applyPi k bp (CAnd cs)   = CAnd $ applyPi k bp <$> cs applyPi k bp (All b c)@@ -453,7 +464,7 @@  defs :: F.Symbol -> Cstr a -> Maybe (Cstr a) defs x (CAnd cs) = andMaybes $ defs x <$> cs-defs x (All (Bind x' _ _) c)+defs x (All (Bind x' _ _ _) c)   | x' == x   = pure c defs x (All _ c) = defs x c@@ -463,8 +474,8 @@ cstrToExpr :: Cstr a -> F.Expr cstrToExpr (Head p _) = predToExpr p cstrToExpr (CAnd cs) = F.PAnd $ cstrToExpr <$> cs-cstrToExpr (All (Bind x t p) c) = F.PAll [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c-cstrToExpr (Any (Bind x t p) c) = F.PExist [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c+cstrToExpr (All (Bind x t p _) c) = F.PAll [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c+cstrToExpr (Any (Bind x t p _) c) = F.PExist [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c  predToExpr :: Pred -> F.Expr predToExpr (Reft e) = e@@ -555,8 +566,8 @@ instance V.Visitable (Cstr a) where   visit v c (CAnd cs) = CAnd <$> mapM (visit v c) cs   visit v c (Head p a) = Head <$> visit v c p <*> pure a-  visit v ctx (All (Bind x t p) c) = All <$> (Bind x t <$> visit v ctx p) <*> visit v ctx c-  visit v ctx (Any (Bind x t p) c) = All <$> (Bind x t <$> visit v ctx p) <*> visit v ctx c+  visit v ctx (All (Bind x t p l) c) = All <$> (Bind x t <$> visit v ctx p <*> pure l) <*> visit v ctx c+  visit v ctx (Any (Bind x t p l) c) = All <$> (Bind x t <$> visit v ctx p <*> pure l) <*> visit v ctx c  ------------------------------------------------------------------------------ -- | Quantifier elimination for use with implicit solver@@ -621,7 +632,7 @@     nResult = (n, makeWellFormed 15 $ sols n)     argResults = map (\arg -> (arg, makeWellFormed 15 $ sols arg)) (S.toList args) -    preds = (mconcat $ (\(x, es) -> mconcat $ mkEquality x <$> es) <$> (nResult:argResults))+    preds = mconcat $ (\(x, es) -> mconcat $ mkEquality x <$> es) <$> (nResult:argResults)      mkEquality x e = [Reft (F.PAtom F.Eq (F.EVar x) e)] @@ -630,10 +641,10 @@       Nothing -> []       Just vertex -> nub $ filter (/= F.EVar x) $ mconcat [es | ((_, es), _, _) <- vf <$> DG.reachable eGraph vertex] -    argsAndPrims = args `S.union` (S.fromList $ map fst $ F.toListSEnv $ F.theorySymbols []) `S.union`measures+    argsAndPrims = args `S.union` S.fromList (map fst $ F.toListSEnv $ F.theorySymbols []) `S.union`measures      isWellFormed :: F.Expr -> Bool-    isWellFormed e = (S.fromList $ F.syms e) `S.isSubsetOf` argsAndPrims+    isWellFormed e = S.fromList (F.syms e) `S.isSubsetOf` argsAndPrims      makeWellFormed :: Int -> [F.Expr] -> [F.Expr]     makeWellFormed 0 es = filter isWellFormed es -- We solved it. Maybe.@@ -641,7 +652,7 @@       where         go e = if isWellFormed e then [e] else rewrite rewrites [e]           where-            needSolving = (S.fromList $ F.syms e) `S.difference` argsAndPrims+            needSolving = S.fromList (F.syms e) `S.difference` argsAndPrims             rewrites = (\x -> (x, filter (/= F.EVar x) $ sols x)) <$> S.toList needSolving             rewrite [] es = es             rewrite ((x, rewrites):rewrites') es = rewrite rewrites' $ [F.subst (F.mkSubst [(x, e')]) e | e' <- rewrites, e <- es]@@ -679,10 +690,10 @@ substPiSols :: M.HashMap F.Symbol Pred -> Cstr a -> Cstr a substPiSols _ c@Head{} = c substPiSols piSols (CAnd cs) = CAnd $ substPiSols piSols <$> cs-substPiSols piSols (All (Bind x t p) c)-  | Var k _ <- p = All (Bind x t $ M.lookupDefault p k piSols) (substPiSols piSols c)-  | otherwise = All (Bind x t p) (substPiSols piSols c)-substPiSols piSols (Any (Bind n _ p) c)+substPiSols piSols (All (Bind x t p l) c)+  | Var k _ <- p = All (Bind x t (M.lookupDefault p k piSols) l) (substPiSols piSols c)+  | otherwise = All (Bind x t p l) (substPiSols piSols c)+substPiSols piSols (Any (Bind n _ p _) c)   | Head (Var pi _) label <- c, Just sol <- M.lookup pi piSols =     case findSol n sol of       Just e -> Head (flatten $ PAnd $ (\pred -> F.subst1 pred (n, e)) <$> [p, sol]) label@@ -712,14 +723,14 @@ uniq c = evalState (uniq' c) M.empty  uniq' :: Cstr a -> State RenameMap (Cstr a)-uniq' (Head c a) = Head <$> gets (rename c) <*> pure a+uniq' (Head c a) = gets (Head . rename c) <*> pure a uniq' (CAnd c) = CAnd <$> mapM uniq' c-uniq' (All b@(Bind x _ _) c2) = do+uniq' (All b@(Bind x _ _ _) c2) = do     b' <- uBind b     c2' <- uniq' c2     modify $ popName x     pure $ All b' c2'-uniq' (Any b@(Bind x _ _) c2) = do+uniq' (Any b@(Bind x _ _ _) c2) = do     b' <- uBind b     c2' <- uniq' c2     modify $ popName x@@ -732,12 +743,11 @@ pushName Nothing = Just (0, [0]) pushName (Just (i, is)) = Just (i + 1, (i + 1):is) -uBind :: Bind -> State RenameMap Bind-uBind (Bind x t p) = do+uBind :: Bind a -> State RenameMap (Bind a)+uBind (Bind x t p l) = do    x' <- uVariable x-   -- nmap <- get    p' <- gets (rename p)-   pure $ Bind x' t p'+   pure $ Bind x' t p' l  uVariable :: IsString a => F.Symbol -> State RenameMap a uVariable x = do@@ -773,7 +783,7 @@ ------------------------------------------------------------------------------ elim c = if S.null $ boundKvars res then res else error "called elim on cyclic constraint"   where-  res = S.foldl elim1 c (boundKvars c)+  res = S.foldl' elim1 c (boundKvars c)  elim1 :: Cstr a -> F.Symbol -> Cstr a -- Find a `sol1` solution to a kvar `k`, and then subsitute in the solution for@@ -795,8 +805,8 @@     go c@(Head (Var k' _) _)       | k' == k = Right c     go (Head _ l) = Left l-    go c@(All (Bind _ _ p) c') =-      if k `S.member` (pKVars p) then Right c else go c'+    go c@(All (Bind _ _ p _) c') =+      if k `S.member` pKVars p then Right c else go c'     go Any{} = error "any should not appear after poke"      -- if kvar doesn't appear, then just return the left@@ -829,9 +839,9 @@ --  - `bss` is a Hyp, that tells us the solution to a Var, that is, --     a collection of cubes that we'll want to disjunct -sol1 :: F.Symbol -> Cstr a -> [([Bind], [F.Expr])]+sol1 :: F.Symbol -> Cstr a -> [([Bind a], [F.Expr])] sol1 k (CAnd cs) = sol1 k =<< cs-sol1 k (All b c) = (\(bs, eqs) -> (b:bs, eqs)) <$> sol1 k c+sol1 k (All b c) = first (b :) <$> sol1 k c sol1 k (Head (Var k' ys) _) | k == k'   = [([], zipWith (F.PAtom F.Eq) (F.EVar <$> xs) (F.EVar <$> ys))]   where xs = zipWith const (kargs k) ys@@ -839,37 +849,37 @@ sol1 _ (Any _ _) =  error "ebinds don't work with old elim"  kargs :: F.Symbol -> [F.Symbol]-kargs k = fromString . (("κarg$" ++ F.symbolString k ++ "#") ++) . show <$> [1..]+kargs k = fromString . (("κarg$" ++ F.symbolString k ++ "#") ++) . show <$> [1 :: Integer ..]  -- | -- >>> LET c = doParse' hCstrP "" "(forall ((z Int) ($k0 z)) ((z = x)))" -- >>> doelim "k0" [[Bind "v" F.boolSort (Reft $ F.EVar "v"), Bind "_" F.boolSort (Reft $ F.EVar "donkey")]]  c -- (forall ((v bool) (v)) (forall ((z int) (donkey)) ((z == x)))) -doelim :: F.Symbol -> [([Bind], [F.Expr])] -> Cstr a -> Cstr a+doelim :: F.Symbol -> [([Bind a], [F.Expr])] -> Cstr a -> Cstr a doelim k bss (CAnd cs)   = CAnd $ doelim k bss <$> cs-doelim k bss (All (Bind x t p) c) =+doelim k bss (All (Bind x t p l) c) =   case findKVarInGuard k p of-    Right _ -> All (Bind x t p) (doelim k bss c)-    Left (kvars, preds) -> demorgan x t kvars preds (doelim k bss c) bss+    Right _ -> All (Bind x t p l) (doelim k bss c)+    Left (kvars, preds) -> demorgan x t l kvars preds (doelim k bss c) bss   where-    demorgan :: F.Symbol -> F.Sort -> [(F.Symbol, [F.Symbol])] -> [Pred] -> Cstr a -> [([Bind], [F.Expr])] -> Cstr a-    demorgan x t kvars preds c bss = mkAnd $ cubeSol <$> bss-      where su = F.Su $ M.fromList $ concat $ map (\(k, xs) -> zip (kargs k) (F.EVar <$> xs)) kvars+    demorgan :: F.Symbol -> F.Sort -> a -> [(F.Symbol, [F.Symbol])] -> [Pred] -> Cstr a -> [([Bind a], [F.Expr])] -> Cstr a+    demorgan x t ann kvars preds c bss = mkAnd $ cubeSol <$> bss+      where su = F.Su $ M.fromList $ concatMap (\(k, xs) -> zip (kargs k) (F.EVar <$> xs)) kvars             mkAnd [c] = c             mkAnd cs = CAnd cs-            cubeSol ((b:bs), eqs) = All b $ cubeSol (bs, eqs)-            cubeSol ([], eqs) = All (Bind x t (PAnd $ (Reft <$> F.subst su eqs) ++ (F.subst su <$> preds))) c+            cubeSol (b:bs, eqs) = All b $ cubeSol (bs, eqs)+            cubeSol ([], eqs) = All (Bind x t (PAnd $ (Reft <$> F.subst su eqs) ++ (F.subst su <$> preds)) ann) c doelim k _ (Head (Var k' _) a)   | k == k'   = Head (Reft F.PTrue) a doelim _ _ (Head p a) = Head p a -doelim k bss (Any (Bind x t p) c) =+doelim k bss (Any (Bind x t p l) c) =   case findKVarInGuard k p of-    Right _ -> Any (Bind x t p) (doelim k bss c)-    Left (_, rights) -> Any (Bind x t (PAnd rights)) (doelim k bss c) -- TODO: for now we set the kvar to true. not sure if this is correct+    Right _ -> Any (Bind x t p l) (doelim k bss c)+    Left (_, rights) -> Any (Bind x t (PAnd rights) l) (doelim k bss c) -- TODO: for now we set the kvar to true. not sure if this is correct  -- If k is in the guard then returns a Left list of that k and the remaining preds in the guard -- If k is not in the guard returns a Right of the pred@@ -877,11 +887,11 @@ findKVarInGuard k (PAnd ps) =   if null lefts     then Right (PAnd ps) -- kvar not found-    else Left $ (newLefts, newRights)+    else Left (newLefts, newRights)   where findResults = findKVarInGuard k <$> ps         (lefts, rights) = partitionEithers findResults-        newLefts = concat $ map fst lefts-        newRights = concat (snd <$> lefts) ++ rights+        newLefts = concatMap fst lefts+        newRights = concatMap snd lefts ++ rights findKVarInGuard k p@(Var k' xs)   | k == k' = Left ([(k', xs)], [])   | otherwise = Right p@@ -905,8 +915,8 @@ boundKvars :: Cstr a -> S.Set F.Symbol boundKvars (Head p _)           = pKVars p boundKvars (CAnd c)             = mconcat $ boundKvars <$> c-boundKvars (All (Bind _ _ p) c) = pKVars p <> boundKvars c-boundKvars (Any (Bind _ _ p) c) = pKVars p <> boundKvars c+boundKvars (All (Bind _ _ p _) c) = pKVars p <> boundKvars c+boundKvars (Any (Bind _ _ p _) c) = pKVars p <> boundKvars c  pKVars :: Pred -> S.Set F.Symbol pKVars (Var k _) = S.singleton k@@ -924,14 +934,14 @@ calculateCuts cfg (Query qs vs _ cons dist eqns mats dds) nnf = convert $ FG.depCuts deps   where     (_, deps) = elimVars cfg (hornFInfo cfg $ Query qs vs nnf cons dist eqns mats dds)-    convert hashset = S.fromList $ F.kv <$> (HS.toList hashset)+    convert hashset = S.fromList $ F.kv <$> HS.toList hashset  forgetPiVars :: S.Set F.Symbol -> Cstr a -> Cstr a forgetPiVars _ c@Head{} = c forgetPiVars pis (CAnd cs) = CAnd $ forgetPiVars pis <$> cs-forgetPiVars pis (All (Bind x t p) c)-  | Var k _ <- p, k `S.member` pis = All (Bind x t (PAnd [])) $ forgetPiVars pis c-  | otherwise = All (Bind x t p) $ forgetPiVars pis c+forgetPiVars pis (All (Bind x t p l) c)+  | Var k _ <- p, k `S.member` pis = All (Bind x t (PAnd []) l) $ forgetPiVars pis c+  | otherwise = All (Bind x t p l) $ forgetPiVars pis c forgetPiVars _ Any{} = error "shouldn't be present"  -----------------------------------------------------------------------------------@@ -964,8 +974,8 @@                         [c] -> c                         cs -> CAnd cs   flatten (Head p a) = Head (flatten p) a-  flatten (All (Bind x t p) c) = All (Bind x t (flatten p)) (flatten c)-  flatten (Any (Bind x t p) c) = Any (Bind x t (flatten p)) (flatten c)+  flatten (All (Bind x t p l) c) = All (Bind x t (flatten p) l) (flatten c)+  flatten (Any (Bind x t p l) c) = Any (Bind x t (flatten p) l) (flatten c)  instance Flatten [Cstr a] where   flatten (CAnd cs : xs) = flatten cs ++ flatten xs@@ -1010,10 +1020,10 @@ hornify (Head (PAnd ps) a) = CAnd (flip Head a <$> ps')   where ps' = let (ks, qs) = split [] [] (flatten ps) in PAnd qs : ks -        split kacc pacc ((Var x xs):qs) = split ((Var x xs):kacc) pacc qs+        split kacc pacc ((Var x xs):qs) = split (Var x xs : kacc) pacc qs         split kacc pacc (q:qs) = split kacc (q:pacc) qs         split kacc pacc [] = (kacc, pacc)-hornify (Head (Reft r) a) = CAnd (flip Head a <$> ((Reft $ F.PAnd ps):(Reft <$> ks)))+hornify (Head (Reft r) a) = CAnd (flip Head a <$> (Reft (F.PAnd ps):(Reft <$> ks)))   where (ks, ps) = split [] [] $ F.splitPAnd r         split kacc pacc (r@F.PKVar{}:rs) = split (r:kacc) pacc rs         split kacc pacc (r:rs) = split kacc (r:pacc) rs@@ -1028,7 +1038,7 @@   where     go _ c@Head{} = c     go xs (CAnd cs) = CAnd $ go xs <$> cs-    go xs (All b@(Bind x _ _) c) = if x `S.member` xs then go xs c else All b $ go (S.insert x xs) c+    go xs (All b@(Bind x _ _ _) c) = if x `S.member` xs then go xs c else All b $ go (S.insert x xs) c     go xs (Any b c) = Any b $ go xs c  pruneTauts :: Cstr a -> Cstr a

src/Language/Fixpoint/Horn/Types.hs view

@@ -1,40 +1,39 @@  ---------------------------------------------------------------------------------- | This module formalizes the key datatypes needed to represent Horn NNF +-- | This module formalizes the key datatypes needed to represent Horn NNF --   constraints as described in "Local Refinement Typing", ICFP 2017 -------------------------------------------------------------------------------  {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-} -module Language.Fixpoint.Horn.Types +{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Language.Fixpoint.Horn.Types   ( -- * Horn Constraints and their components     Query (..)   , Cstr  (..)   , Pred  (..)   , Bind  (..)-  , Var   (..) +  , Var   (..)      -- * Raw Query   , Tag (..)   , TagVar-  , TagQuery +  , TagQuery      -- * accessing constraint labels   , cLabel -    -- * invariants (refinements) on constraints -  , okCstr -  , dummyBind+    -- * invariants (refinements) on constraints+  , okCstr -    -- * extract qualifiers +    -- * extract qualifiers   , quals-  ) -  where +  )+  where  import           Data.Generics             (Data) import           Data.Typeable             (Typeable)@@ -50,7 +49,7 @@ import           Data.Aeson  ---------------------------------------------------------------------------------- | @HVar@ is a Horn variable +-- | @HVar@ is a Horn variable ------------------------------------------------------------------------------- data Var a = HVar   { hvName :: !F.Symbol                         -- ^ name of the variable $k1, $k2 etc.@@ -60,19 +59,19 @@   deriving (Eq, Ord, Data, Typeable, Generic, Functor)  ---------------------------------------------------------------------------------- | @HPred@ is a Horn predicate that appears as LHS (body) or RHS (head) of constraints +-- | @HPred@ is a Horn predicate that appears as LHS (body) or RHS (head) of constraints --------------------------------------------------------------------------------data Pred -  = Reft  !F.Expr                               -- ^ r -  | Var   !F.Symbol ![F.Symbol]                 -- ^ $k(y1..yn) -  | PAnd  ![Pred]                               -- ^ p1 /\ .../\ pn +data Pred+  = Reft  !F.Expr                               -- ^ r+  | Var   !F.Symbol ![F.Symbol]                 -- ^ $k(y1..yn)+  | PAnd  ![Pred]                               -- ^ p1 /\ .../\ pn   deriving (Data, Typeable, Generic, Eq)   instance Semigroup Pred where   p1 <> p2 = PAnd [p1, p2] -instance Monoid Pred where +instance Monoid Pred where   mempty = Reft mempty  instance F.Subable Pred where@@ -97,21 +96,21 @@   subst1 (Var k xs) su = Var k [F.subst1 x su | x <- xs]  --------------------------------------------------------------------------------quals :: Cstr a -> [F.Qualifier] +quals :: Cstr a -> [F.Qualifier] --------------------------------------------------------------------------------quals = F.tracepp "horn.quals" . cstrQuals F.emptySEnv F.vv_  +quals = F.tracepp "horn.quals" . cstrQuals F.emptySEnv F.vv_ -cstrQuals :: F.SEnv F.Sort -> F.Symbol -> Cstr a -> [F.Qualifier] -cstrQuals = go +cstrQuals :: F.SEnv F.Sort -> F.Symbol -> Cstr a -> [F.Qualifier]+cstrQuals = go   where     go env v (Head p _)  = predQuals env v p     go env v (CAnd   cs) = concatMap (go env v) cs-    go env _ (All  b c)  = bindQuals env b c +    go env _ (All  b c)  = bindQuals env b c     go env _ (Any  b c)  = bindQuals env b c -bindQuals  :: F.SEnv F.Sort -> Bind -> Cstr a -> [F.Qualifier] -bindQuals env b c = predQuals env' bx (bPred b) ++ cstrQuals env' bx c -  where +bindQuals  :: F.SEnv F.Sort -> Bind a -> Cstr a -> [F.Qualifier]+bindQuals env b c = predQuals env' bx (bPred b) ++ cstrQuals env' bx c+  where     env'          = F.insertSEnv bx bt env     bx            = bSym b     bt            = bSort b@@ -119,24 +118,24 @@ predQuals :: F.SEnv F.Sort -> F.Symbol -> Pred -> [F.Qualifier] predQuals env v (Reft p)  = exprQuals env v p predQuals env v (PAnd ps) = concatMap (predQuals env v) ps-predQuals _   _ _         = [] +predQuals _   _ _         = []  exprQuals :: F.SEnv F.Sort -> F.Symbol -> F.Expr -> [F.Qualifier] exprQuals env v e = mkQual env v <$> F.conjuncts e  mkQual :: F.SEnv F.Sort -> F.Symbol -> F.Expr -> F.Qualifier mkQual env v p = case envSort env <$> (v:xs) of-                   (_,so):xts -> F.mkQ "Auto" ((v, so) : xts) p junk +                   (_,so):xts -> F.mkQ "Auto" ((v, so) : xts) p junk                    _          -> F.panic "impossible"   where     xs         = L.delete v $ Misc.hashNub (F.syms p)-    junk       = F.dummyPos "mkQual" +    junk       = F.dummyPos "mkQual"  envSort :: F.SEnv F.Sort -> F.Symbol -> (F.Symbol, F.Sort) envSort env x = case F.lookupSEnv x env of-                   Just t -> (x, t) +                   Just t -> (x, t)                    _      -> F.panic $ "unbound symbol in scrape: " ++ F.showpp x-{- +{-   | Just _ <- lookupSEnv x lEnv = Nothing   | otherwise                   = Just (x, ai)   where@@ -146,31 +145,31 @@   ----------------------------------------------------------------------------------- | @Cst@ is an NNF Horn Constraint. +-- | @Cst@ is an NNF Horn Constraint. ------------------------------------------------------------------------------- -- Note that a @Bind@ is a simplified @F.SortedReft@ ...-data Bind = Bind -  { bSym  :: !F.Symbol -  , bSort :: !F.Sort -  , bPred :: !Pred +data Bind a = Bind+  { bSym  :: !F.Symbol+  , bSort :: !F.Sort+  , bPred :: !Pred+  , bMeta :: !a   }-  deriving (Data, Typeable, Generic, Eq)--instance F.Subable Bind where-    syms = undefined-    substa = undefined-    substf = undefined-    subst su (Bind x t p) = (Bind x t (F.subst su p))+  deriving (Data, Typeable, Generic, Functor, Eq) -dummyBind :: Bind -dummyBind = Bind F.dummySymbol F.intSort (PAnd []) +instance F.Subable (Bind a) where+    syms     (Bind x _ p _) = x : F.syms p+    substa f (Bind v t p a) = Bind (f v) t (F.substa f p) a+    substf f (Bind v t p a) = Bind v t (F.substf (F.substfExcept f [v]) p) a+    -- subst su (Bind x t p) = (Bind x t (F.subst su p))+    subst su (Bind v t p a)  = Bind v t (F.subst (F.substExcept su [v]) p) a+    subst1 (Bind v t p a) su = Bind v t (F.subst1Except [v] p su) a  -- Can we enforce the invariant that CAnd has len > 1? data Cstr a-  = Head  !Pred a               -- ^ p-  | CAnd  ![(Cstr a)]           -- ^ c1 /\ ... /\ cn-  | All   !Bind  !(Cstr a)      -- ^ \all x:t. p => c-  | Any   !Bind  !(Cstr a)      -- ^ \exi x:t. p /\ c or is it \exi x:t. p => c?+  = Head  !Pred !a                  -- ^ p+  | CAnd  ![Cstr a]                 -- ^ c1 /\ ... /\ cn+  | All   !(Bind a)  !(Cstr a)      -- ^ \all x:t. p => c+  | Any   !(Bind a)  !(Cstr a)      -- ^ \exi x:t. p /\ c or is it \exi x:t. p => c?   deriving (Data, Typeable, Generic, Functor, Eq)  cLabel :: Cstr a -> a@@ -184,24 +183,26 @@     go (Any _ c)    = go c  -- We want all valid constraints to start with a binding at the top-okCstr :: Cstr a -> Bool -okCstr (All {}) = True -okCstr (Any {}) = True -okCstr _        = False  +okCstr :: Cstr a -> Bool+okCstr All {} = True+okCstr Any {} = True+okCstr _      = False++ ---------------------------------------------------------------------------------- | @Query@ is an NNF Horn Constraint. +-- | @Query@ is an NNF Horn Constraint. ------------------------------------------------------------------------------- -data Query a = Query -  { qQuals :: ![F.Qualifier]                    -- ^ qualifiers over which to solve cstrs-  , qVars  :: ![Var a]                          -- ^ kvars, with parameter-sorts-  , qCstr  :: !(Cstr a)                         -- ^ list of constraints-  , qCon   :: M.HashMap (F.Symbol) (F.Sort)     -- ^ list of constants (uninterpreted functions-  , qDis   :: M.HashMap (F.Symbol) (F.Sort)     -- ^ list of constants (uninterpreted functions-  , qEqns  :: ![F.Equation]                     -- ^ list of equations-  , qMats  :: ![F.Rewrite]                      -- ^ list of match-es-  , qData  :: ![F.DataDecl]                     -- ^ list of data-declarations+data Query a = Query+  { qQuals :: ![F.Qualifier]             -- ^ qualifiers over which to solve cstrs+  , qVars  :: ![Var a]                   -- ^ kvars, with parameter-sorts+  , qCstr  :: !(Cstr a)                  -- ^ list of constraints+  , qCon   :: M.HashMap F.Symbol F.Sort  -- ^ list of constants (uninterpreted functions+  , qDis   :: M.HashMap F.Symbol F.Sort  -- ^ list of constants (uninterpreted functions+  , qEqns  :: ![F.Equation]              -- ^ list of equations+  , qMats  :: ![F.Rewrite]               -- ^ list of match-es+  , qData  :: ![F.DataDecl]            -- ^ list of data-declarations   }   deriving (Data, Typeable, Generic, Functor) @@ -210,7 +211,7 @@ type TagVar   = Var Tag type TagQuery = Query Tag data Tag      = NoTag | Tag String-  deriving (Data, Typeable, Generic, Show) +  deriving (Data, Typeable, Generic, Show)  instance NFData Tag @@ -218,19 +219,19 @@   srcSpan _ = F.dummySpan  instance F.Fixpoint Tag where-  toFix NoTag   = "\"\"" +  toFix NoTag   = "\"\""   toFix (Tag s) = "\"" <> P.text s <> "\""-  + instance F.PPrint Tag where   pprintPrec _ _ NoTag   = mempty-  pprintPrec _ _ (Tag s) = P.ptext s +  pprintPrec _ _ (Tag s) = P.ptext s  instance ToJSON Tag where   toJSON NoTag   = Null-  toJSON (Tag s) = String (T.pack s) +  toJSON (Tag s) = String (T.pack s) -instance F.PPrint (Query a) where -  pprintPrec k t q = P.vcat $ L.intersperse " " +instance F.PPrint (Query a) where+  pprintPrec k t q = P.vcat $ L.intersperse " "     [ P.vcat   (ppQual <$> qQuals q)     , P.vcat   [ppVar k   | k <- qVars q]     , P.vcat   [ppCon x t | (x, t) <- M.toList (qCon q)]@@ -241,22 +242,24 @@  ppThings :: F.PPrint a => Maybe P.Doc -> [a] -> P.Doc ppThings pfx qs = P.vcat [ P.parens $ prefix P.<-> F.pprint q | q <- qs]-  where -    prefix      = fromMaybe "" pfx +  where+    prefix      = fromMaybe "" pfx  ppCon :: F.Symbol -> F.Sort -> P.Doc ppCon x t = P.parens ("constant" P.<+> F.pprint x P.<+> P.parens (F.pprint t))  ppQual :: F.Qualifier -> P.Doc ppQual (F.Q n xts p _) =  P.parens ("qualif" P.<+> F.pprint n P.<+> ppBlanks (ppArg <$> xts) P.<+> P.parens (F.pprint p))-  where -    ppArg qp    = F.pprint (F.qpSym qp) P.<+> P.parens (F.pprint (F.qpSort qp))+  where+    ppArg qp    = P.parens $ F.pprint (F.qpSym qp) P.<+> P.parens (F.pprint (F.qpSort qp))  ppVar :: Var a -> P.Doc-ppVar (HVar k ts _)  = P.parens ("var" P.<+> "$" P.<-> F.pprint k P.<+> ppBlanks ((P.parens . F.pprint) <$> ts)) +ppVar (HVar k ts _)  = P.parens ("var" P.<+> "$" P.<-> F.pprint k P.<+> ppBlanks (P.parens . F.pprint <$> ts)) + ppBlanks :: [P.Doc] -> P.Doc ppBlanks ds = P.parens (P.hcat (L.intersperse " " ds))+ ------------------------------------------------------------------------------- -- Pretty Printing -------------------------------------------------------------------------------@@ -268,7 +271,7 @@  instance Show Pred where   show (Reft p)   = parens $ F.showpp p-  show (Var x xs) = parens $ unwords (F.symbolString <$> x:xs)+  show (Var x xs) = parens $ "$" ++ unwords (F.symbolString <$> x:xs)   show (PAnd ps)  = parens $ unwords $ "and": map show ps  instance Show (Cstr a) where@@ -277,15 +280,15 @@   show (Any b c)  = parens $ unwords ["exists" , show b , show c]   show (CAnd cs)  = parens $ unwords $ "and" : map show cs -instance Show Bind where-  show (Bind x t p) = parens $ unwords [parens $ unwords [F.symbolString x, F.showpp t], show p]+instance Show (Bind a) where+  show (Bind x t p _) = parens $ unwords [parens $ unwords [F.symbolString x, F.showpp t], show p]  instance F.PPrint (Var a) where   pprintPrec _ _ v = P.ptext $ show v  instance F.PPrint Pred where   pprintPrec k t (Reft p)   = P.parens $ F.pprintPrec k t p-  pprintPrec _ _ (Var x xs) = P.parens $ P.hsep (P.ptext . F.symbolString <$> x:xs)+  pprintPrec _ _ (Var x xs) = P.parens $ P.ptext "$" <> P.hsep (P.ptext . F.symbolString <$> x:xs)   pprintPrec k t (PAnd ps)  = P.parens $ P.vcat $ P.ptext "and" : map (F.pprintPrec (k+2) t) ps  instance F.PPrint (Cstr a) where@@ -298,5 +301,5 @@                                                 ]   pprintPrec k t (CAnd cs) = P.parens $ P.vcat  $ P.ptext "and" : map (F.pprintPrec (k+2) t) cs -instance F.PPrint Bind where+instance F.PPrint (Bind a) where   pprintPrec _ _ b = P.ptext $ show b

src/Language/Fixpoint/Minimize.hs view

@@ -7,8 +7,11 @@  {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Minimize ( minQuery, minQuals, minKvars ) where +import Prelude hiding (min, init) import qualified Data.HashMap.Strict                as M import           Control.Monad                      (filterM) import           Language.Fixpoint.Types.Visitor    (mapKVars)@@ -16,7 +19,7 @@ import           Language.Fixpoint.Misc             (safeHead) import           Language.Fixpoint.Utils.Files      hiding (Result) import           Language.Fixpoint.Graph-import           Language.Fixpoint.Types+import           Language.Fixpoint.Types            hiding (fi) import           Control.DeepSeq  ---------------------------------------------------------------------------@@ -79,7 +82,7 @@   failFis  <- filterM (fmap (not . isSafe) . solve cfg') fis   let failFi = safeHead "--minimize can only be called on UNSAT fq" failFis   let format _ cs = "Minimized Constraints: " ++ show (fst <$> cs)-  let update fi cs = fi { cm = M.fromList cs }+  let update fi' cs = fi' { cm = M.fromList cs }   commonDebug (M.toList . cm) update (not . isSafe) True cfg' solve failFi Min format  ---------------------------------------------------------------------------@@ -88,9 +91,9 @@ --------------------------------------------------------------------------- minQuals cfg solve fi = do   let cfg'  = cfg { minimizeQs = False }-  let format fi qs = "Required Qualifiers: " ++ show (length qs)-                  ++ "; Total Qualifiers: "  ++ show (length $ quals fi)-  let update fi qs = fi { quals = qs }+  let format fi' qs = "Required Qualifiers: " ++ show (length qs)+                  ++ "; Total Qualifiers: "  ++ show (length $ quals fi')+  let update fi' qs = fi' { quals = qs }   commonDebug quals update isSafe False cfg' solve fi MinQuals format  ---------------------------------------------------------------------------@@ -99,8 +102,8 @@ --------------------------------------------------------------------------- minKvars cfg solve fi = do   let cfg'  = cfg { minimizeKs = False }-  let format fi ks = "Required KVars: " ++ show (length ks)-                  ++ "; Total KVars: "  ++ show (length $ ws fi)+  let format fi' ks = "Required KVars: " ++ show (length ks)+                  ++ "; Total KVars: "  ++ show (length $ ws fi')   commonDebug (M.keys . ws) removeOtherKs isSafe False cfg' solve fi MinKVars format  removeOtherKs :: FInfo a -> [KVar] -> FInfo a

src/Language/Fixpoint/Misc.hs view

@@ -5,9 +5,9 @@ {-# LANGUAGE TupleSections             #-} {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE TypeOperators             #-}-{-# LANGUAGE BangPatterns              #-} {-# LANGUAGE ImplicitParams            #-} -- ignore hlint + module Language.Fixpoint.Misc where  -- import           System.IO.Unsafe            (unsafePerformIO)@@ -56,14 +56,14 @@ hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)] hashMapToAscList = L.sortBy (compare `on` fst) . M.toList -findNearest :: (Ord i, Num i) => i -> [(i, a)] -> Maybe a +findNearest :: (Ord i, Num i) => i -> [(i, a)] -> Maybe a findNearest key kvs = argMin [ (abs (key - k), v) | (k, v) <- kvs ] -argMin :: (Ord k) => [(k, v)] -> Maybe v +argMin :: (Ord k) => [(k, v)] -> Maybe v argMin = fmap snd . headMb . L.sortBy (compare `on` fst) -headMb :: [a] -> Maybe a -headMb []    = Nothing +headMb :: [a] -> Maybe a+headMb []    = Nothing headMb (x:_) = Just x --------------------------------------------------------------- -- | Unique Int -----------------------------------------------@@ -150,7 +150,7 @@   errorP :: String -> String -> a-errorP p s = error (p ++ s)   +errorP p s = error (p ++ s)  errorstar :: (?callStack :: CallStack) => String -> a errorstar  = error . wrap (stars ++ "\n") (stars ++ "\n")@@ -224,7 +224,7 @@ hashNubWith f xs = M.elems $ M.fromList [ (f x, x) | x <- xs ]  mFromList :: (Eq k, Hashable k) => [(k, v)] -> M.HashMap k v-mFromList = M.fromList +mFromList = M.fromList  duplicates :: (Eq k, Hashable k) => [k] -> [k] duplicates xs = [ x | (x, n) <- count xs, 1 < n ]@@ -264,8 +264,8 @@   where     -- dups             = duplicates . fmap fst     dups             = [ x | (x, n) <- count (fst <$> kvs), 1 < n ]-    err              = errorstar . wrap "safeFromList with duplicates" msg . show-    wrap m1 m2 s     = m1 ++ " " ++ s ++ " " ++ m2 +    err              = errorstar . wrapMsg "safeFromList with duplicates" msg . show+    wrapMsg m1 m2 s     = m1 ++ " " ++ s ++ " " ++ m2  safeHead _   (x:_) = x safeHead msg _     = errorstar $ "safeHead with empty list " ++ msg@@ -307,16 +307,6 @@ ensurePath :: FilePath -> IO () ensurePath = createDirectoryIfMissing True . takeDirectory -singleton :: a -> [a]-singleton x = [x]--pair :: a -> a -> [a]-pair x1 x2 = [x1, x2]--triple :: a -> a -> a -> [a]-triple x1 x2 x3 = [x1, x2, x3]-- fM :: (Monad m) => (a -> b) -> a -> m b fM f = return . f @@ -325,10 +315,10 @@   b <- cond   when b act -ifM :: (Monad m) => m Bool -> m a -> m a -> m a -ifM c t e = do -  b <- c -  if b then t else e +ifM :: (Monad m) => m Bool -> m a -> m a -> m a+ifM c t e = do+  b <- c+  if b then t else e  mapEither :: (a -> Either b c) -> [a] -> ([b], [c]) mapEither _ []     = ([], [])@@ -338,8 +328,8 @@                      where                        (ys, zs) = mapEither f xs -isRight :: Either a b -> Bool -isRight (Right _) = True +isRight :: Either a b -> Bool+isRight (Right _) = True isRight _         = False  componentsWith :: (Ord c) => (a -> [(b, c, [c])]) -> a -> [[b]]@@ -357,8 +347,8 @@ -- | -- >>> let em = M.fromList [ (1, [2, 3]), (2, [1, 3]), (3, []   ) ] -- >>> let ef = \v -> (v, M.lookupDefault [] v em)--- >>> sccsWith ef [1,2,3]  --- [[3],[1,2]] +-- >>> sccsWith ef [1,2,3]+-- [[3],[1,2]]  sccsWith :: (Ord v) => (a -> (v, [v])) -> [a] -> [[a]] sccsWith vF xs     = map (fst3 . f) <$> (T.flatten <$> G.scc g)@@ -412,49 +402,36 @@  {-@ allCombinations :: xss:[[a]] -> [{v:[a]| len v == len xss}] @-} allCombinations :: [[a]] -> [[a]]-allCombinations xs = assert (and . map (((length xs) == ) . length)) $ go xs+allCombinations xs = assert (all ((length xs == ) . length)) $ go xs   where-   go []          = [[]]-   go [[]]        = []-   go ([]:_)      = []-   go ((x:xs):ys) = ((x:) <$> go ys) ++ go (xs:ys)+   go []           = [[]]+   go [[]]         = []+   go ([]:_)       = []+   go ((x:xs'):ys) = ((x:) <$> go ys) ++ go (xs':ys)     assert b x = if b x then x else errorstar "allCombinations: assertion violation"  powerset :: [a] -> [[a]] powerset xs = filterM (const [False, True]) xs +infixl 9 =>> (=>>) :: Monad m => m b -> (b -> m a) -> m b (=>>) m f = m >>= (\x -> f x >> return x) +infixl 9 <<= (<<=) :: Monad m => (b -> m a) -> m b -> m b (<<=) = flip (=>>) -(<$$>) ::  (Monad m) => (a -> m b) -> [a] -> m [b]-_ <$$> []           = return []-f <$$> [x1]         = singleton <$> f x1-f <$$> [x1, x2]     = pair      <$> f x1 <*> f x2-f <$$> [x1, x2, x3] = triple    <$> f x1 <*> f x2 <*> f x3-f <$$> xs           = revMapM f ({- trace msg -} xs)-  where-    _msg            = "<$$> on " ++ show (length xs)--revMapM  :: (Monad m) => (a -> m b) -> [a] -> m [b]-revMapM f          = go []-  where-    go !acc []     = return (reverse acc)-    go !acc (x:xs) = do {!y <- f x; go (y:acc) xs}- -- Null if first is a subset of second-nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a +nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a nubDiff a b = a' `S.difference` b'   where     a' = S.fromList a     b' = S.fromList b  -fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a -fold1M _ []         = errorstar $ "fold1M with empty list"-fold1M _ [x]        = return x -fold1M f (x1:x2:xs) = do { x <- f x1 x2; fold1M f (x:xs) }  +fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a+fold1M _ []         = errorstar "fold1M with empty list"+fold1M _ [x]        = return x+fold1M f (x1:x2:xs) = do { x <- f x1 x2; fold1M f (x:xs) }

src/Language/Fixpoint/Parse.hs view

@@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE DeriveGeneric             #-} {-# LANGUAGE OverloadedStrings         #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Parse (    -- * Top Level Class for Parseable Values@@ -124,7 +124,8 @@ import           Language.Fixpoint.Types.Errors import qualified Language.Fixpoint.Misc      as Misc import           Language.Fixpoint.Smt.Types-import           Language.Fixpoint.Types hiding    (mapSort)+import           Language.Fixpoint.Types hiding    (mapSort, fi, params, GInfo(..))+import qualified Language.Fixpoint.Types     as Types (GInfo(FI)) import           Text.PrettyPrint.HughesPJ         (text, vcat, (<+>), Doc)  import Control.Monad.State@@ -764,14 +765,14 @@  emptyListP :: Parser Expr emptyListP = do-  e <- empList <$> get+  e <- gets empList   case e of     Nothing -> fail "No parsing support for empty lists"     Just s  -> return s  singletonListP :: Expr -> Parser Expr singletonListP e = do-  f <- singList <$> get+  f <- gets singList   case f of     Nothing -> fail "No parsing support for singleton lists"     Just s  -> return $ s e@@ -780,9 +781,8 @@ exprCastP :: Parser Expr exprCastP   = do e  <- exprP-       try dcolon <|> colon -- allow : or :: *and* allow following symbols-       so <- sortP-       return $ ECst e so+       _ <- try dcolon <|> colon -- allow : or :: *and* allow following symbols+       ECst e <$> sortP  fastIfP :: (Expr -> a -> a -> a) -> Parser a -> Parser a fastIfP f bodyP@@ -791,15 +791,13 @@        reserved "then"        b1 <- bodyP        reserved "else"-       b2 <- bodyP-       return $ f p b1 b2+       f p b1 <$> bodyP  coerceP :: Parser Expr -> Parser Expr coerceP p = do   reserved "coerce"   (s, t) <- parens (pairP sortP (reservedOp "~") sortP)-  e      <- p-  return $ ECoerc s t e+  ECoerc s t <$> p   @@ -860,7 +858,7 @@ -- | Parses any of the known infix operators. infixSymbolP :: Parser Symbol infixSymbolP = do-  ops <- infixOps <$> get+  ops <- gets infixOps   choice (reserved' <$> ops)   where     infixOps st = [s | FInfix _ s _ _ <- fixityOps st]@@ -869,7 +867,7 @@ -- | Located version of 'infixSymbolP'. locInfixSymbolP :: Parser (Located Symbol) locInfixSymbolP = do-  ops <- infixOps <$> get+  ops <- gets infixOps   choice (reserved' <$> ops)   where     infixOps st = [s | FInfix _ s _ _ <- fixityOps st]@@ -926,7 +924,7 @@                  , FInfix  (Just 9) "."   applyCompose        AssocRight                  ]     applyCompose :: Maybe (Expr -> Expr -> Expr)-    applyCompose = (\f x y -> (f `eApps` [x,y])) <$> cmpFun+    applyCompose = (\f x y -> f `eApps` [x,y]) <$> cmpFun  -- | Parser for function applications. --@@ -952,24 +950,21 @@   return $ mkEApp (Loc l1 l2 cons) (first : rest)  --- TODO:AZ: The comment says BitVector literal, but it accepts any @Sort@--- | BitVector literal: lit "#x00000001" (BitVec (Size32 obj))+-- | Parser for literals of all sorts. litP :: Parser Expr litP = do reserved "lit"           l <- stringLiteral-          t <- sortP-          return $ ECon $ L (T.pack l) t+          ECon . L (T.pack l) <$> sortP  -- | Parser for lambda abstractions. lamP :: Parser Expr lamP   = do reservedOp "\\"        x <- symbolP-       colon -- TODO: this should probably be reservedOp instead+       _ <- colon -- TODO: this should probably be reservedOp instead        t <- sortP        reservedOp "->"-       e  <- exprP-       return $ ELam (x, t) e+       ELam (x, t) <$> exprP  varSortP :: Parser Sort varSortP  = FVar  <$> parens intP@@ -979,8 +974,8 @@ funcSortP = parens $ mkFFunc <$> intP <* comma <*> sortsP  sortsP :: Parser [Sort]-sortsP = try (brackets (sepBy sortP semi)) -      <|> (brackets (sepBy sortP comma)) +sortsP = try (brackets (sepBy sortP semi))+      <|> brackets (sepBy sortP comma)  -- | Parser for sorts (types). sortP    :: Parser Sort@@ -1051,7 +1046,7 @@       <|> kvarPredP       <|> fastIfP pIte predP -- "if-then-else", starts with "if"       <|> try predrP -- binary relation, starts with anything that an expr can start with-      <|> (parens predP) -- parenthesised predicate, starts with "("+      <|> parens predP -- parenthesised predicate, starts with "("       <|> (reservedOp "?" *> exprP)       <|> try funAppP       <|> EVar <$> symbolP -- identifier, starts with any letter or underscore@@ -1203,8 +1198,7 @@   x     <- symbolP   pat   <- qualPatP   _     <- colon-  t     <- tP-  return $ QP x pat t+  QP x pat <$> tP  qualPatP :: Parser QualPattern qualPatP@@ -1256,7 +1250,7 @@ matchP = SMeasure <$> symbolP <*> symbolP <*> many symbolP <*> (reserved "=" >> exprP)  pairsP :: Parser a -> Parser b -> Parser [(a, b)]-pairsP aP bP = brackets $ sepBy1 (pairP aP (reserved ":") bP) semi+pairsP aP bP = brackets $ sepBy (pairP aP (reserved ":") bP) semi --------------------------------------------------------------------- -- | Parsing Constraints (.fq files) -------------------------------- ---------------------------------------------------------------------@@ -1271,8 +1265,8 @@   | Qul !Qualifier   | Kut !KVar   | Pack !KVar !Int-  | IBind !Int !Symbol !SortedReft-  | EBind !Int !Symbol !Sort+  | IBind !Int !Symbol !SortedReft !a+  | EBind !Int !Symbol !Sort !a   | Opt !String   | Def !Equation   | Mat !Rewrite@@ -1289,19 +1283,19 @@                return $ FIO (defsFInfo ps) [s | Opt s <- ps]  fInfoP :: Parser (FInfo ())-fInfoP = defsFInfo <$> {- SCC "many-defP" #-} many defP+fInfoP = defsFInfo <$> {- SCC "many-defP" -} many defP  defP :: Parser (Def ()) defP =  Srt   <$> (reserved "sort"         >> colon >> sortP)-    <|> Cst   <$> (reserved "constraint"   >> colon >> {- SCC "subCP" #-} subCP)-    <|> Wfc   <$> (reserved "wf"           >> colon >> {- SCC "wfCP"  #-} wfCP)+    <|> Cst   <$> (reserved "constraint"   >> colon >> {- SCC "subCP" -} subCP)+    <|> Wfc   <$> (reserved "wf"           >> colon >> {- SCC "wfCP"  -} wfCP)     <|> Con   <$> (reserved "constant"     >> symbolP) <*> (colon >> sortP)     <|> Dis   <$> (reserved "distinct"     >> symbolP) <*> (colon >> sortP)     <|> Pack  <$> (reserved "pack"         >> kvarP)   <*> (colon >> intP)     <|> Qul   <$> (reserved "qualif"       >> qualifierP sortP)     <|> Kut   <$> (reserved "cut"          >> kvarP)-    <|> EBind <$> (reserved "ebind"        >> intP) <*> symbolP <*> (colon >> braces sortP)-    <|> IBind <$> (reserved "bind"         >> intP) <*> symbolP <*> (colon >> sortedReftP)+    <|> EBind <$> (reserved "ebind"        >> intP) <*> symbolP <*> (colon >> braces sortP) <*> pure ()+    <|> IBind <$> (reserved "bind"         >> intP) <*> symbolP <*> (colon >> sortedReftP)  <*> pure ()     <|> Opt    <$> (reserved "fixpoint"    >> stringLiteral)     <|> Def    <$> (reserved "define"      >> defineP)     <|> Mat    <$> (reserved "match"       >> matchP)@@ -1318,9 +1312,11 @@ wfCP = do reserved "env"           env <- envP           reserved "reft"-          r   <- sortedReftP-          let [w] = wfC env r ()-          return w+          r <- sortedReftP+          case wfC env r () of+            [w]   -> return w+            []    -> error "Unexpected empty list in wfCP"+            _:_:_ -> error "Expected a single element list in wfCP"  subCP :: Parser (SubC ()) subCP = do pos <- getSourcePos@@ -1333,8 +1329,7 @@            reserved "id"            i   <- natural <* spaces            tag <- tagP-           pos' <- getSourcePos-           return $ subC' env lhs rhs i tag pos pos'+           subC' env lhs rhs i tag pos <$> getSourcePos  subC' :: IBindEnv       -> SortedReft@@ -1368,15 +1363,15 @@     <|> (reserved "False" >> return False)  defsFInfo :: [Def a] -> FInfo a-defsFInfo defs = {- SCC "defsFI" #-} FI cm ws bs ebs lts dts kts qs binfo adts mempty mempty ae+defsFInfo defs = {- SCC "defsFI" -} Types.FI cm ws bs ebs lts dts kts qs binfo adts mempty mempty ae   where     cm         = Misc.safeFromList                    "defs-cm"        [(cid c, c)         | Cst c       <- defs]     ws         = Misc.safeFromList                    "defs-ws"        [(i, w)              | Wfc w    <- defs, let i = Misc.thd3 (wrft w)]-    bs         = bindEnvFromList  $ exBinds ++ [(n,x,r)  | IBind n x r <- defs]-    ebs        =                    [ n                  | (n,_,_) <- exBinds]-    exBinds    =                    [(n, x, RR t mempty) | EBind n x t <- defs]+    bs         = bindEnvFromList  $ exBinds ++ [(n,(x,r,a)) | IBind n x r a <- defs]+    ebs        =                    [ n                  | (n,_) <- exBinds]+    exBinds    =                    [(n, (x, RR t mempty, a)) | EBind n x t a <- defs]     lts        = fromListSEnv       [(x, t)             | Con x t     <- defs]     dts        = fromListSEnv       [(x, t)             | Dis x t     <- defs]     kts        = KS $ S.fromList    [k                  | Kut k       <- defs]@@ -1387,14 +1382,14 @@     rews       =                    [r                  | Mat r       <- defs]     autoRWs    = M.fromList         [(arId , s)         | AutoRW arId s <- defs]     rwEntries  =                    [(i, f)             | RWMap fs   <- defs, (i,f) <- fs]-    rwMap      = foldl insert (M.fromList []) rwEntries+    rwMap      = foldl' insert (M.fromList []) rwEntries                  where-                   insert map (cid, arId) =+                   insert map' (cid', arId) =                      case M.lookup arId autoRWs of                        Just rewrite ->-                         M.insertWith (++) (fromIntegral cid) [rewrite] map+                         M.insertWith (++) (fromIntegral cid') [rewrite] map'                        Nothing ->-                         map+                         map'     cid        = fromJust . sid     ae         = AEnv eqs rews expand rwMap     adts       =                    [d                  | Adt d       <- defs]@@ -1414,7 +1409,7 @@ crashP pp = do   i   <- pp   msg <- takeWhileP Nothing (const True) -- consume the rest of the input-  return $ Crash [i] msg+  return $ Crash [(i, Nothing)] msg  predSolP :: Parser Expr predSolP = parens (predP  <* (comma >> iQualP))@@ -1547,10 +1542,10 @@   rr' = doParse' solutionFileP  instance Inputable (FInfo ()) where-  rr' = {- SCC "fInfoP" #-} doParse' fInfoP+  rr' = {- SCC "fInfoP" -} doParse' fInfoP  instance Inputable (FInfoWithOpts ()) where-  rr' = {- SCC "fInfoWithOptsP" #-} doParse' fInfoOptP+  rr' = {- SCC "fInfoWithOptsP" -} doParse' fInfoOptP  instance Inputable Command where   rr' = doParse' commandP

src/Language/Fixpoint/Smt/Bitvector.hs view

@@ -28,6 +28,7 @@ import           GHC.Generics            (Generic) import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types+import           Data.List (foldl')  data Bv     = Bv !BvSize !String @@ -57,7 +58,7 @@  -- | Apply some bitvector operator to a list of arguments eOp :: BvOp -> [Expr] -> Expr-eOp b es = foldl EApp (EVar $ opName b) es+eOp b es = foldl' EApp (EVar $ opName b) es  opName :: BvOp -> Symbol opName BvAnd = bvAndName

src/Language/Fixpoint/Smt/Interface.hs view

@@ -8,6 +8,8 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE PatternGuards             #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | This module contains an SMTLIB2 interface for --   1. checking the validity, and, --   2. computing satisfying assignments@@ -106,10 +108,6 @@ import           Data.Char import qualified Data.HashMap.Strict      as M import           Data.Maybe              (fromMaybe)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup          (Semigroup (..))-#endif- import qualified Data.Text                as T -- import           Data.Text.Format import qualified Data.Text.IO             as TIO@@ -203,14 +201,14 @@ smtWrite me !s = smtWriteRaw me s  smtRead :: Context -> IO Response-smtRead me = {- SCC "smtRead" #-} do+smtRead me = {- SCC "smtRead" -} do   when (ctxVerbose me) $ LTIO.putStrLn "SMT READ"   ln  <- smtReadRaw me   res <- A.parseWith (smtReadRaw me) responseP ln   case A.eitherResult res of     Left e  -> Misc.errorstar $ "SMTREAD:" ++ e     Right r -> do-      maybe (return ()) (\h -> LTIO.hPutStrLn h $ blt ("; SMT Says: " <> (bShow r))) (ctxLog me)+      maybe (return ()) (\h -> LTIO.hPutStrLn h $ blt ("; SMT Says: " <> bShow r)) (ctxLog me)       when (ctxVerbose me) $ LTIO.putStrLn $ blt ("SMT Says: " <> bShow r)       return r @@ -219,13 +217,13 @@ type SmtParser a = Parser T.Text a  responseP :: SmtParser Response-responseP = {- SCC "responseP" #-} A.char '(' *> sexpP+responseP = {- SCC "responseP" -} A.char '(' *> sexpP          <|> A.string "sat"     *> return Sat          <|> A.string "unsat"   *> return Unsat          <|> A.string "unknown" *> return Unknown  sexpP :: SmtParser Response-sexpP = {- SCC "sexpP" #-} A.string "error" *> (Error <$> errorP)+sexpP = {- SCC "sexpP" -} A.string "error" *> (Error <$> errorP)      <|> Values <$> valuesP  errorP :: SmtParser T.Text@@ -235,20 +233,20 @@ valuesP = A.many1' pairP <* A.char ')'  pairP :: SmtParser (Symbol, T.Text)-pairP = {- SCC "pairP" #-}+pairP = {- SCC "pairP" -}   do A.skipSpace-     A.char '('+     _ <- A.char '('      !x <- symbolP      A.skipSpace      !v <- valueP-     A.char ')'+     _ <- A.char ')'      return (x,v)  symbolP :: SmtParser Symbol-symbolP = {- SCC "symbolP" #-} symbol <$> A.takeWhile1 (not . isSpace)+symbolP = {- SCC "symbolP" -} symbol <$> A.takeWhile1 (not . isSpace)  valueP :: SmtParser T.Text-valueP = {- SCC "valueP" #-} negativeP+valueP = {- SCC "valueP" -} negativeP       <|> A.takeWhile1 (\c -> not (c == ')' || isSpace c))  negativeP :: SmtParser T.Text@@ -256,18 +254,23 @@   = do v <- A.char '(' *> A.takeWhile1 (/=')') <* A.char ')'        return $ "(" <> v <> ")" -smtWriteRaw      :: Context -> Raw -> IO ()-smtWriteRaw me !s = {- SCC "smtWriteRaw" #-} do+-- | Writes a line of input for the SMT solver and to the log if there is one.+smtWriteRaw :: Context -> Raw -> IO ()+smtWriteRaw me !s = {- SCC "smtWriteRaw" -} do   -- whenLoud $ do LTIO.appendFile debugFile (s <> "\n")   --               LTIO.putStrLn ("CMD-RAW:" <> s <> ":CMD-RAW:DONE")-  hPutStrLnNow (ctxCout me) s+  hPutStrLnNow (ctxIn me) s   maybe (return ()) (`LTIO.hPutStrLn` s) (ctxLog me) -smtReadRaw       :: Context -> IO T.Text-smtReadRaw me    = {- SCC "smtReadRaw" #-} TIO.hGetLine (ctxCin me)+-- | Reads a line of output from the SMT solver.+smtReadRaw :: Context -> IO T.Text+smtReadRaw me = do+  eof <- hIsEOF (ctxOut me)+  if eof then Misc.errorstar "SMT returned End of File" else+    TIO.hGetLine (ctxOut me) {-# SCC smtReadRaw  #-} -hPutStrLnNow     :: Handle -> LT.Text -> IO ()+hPutStrLnNow :: Handle -> LT.Text -> IO () hPutStrLnNow h !s = LTIO.hPutStrLn h s >> hFlush h {-# SCC hPutStrLnNow #-} @@ -307,7 +310,7 @@  makeProcess :: Config -> IO Context makeProcess cfg-  = do (hOut, hIn, _ ,pid) <- runInteractiveCommand $ smtCmd (solver cfg)+  = do (hIn, hOut, _ ,pid) <- runInteractiveCommand $ smtCmd (solver cfg)        loud <- isLoud        hSetBuffering hOut $ BlockBuffering $ Just $ 1024*1024*64        hSetBuffering hIn $ BlockBuffering $ Just $ 1024*1024*64@@ -320,11 +323,11 @@            when (LT.null t) retry            writeTVar queueTVar mempty            return t-         LTIO.hPutStr hOut t-         hFlush hOut+         LTIO.hPutStr hIn t+         hFlush hIn        return Ctx { ctxPid     = pid-                  , ctxCin     = hIn-                  , ctxCout    = hOut+                  , ctxIn      = hIn+                  , ctxOut     = hOut                   , ctxLog     = Nothing                   , ctxVerbose = loud                   , ctxSymEnv  = mempty@@ -332,13 +335,12 @@                   , ctxTVar    = queueTVar                   } ---------------------------------------------------------------------------+-- | Close file handles and wait for the solver process to terminate. cleanupContext :: Context -> IO ExitCode----------------------------------------------------------------------------cleanupContext (Ctx {..}) = do+cleanupContext Ctx{..} = do   cancel ctxAsync-  hCloseMe "ctxCin"  ctxCin-  hCloseMe "ctxCout" ctxCout+  hCloseMe "ctxIn" ctxIn+  hCloseMe "ctxOut"  ctxOut   maybe (return ()) (hCloseMe "ctxLog") ctxLog   waitForProcess ctxPid @@ -354,37 +356,39 @@ smtCmd Mathsat = "mathsat -input=smt2" smtCmd Cvc4    = "cvc4 --incremental -L smtlib2" --- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2... smtPreamble :: Config -> SMTSolver -> Context -> IO [LT.Text] smtPreamble cfg Z3 me-  = do smtWrite me "(get-info :version)"-       v:_ <- T.words . (!!1) . T.splitOn "\"" <$> smtReadRaw me+  = do v <- getZ3Version me        checkValidStringFlag Z3 v cfg-       if T.splitOn "." v `versionGreaterEq` ["4", "3", "2"]-         then return $ z3_432_options ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3-         else return $ z3_options     ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3+       return $ z3_options ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3 smtPreamble cfg s _-  = checkValidStringFlag s "" cfg >> return (Thy.preamble cfg s)+  = checkValidStringFlag s [] cfg >> return (Thy.preamble cfg s) -checkValidStringFlag :: SMTSolver -> T.Text -> Config -> IO ()+getZ3Version :: Context -> IO [Int]+getZ3Version me+  = do smtWrite me "(get-info :version)"+       -- resp is like (:version "4.8.15")+       resp <- smtReadRaw me+       case T.splitOn "\"" resp of+         _:vText:_ -> do+           let parsedComponents = [ reads (T.unpack cText) | cText <- T.splitOn "." vText ]+           sequence+             [ case pComponent of+                 [(c, "")] -> return c+                 xs -> error $ "Can't parse z3 version: " ++ show xs+             | pComponent <- parsedComponents+             ]+         xs -> error $ "Can't parse z3 (get-info :version): " ++ show xs++checkValidStringFlag :: SMTSolver -> [Int] -> Config -> IO () checkValidStringFlag smt v cfg   = when (noString smt v cfg) $       die $ err dummySpan (text "stringTheory is only supported by z3 version >=4.2.2") -noString :: SMTSolver -> T.Text -> Config -> Bool+noString :: SMTSolver -> [Int] -> Config -> Bool noString smt v cfg   =  stringTheory cfg-  && not (smt == Z3 && (T.splitOn "." v `versionGreaterEq` ["4", "4", "2"]))---versionGreaterEq :: Ord a => [a] -> [a] -> Bool-versionGreaterEq (x:xs) (y:ys)-  | x >  y = True-  | x == y = versionGreaterEq xs ys-  | x <  y = False-versionGreaterEq _  [] = True-versionGreaterEq [] _  = False-versionGreaterEq _ _ = Misc.errorstar "Interface.versionGreater called with bad arguments"+  && not (smt == Z3 && (v >= [4, 4, 2]))  ----------------------------------------------------------------------------- -- | SMT Commands -----------------------------------------------------------@@ -512,7 +516,7 @@  makeTimeout :: Config -> [LT.Text] makeTimeout cfg-  | Just i <- smtTimeout cfg = [ LT.pack ("\n(set-option :timeout " ++ (show i) ++ ")\n")]+  | Just i <- smtTimeout cfg = [ LT.pack ("\n(set-option :timeout " ++ show i ++ ")\n")]   | otherwise                = [""]  @@ -521,23 +525,15 @@   | gradual cfg = [""]   | otherwise   = ["\n(set-option :smt.mbqi false)"] --- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2...-z3_432_options :: [LT.Text]-z3_432_options-  = [ "(set-option :auto-config false)"-    , "(set-option :model true)"-    , "(set-option :model.partial false)"]- z3_options :: [LT.Text] z3_options   = [ "(set-option :auto-config false)"-    , "(set-option :model true)"-    , "(set-option :model-partial false)"]+    , "(set-option :model true)" ]    ---------------------------------------------------------------------------------declare :: Context -> IO () -- SolveM ()+declare :: Context -> IO () -------------------------------------------------------------------------------- declare me = do   forM_ dss    $           smtDataDecl me@@ -555,7 +551,7 @@     thyXTs     =                    filter (isKind 1) xts     qryXTs     = Misc.mapSnd tx <$> filter (isKind 2) xts     isKind n   = (n ==)  . symKind env . fst-    xts        = {- tracepp "symbolSorts" $ -} symbolSorts (F.seSort env) +    xts        = {- tracepp "symbolSorts" $ -} symbolSorts (F.seSort env)     tx         = elaborate    "declare" env     ats        = funcSortVars env @@ -609,4 +605,3 @@     tess             = Misc.groupList [(t, F.expr x) | (x, t) <- xts, notFun t]     notFun           = not . F.isFunctionSortedReft . (`F.RR` F.trueReft)     -- _notStr          = not . (F.strSort ==) . F.sr_sort . (`F.RR` F.trueReft)-

src/Language/Fixpoint/Smt/Serialize.hs view

@@ -1,11 +1,13 @@ {-# LANGUAGE CPP                  #-} {-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE PatternGuards        #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE DoAndIfThenElse      #-} +{-# OPTIONS_GHC -Wno-orphans        #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | This module contains the code for serializing Haskell values --   into SMTLIB2 format, that is, the instances for the @SMTLIB2@ --   typeclass. We split it into a separate module as it depends on@@ -18,9 +20,6 @@ import qualified Language.Fixpoint.Types.Visitor as Vis import           Language.Fixpoint.Smt.Types import qualified Language.Fixpoint.Smt.Theories as Thy-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup                 (Semigroup (..))-#endif  -- import           Data.Text.Format import           Language.Fixpoint.Misc (sortNub, errorstar)@@ -46,12 +45,12 @@                          , parens $ smt2many (smt2datactors env <$> ds)                          ] - + smt2dataname :: SymEnv -> DataDecl -> Builder.Builder smt2dataname env (DDecl tc as _) = parenSeqs [name, n]   where     name  = smt2 env (symbol tc)-    n     = smt2 env as +    n     = smt2 env as   smt2datactors :: SymEnv -> DataDecl -> Builder.Builder@@ -59,12 +58,12 @@   where     tvars        = smt2many (smt2TV <$> [0..(as-1)])     smt2TV       = smt2 env . SVar-    ds           = smt2many (smt2ctor env as <$> cs) +    ds           = smt2many (smt2ctor env as <$> cs)  smt2ctor :: SymEnv -> Int -> DataCtor -> Builder.Builder smt2ctor env _  (DCtor c [])  = smt2 env c smt2ctor env as (DCtor c fs)  = parenSeqs [smt2 env c, fields]-                                +   where     fields                 = smt2many (smt2field env as <$> fs) @@ -101,8 +100,8 @@     | Just t <- Thy.smt2Symbol env s = t   smt2 _ s                           = symbolBuilder s -instance SMTLIB2 Int where -  smt2 _ = Builder.fromString . show +instance SMTLIB2 Int where+  smt2 _ = Builder.fromString . show  instance SMTLIB2 LocSymbol where   smt2 env = smt2 env . val@@ -148,14 +147,14 @@   smt2 _   (PAnd [])        = "true"   smt2 env (PAnd ps)        = parenSeqs ["and", smt2s env ps]   smt2 _   (POr [])         = "false"-  smt2 env (POr ps)         = parenSeqs ["or", smt2s env ps] +  smt2 env (POr ps)         = parenSeqs ["or", smt2s env ps]   smt2 env (PNot p)         = parenSeqs ["not", smt2  env p]   smt2 env (PImp p q)       = parenSeqs ["=>", smt2 env p, smt2 env q]   smt2 env (PIff p q)       = parenSeqs ["=", smt2 env p, smt2 env q]   smt2 env (PExist [] p)    = smt2 env p   smt2 env (PExist bs p)    = parenSeqs ["exists", parens (smt2s env bs), smt2 env p]   smt2 env (PAll   [] p)    = smt2 env p-  smt2 env (PAll   bs p)    = parenSeqs ["forall", parens (smt2s env bs), smt2 env p] +  smt2 env (PAll   bs p)    = parenSeqs ["forall", parens (smt2s env bs), smt2 env p]   smt2 env (PAtom r e1 e2)  = mkRel env r e1 e2   smt2 env (ELam b e)       = smt2Lam   env b e   smt2 env (ECoerc t1 t2 e) = smt2Coerc env t1 t2 e@@ -205,13 +204,13 @@     (f, es)   = splitEApp' e  smt2Coerc :: SymEnv -> Sort -> Sort -> Expr -> Builder.Builder-smt2Coerc env t1 t2 e +smt2Coerc env t1 t2 e   | t1' == t2'  = smt2 env e   | otherwise = parenSeqs [Builder.fromText coerceFn , smt2 env e]-  where +  where     coerceFn  = symbolAtName coerceName env (ECoerc t1 t2 e) t     t         = FFunc t1 t2-    t1'       = smt2SortMono e env t1 +    t1'       = smt2SortMono e env t1     t2'       = smt2SortMono e env t2  splitEApp' :: Expr -> (Expr, [Expr])@@ -242,13 +241,13 @@     | length az < 2            = ""     | otherwise                = key "assert" (key "distinct" (smt2s env az))   smt2 env (AssertAx t)        = key "assert" (smt2 env t)-  smt2 _   (Push)              = "(push 1)"-  smt2 _   (Pop)               = "(pop 1)"-  smt2 _   (CheckSat)          = "(check-sat)"+  smt2 _   Push                = "(push 1)"+  smt2 _   Pop                 = "(pop 1)"+  smt2 _   CheckSat            = "(check-sat)"   smt2 env (GetValue xs)       = key "key-value" (parens (smt2s env xs))   smt2 env (CMany cmds)        = smt2many (smt2 env <$> cmds)-  smt2 _   (Exit)              = "(exit)"-  smt2 _   (SetMbqi)           = "(set-option :smt.mbqi true)"+  smt2 _   Exit                = "(exit)"+  smt2 _   SetMbqi             = "(set-option :smt.mbqi true)"  instance SMTLIB2 (Triggered Expr) where   smt2 env (TR NoTrigger e)       = smt2 env e@@ -257,10 +256,10 @@   smt2 env (TR _ (PAll   [] p))   = smt2 env p   smt2 env t@(TR _ (PAll   bs p)) = smtTr env "forall" bs p t   smt2 env (TR _ e)               = smt2 env e-  + {-# INLINE smtTr #-} smtTr :: SymEnv -> Builder.Builder -> [(Symbol, Sort)] -> Expr -> Triggered Expr -> Builder.Builder-smtTr env q bs p t = key q (parens (smt2s env bs) <+> key "!" (smt2 env p <+> ":pattern" <> parens (smt2s env (makeTriggers t)))) +smtTr env q bs p t = key q (parens (smt2s env bs) <+> key "!" (smt2 env p <+> ":pattern" <> parens (smt2s env (makeTriggers t))))  {-# INLINE smt2s #-} smt2s    :: SMTLIB2 a => SymEnv -> [a] -> Builder.Builder

src/Language/Fixpoint/Smt/Theories.hs view

@@ -4,7 +4,11 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE ViewPatterns              #-} +{-# OPTIONS_GHC -Wno-orphans           #-}+{-# OPTIONS_GHC -Wno-name-shadowing    #-}+ module Language.Fixpoint.Smt.Theories      (        -- * Convert theory applications TODO: merge with smt2symbol@@ -38,10 +42,6 @@      ) where  import           Prelude hiding (map)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif- import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types@@ -71,7 +71,8 @@ set  = "LSet" map  = "Map" -emp, sng, add, cup, cap, mem, dif, sub, com, sel, sto, mcup, mdef :: Raw+emp, sng, add, cup, cap, mem, dif, sub, com, sel, sto, mcup, mdef, mprj :: Raw+mToSet, mshift, mmax, mmin :: Raw emp   = "smt_set_emp" sng   = "smt_set_sng" add   = "smt_set_add"@@ -84,10 +85,16 @@ sel   = "smt_map_sel" sto   = "smt_map_sto" mcup  = "smt_map_cup"+mmax  = "smt_map_max"+mmin  = "smt_map_min" mdef  = "smt_map_def"+mprj  = "smt_map_prj"+mshift = "smt_map_shift"+mToSet = "smt_map_to_set"  -setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng :: Symbol+setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup :: Symbol+setDif, setSng :: Symbol setEmpty = "Set_empty" setEmp   = "Set_emp" setCap   = "Set_cap"@@ -99,12 +106,51 @@ setDif   = "Set_dif" setSng   = "Set_sng" -mapSel, mapSto, mapCup, mapDef :: Symbol+mapSel, mapSto, mapCup, mapDef, mapPrj, mapToSet :: Symbol+mapMax, mapMin, mapShift :: Symbol mapSel   = "Map_select" mapSto   = "Map_store" mapCup   = "Map_union"+mapMax   = "Map_union_max"+mapMin   = "Map_union_min" mapDef   = "Map_default"+mapPrj   = "Map_project"+mapShift = "Map_shift" -- See [Map key shift]+mapToSet = "Map_to_set" +-- [Interaction between Map and Set]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Function mapToSet: Convert a map to a set. The map's key may be of+-- any type and is preserved as the set's element type. More precisely:+--   mapToSet : Map k Int -> Set k+-- The element type must be Int. All non-positive elements are mapped+-- to False, and all positive elements are mapped to True. In practice,+-- negative elements should not exist because Map is intended to be used+-- as a bag, so the element is a non-negative number representing+-- the occurrences of its corresponding key.+--+-- Function mapPrj: Project a subset of a map. Type signature:+--   mapPrj : Set k -> Map k Int -> Map k Int+-- If the key is present in both the argument set and the argument map,+-- then the key (along with its associated value in the map) are preserved+-- in the output. Keys not present in the set are mapped to zero. Keys not+-- present in the set are mapped to zero.+--+-- [Map key shift]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Function mapShift: Add an integer to all keys in a map. Type signature:+--   mapShift : Int -> Map Int v -> Map Int v+-- Let's call the first argument (the shift amount) N, the second argument K1,+-- and the result K2. For all indices i, we have K2[i] = K1[i - N].+-- This is implemented with Z3's lambda, which lets us construct an array+-- from a function.+--+-- [Map max and min]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Functions mapMax and mapMin: Union two maps, combining the elements by+-- taking either the greatest (mapMax) or the least (mapMin) of them.+--   mapMax, mapMin : Map v Int -> Map v Int -> Map v Int+ strLen, strSubstr, strConcat :: (IsString a) => a -- Symbol strLen    = "strLen" strSubstr = "subString"@@ -139,62 +185,101 @@ z3Preamble :: Config -> [T.Text] z3Preamble u   = stringPreamble u ++-    [ bSort elt +    [ bSort elt         "Int"-    , bSort set +    , bSort set         (key2 "Array" (bb elt) "Bool")-    , bFun emp -        [] -        (bb set) +    , bFun emp+        []+        (bb set)         (parens (key "as const" (bb set) <+> "false"))     , bFun sng         [("x", bb elt)]         (bb set)         (key3 "store" (parens (key "as const" (bb set) <+> "false")) "x" "true")-    , bFun mem -        [("x", bb elt), ("s", bb set)] +    , bFun mem+        [("x", bb elt), ("s", bb set)]         "Bool"         "(select s x)"     , bFun add-        [("s", bb set), ("x", bb elt)] +        [("s", bb set), ("x", bb elt)]         (bb set)         "(store s x true)"-    , bFun cup -        [("s1", bb set), ("s2", bb set)] +    , bFun cup+        [("s1", bb set), ("s2", bb set)]         (bb set)         "((_ map or) s1 s2)"-    , bFun cap -        [("s1", bb set), ("s2", bb set)] +    , bFun cap+        [("s1", bb set), ("s2", bb set)]         (bb set)         "((_ map and) s1 s2)"     , bFun com-        [("s", bb set)] +        [("s", bb set)]         (bb set)         "((_ map not) s)"-    , bFun dif -        [("s1", bb set), ("s2", bb set)] +    , bFun dif+        [("s1", bb set), ("s2", bb set)]         (bb set)         (key2 (bb cap) "s1" (key (bb com) "s2"))     , bFun sub         [("s1", bb set), ("s2", bb set)]         "Bool"-        (key2 "=" (bb emp) (key2 (bb dif) "s1" "s2")) +        (key2 "=" (bb emp) (key2 (bb dif) "s1" "s2")) -    -- Maps    +    -- Maps     , bSort map         (key2 "Array" (bb elt) (bb elt))     , bFun sel         [("m", bb map), ("k", bb elt)]-        (bb elt)    +        (bb elt)         "(select m k)"     , bFun sto         [("m", bb map), ("k", bb elt), ("v", bb elt)]-        (bb map)    +        (bb map)         "(store m k v)"     , bFun mcup         [("m1", bb map), ("m2", bb map)]         (bb map)         (key2 (key "_ map" (key2 "+" (parens (bb elt <+> bb elt)) (bb elt))) "m1" "m2")+    , bFun mprj -- See [Interaction Between Map and Set]+        [("s", bb set), ("m", bb map)]+        (bb map)+        (key3+          (key "_ map"+            (key2 "ite"+              (parens ("Bool" <+> bb elt <+> bb elt))+              (bb elt)+            )+          )+          "s"+          "m"+          (parens (key "as const" (key2 "Array" (bb elt) (bb elt)) <+> "0"))+        )+    , bFun mToSet -- See [Interaction Between Map and Set]+        [("m", bb map)]+        (bb set)+        (key2+          (key "_ map"+            (key2 ">"+              (parens (bb elt <+> bb elt))+              "Bool"+            )+          )+          "m"+          (parens (key "as const" (key2 "Array" (bb elt) (bb elt)) <+> "0"))+        )+    , bFun mmax -- See [Map max and min]+        [("m1", bb map),("m2", bb map)]+        (bb map)+        "(lambda ((i Int)) (ite (> (select m1 i) (select m2 i)) (select m1 i) (select m2 i)))"+    , bFun mmin -- See [Map max and min]+        [("m1", bb map),("m2", bb map)]+        (bb map)+        "(lambda ((i Int)) (ite (< (select m1 i) (select m2 i)) (select m1 i) (select m2 i)))"+    , bFun mshift -- See [Map key shift]+        [("n", "Int"),("m", bb map)]+        (bb map)+        "(lambda ((i Int)) (select m (- i n)))"     , bFun mdef         [("v", bb elt)]         (bb map)@@ -204,19 +289,19 @@         "Int"         "(ite b 1 0)" -    , uifDef u (symbolLText mulFuncName) "*" +    , uifDef u (symbolLText mulFuncName) "*"     , uifDef u (symbolLText divFuncName) "div"     ]  symbolLText :: Symbol -> T.Text-symbolLText = T.fromStrict . symbolText +symbolLText = T.fromStrict . symbolText  -- RJ: Am changing this to `Int` not `Real` as (1) we usually want `Int` and -- (2) have very different semantics. TODO: proper overloading, post genEApp uifDef :: Config -> T.Text -> T.Text -> T.Text uifDef cfg f op   | linear cfg || Z3 /= solver cfg-  = bFun' f ["Int", "Int"] "Int" +  = bFun' f ["Int", "Int"] "Int"   | otherwise   = bFun f [("x", "Int"), ("y", "Int")] "Int" (key2 (bb op) "x" "y") @@ -231,7 +316,7 @@   = [ bSort elt    "Int"     , bSort set    "Int"     , bSort string "Int"-    , bFun' emp []               (bb set) +    , bFun' emp []               (bb set)     , bFun' sng [bb elt]         (bb set)     , bFun' add [bb set, bb elt] (bb set)     , bFun' cup [bb set, bb set] (bb set)@@ -243,7 +328,7 @@     ]  cvc4MapPreamble :: Config -> [T.Text]-cvc4MapPreamble _ =      +cvc4MapPreamble _ =     [ bSort map    (key2 "Array" (bb elt) (bb elt))     , bFun sel [("m", bb map), ("k", bb elt)]                (bb elt) "(select m k)"     , bFun sto [("m", bb map), ("k", bb elt), ("v", bb elt)] (bb map) "(store m k v)"@@ -251,7 +336,7 @@  smtlibPreamble :: Config -> [T.Text] smtlibPreamble z --TODO use uif flag u (see z3Preamble)-  = commonPreamble z +  = commonPreamble z  ++ [ bSort map "Int"     , bFun' sel [bb map, bb elt] (bb elt)     , bFun' sto [bb map, bb elt, bb elt] (bb map)@@ -259,7 +344,7 @@  stringPreamble :: Config -> [T.Text] stringPreamble cfg | stringTheory cfg-  = [ bSort string "String" +  = [ bSort string "String"     , bFun strLen [("s", bb string)] "Int" (key (bb z3strlen) "s")     , bFun strSubstr [("s", bb string), ("i", "Int"), ("j", "Int")] (bb string) (key (bb z3strsubstr) "s i j")     , bFun strConcat [("x", bb string), ("y", bb string)] (bb string) (key (bb z3strconcat) "x y")@@ -267,7 +352,7 @@  stringPreamble _   = [ bSort string "Int"-    , bFun' strLen [bb string] "Int" +    , bFun' strLen [bb string] "Int"     , bFun' strSubstr [bb string, "Int", "Int"] (bb string)     , bFun' strConcat [bb string, bb string] (bb string)     ]@@ -302,7 +387,7 @@ -------------------------------------------------------------------------------- smt2App :: VarAs -> SymEnv -> Expr -> [Builder] -> Maybe Builder ---------------------------------------------------------------------------------smt2App _ _ (ECst (EVar f) _) [d]+smt2App _ _ (dropECst -> EVar f) [d]   | f == setEmpty = Just (bb emp)   | f == setEmp   = Just (key2 "=" (bb emp) d)   | f == setSng   = Just (key (bb sng) d) -- Just (key2 (bb add) (bb emp) d)@@ -314,10 +399,10 @@ smt2App _ _ _ _    = Nothing  smt2AppArg :: VarAs -> SymEnv -> Expr -> Maybe Builder-smt2AppArg k env (ECst (EVar f) t)+smt2AppArg k env (ECst (dropECst -> EVar f) t)   | Just fThy <- symEnvTheory f env   = Just $ if isPolyCtor fThy t-            then (k env f (ffuncOut t))+            then k env f (ffuncOut t)             else bb (tsRaw fThy)  smt2AppArg _ _ _@@ -332,7 +417,7 @@ -------------------------------------------------------------------------------- isSmt2App :: SEnv TheorySymbol -> Expr -> Maybe Int ---------------------------------------------------------------------------------isSmt2App g  (EVar f)+isSmt2App g  (dropECst -> EVar f)   | f == setEmpty = Just 1   | f == setEmp   = Just 1   | f == setSng   = Just 1@@ -385,7 +470,12 @@   , interpSym mapSel   sel   mapSelSort   , interpSym mapSto   sto   mapStoSort   , interpSym mapCup   mcup  mapCupSort+  , interpSym mapMax   mmax  mapMaxSort+  , interpSym mapMin   mmin  mapMinSort   , interpSym mapDef   mdef  mapDefSort+  , interpSym mapPrj   mprj  mapPrjSort+  , interpSym mapShift mshift mapShiftSort+  , interpSym mapToSet mToSet mapToSetSort   , interpSym bvOrName "bvor"   bvBopSort   , interpSym bvAndName "bvand" bvBopSort   , interpSym strLen    strLen    strLenSort@@ -404,6 +494,15 @@     mapCupSort = FAbs 0          $ FFunc (mapSort (FVar 0) intSort)                                  $ FFunc (mapSort (FVar 0) intSort)                                          (mapSort (FVar 0) intSort)+    mapMaxSort = mapCupSort+    mapMinSort = mapCupSort+    mapPrjSort = FAbs 0          $ FFunc (setSort (FVar 0))+                                 $ FFunc (mapSort (FVar 0) intSort)+                                         (mapSort (FVar 0) intSort)+    mapShiftSort = FAbs 0        $ FFunc intSort+                                 $ FFunc (mapSort intSort (FVar 0))+                                         (mapSort intSort (FVar 0))+    mapToSetSort = FAbs 0        $ FFunc (mapSort (FVar 0) intSort) (setSort (FVar 0))     mapStoSort = FAbs 0 $ FAbs 1 $ FFunc (mapSort (FVar 0) (FVar 1))                                  $ FFunc (FVar 0)                                  $ FFunc (FVar 1)

src/Language/Fixpoint/Smt/Types.hs view

@@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE UndecidableInstances      #-} +{-# OPTIONS_GHC -Wno-name-shadowing    #-}+ -- | This module contains the types defining an SMTLIB2 interface.  module Language.Fixpoint.Smt.Types (@@ -73,14 +75,14 @@ ppCmd (DeclData d)     = text "Data" <+> pprint d ppCmd (Declare x [] t) = text "Declare" <+> text (T.unpack x) <+> text ":" <+> pprint t ppCmd (Declare x ts t) = text "Declare" <+> text (T.unpack x) <+> text ":" <+> parens (pprint ts) <+> pprint t-ppCmd (Define {})   = text "Define ..."+ppCmd Define {}   = text "Define ..." ppCmd (DefineFunc name params rsort e) =   text "DefineFunc" <+> pprint name <+> pprint params <+> pprint rsort <+> pprint e ppCmd (Assert _ e)  = text "Assert" <+> pprint e ppCmd (AssertAx _)  = text "AssertAxiom ..."-ppCmd (Distinct {}) = text "Distinct ..."-ppCmd (GetValue {}) = text "GetValue ..."-ppCmd (CMany {})    = text "CMany ..."+ppCmd Distinct {} = text "Distinct ..."+ppCmd GetValue {} = text "GetValue ..."+ppCmd CMany {}    = text "CMany ..."  -- | Responses received from SMT engine data Response     = Ok@@ -94,12 +96,13 @@ -- | Information about the external SMT process data Context = Ctx   { ctxPid     :: !ProcessHandle-  , ctxCin     :: !Handle-  , ctxCout    :: !Handle+    -- | The handle for writing queries to, for input to the SMT solver.+  , ctxIn      :: !Handle+    -- | The handle for reading responses from, the output from the SMT solver.+  , ctxOut     :: !Handle   , ctxLog     :: !(Maybe Handle)   , ctxVerbose :: !Bool   , ctxSymEnv  :: !SymEnv-    -- | The handle of the thread writing queries to the SMT solver   , ctxAsync   :: Async ()     -- | The next batch of queries to send to the SMT solver   , ctxTVar    :: TVar Builder

src/Language/Fixpoint/Solver.hs view

@@ -3,11 +3,11 @@ --   either as .fq files or as FInfo. {-# LANGUAGE BangPatterns        #-} {-# LANGUAGE DoAndIfThenElse     #-}-{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Solver (     -- * Invoke Solver on an FInfo     solve, Solver@@ -54,11 +54,13 @@ import           Language.Fixpoint.Utils.Statistics (statistics) import           Language.Fixpoint.Graph import           Language.Fixpoint.Parse            (rr')-import           Language.Fixpoint.Types+import           Language.Fixpoint.Types hiding (GInfo(..), fi)+import qualified Language.Fixpoint.Types as Types (GInfo(..)) import           Language.Fixpoint.Minimize (minQuery, minQuals, minKvars) import           Language.Fixpoint.Solver.Instantiate (instantiate) import           Control.DeepSeq import qualified Data.ByteString as B+import Data.Maybe (catMaybes)  --------------------------------------------------------------------------- -- | Solve an .fq file ----------------------------------------------------@@ -74,22 +76,22 @@     file    = srcFile      cfg  ----------------------------------------------------------------------------resultExitCode :: (Fixpoint a, NFData a, ToJSON a) => Config -> Result a +resultExitCode :: (Fixpoint a, NFData a, ToJSON a) => Config -> Result a                -> IO ExitCode ----------------------------------------------------------------------------resultExitCode cfg r = do +resultExitCode cfg r = do   whenNormal $ colorStrLn (colorResult stat) (statStr $!! stat)   when (json cfg) $ LT.putStrLn jStr   return (eCode r)-  where +  where     jStr    = LT.decodeUtf8 . encode $ r     stat    = resStatus $!! r     eCode   = resultExit . resStatus-    statStr = render . resultDoc +    statStr = render . resultDoc  ignoreQualifiers :: Config -> FInfo a -> FInfo a ignoreQualifiers cfg fi-  | eliminate cfg == All = fi { quals = [] }+  | eliminate cfg == All = fi { Types.quals = [] }   | otherwise            = fi  @@ -126,15 +128,15 @@ readFq :: FilePath -> IO (FInfo (), [String]) readFq file = do   str   <- readFile file-  let q  = {- SCC "parsefq" #-} rr' file str :: FInfoWithOpts ()+  let q  = {- SCC "parsefq" -} rr' file str :: FInfoWithOpts ()   return (fioFI q, fioOpts q)  readBinFq :: FilePath -> IO (FInfo ())-readBinFq file = {-# SCC "parseBFq" #-} do +readBinFq file = {-# SCC "parseBFq" #-} do   bs <- B.readFile file-  case S.decode bs of +  case S.decode bs of     Right fi -> return fi-    Left err -> error ("Error decoding .bfq: " ++ show err) +    Left err' -> error ("Error decoding .bfq: " ++ show err')  -------------------------------------------------------------------------------- -- | Solve in parallel after partitioning an FInfo to indepdendant parts@@ -163,7 +165,7 @@     [onePart] -> s c onePart     _         -> inParallelUsing (f s c) $ zip [1..] fis     where-      f s c (j, fi) = s (c {srcFile = queryFile (Part j) c}) fi+      f s' c' (j, fi) = s' (c {srcFile = queryFile (Part j) c'}) fi  -------------------------------------------------------------------------------- -- | Solve a list of FInfos using the provided solver function in parallel@@ -181,15 +183,35 @@ -------------------------------------------------------------------------------- solveNative, solveNative' :: (NFData a, Fixpoint a, Show a, Loc a) => Solver a ---------------------------------------------------------------------------------solveNative !cfg !fi0 = (solveNative' cfg fi0)+solveNative !cfg !fi0 = solveNative' cfg fi0                           `catch`-                             (return . result)+                             (return . crashResult (errorMap fi0)) -result :: Error -> Result a-result e = Result (Crash [] msg) mempty mempty mempty+crashResult :: ErrorMap a -> Error -> Result (Integer, a)+crashResult m e = Result res mempty mempty mempty   where-    msg  = showpp e+    res           = Crash es msg+    es            = catMaybes [ findError m e | e <- errs e ]+    msg | null es = showpp e+        | otherwise = "Sorry, unexpected panic in liquid-fixpoint!" +-- | Unpleasant hack to save meta-data that can be recovered from SrcSpan+type ErrorMap a = HashMap.HashMap SrcSpan a++findError :: ErrorMap a -> Error1 -> Maybe ((Integer, a), Maybe String)+findError m e = do+  ann <- HashMap.lookup (errLoc e) m+  let str = render (errMsg e)+  return ((-1, ann), Just str)++-- The order is important here: we want the "binders" to get the "precedence"+errorMap :: (Loc a) => FInfo a -> ErrorMap a+errorMap fi = HashMap.fromList [ (srcSpan a, a) | a <- anns ]+  where+    anns    =  [ sinfo c | (_, c) <- HashMap.toList (Types.cm fi) ]+            ++ [ winfo w | (_, w) <- HashMap.toList (Types.ws fi) ]+            ++ [ a | (_, (_,_, a)) <- bindEnvToList (Types.bs fi) ]+ loudDump :: (Fixpoint a) => Int -> Config -> SInfo a -> IO () loudDump i cfg si = when False (writeLoud $ msg ++ render (toFixpoint cfg si))   where@@ -205,32 +227,32 @@   -- whenLoud $ print qs   -- whenLoud $ putStrLn $ showFix (quals fi1)   reducedFi <- reduceFInfo cfg fi0-  let fi1   = reducedFi { quals = remakeQual <$> quals reducedFi }-  let si0   = {- SCC "convertFormat" #-} convertFormat fi1+  let fi1   = reducedFi { Types.quals = remakeQual <$> Types.quals reducedFi }+  let si0   = {- SCC "convertFormat" -} convertFormat fi1   -- writeLoud $ "fq file after format convert: \n" ++ render (toFixpoint cfg si0)   -- rnf si0 `seq` donePhase Loud "Format Conversion"-  let si1   = either die id $ ({- SCC "sanitize" #-} sanitize cfg $!! si0)+  let si1   = either die id ({- SCC "sanitize" -} sanitize cfg $!! si0)   -- writeLoud $ "fq file after sanitize: \n" ++ render (toFixpoint cfg si1)   -- rnf si1 `seq` donePhase Loud "Validated Constraints"   graphStatistics cfg si1-  let si2  = {- SCC "wfcUniqify" #-} wfcUniqify $!! si1-  let si3  = {- SCC "renameAll"  #-} renameAll  $!! si2+  let si2  = {- SCC "wfcUniqify" -} wfcUniqify $!! si1+  let si3  = {- SCC "renameAll"  -} renameAll  $!! si2   rnf si3 `seq` whenLoud $ donePhase Loud "Uniqify & Rename"   loudDump 1 cfg si3-  let si4  = {- SCC "defunction" #-} defunctionalize cfg $!! si3+  let si4  = {- SCC "defunction" -} defunctionalize cfg $!! si3   -- putStrLn $ "AXIOMS: " ++ showpp (asserts si4)   loudDump 2 cfg si4-  let si5  = {- SCC "elaborate"  #-} elaborate (atLoc dummySpan "solver") (symbolEnv cfg si4) si4+  let si5  = {- SCC "elaborate" -} elaborate (atLoc dummySpan "solver") (symbolEnv cfg si4) si4   loudDump 3 cfg si5-  let si6 = if extensionality cfg then {- SCC "expand"     #-} expand cfg si5 else si5+  let si6 = if extensionality cfg then {- SCC "expand" -} expand cfg si5 else si5   if rewriteAxioms cfg && noLazyPLE cfg     then instantiate cfg si6 $!! Nothing     else return si6  reduceFInfo :: Fixpoint a => Config -> FInfo a -> IO (FInfo a) reduceFInfo cfg fi = do-  let simplifiedFi = {- SCC "simplifyFInfo" #-} simplifyBindings cfg fi-      reducedFi = {- SCC "reduceEnvironments" #-} reduceEnvironments simplifiedFi+  let simplifiedFi = {- SCC "simplifyFInfo" -} simplifyBindings cfg fi+      reducedFi = {- SCC "reduceEnvironments" -} reduceEnvironments simplifiedFi   when (save cfg) $     savePrettifiedQuery cfg reducedFi   if noEnvironmentReduction cfg then@@ -240,7 +262,7 @@  solveNative' !cfg !fi0 = do   si6 <- simplifyFInfo cfg fi0-  res <- {- SCC "Sol.solve" #-} Sol.solve cfg $!! si6+  res <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6   -- rnf soln `seq` donePhase Loud "Solve2"   --let stat = resStatus res   -- saveSolution cfg res@@ -260,9 +282,9 @@ parseFI f = do   str   <- readFile f   let fi = rr' f str :: FInfo ()-  return $ mempty { quals = quals  fi-                  , gLits = gLits  fi-                  , dLits = dLits  fi }+  return $ mempty { Types.quals = Types.quals  fi+                  , Types.gLits = Types.gLits  fi+                  , Types.dLits = Types.dLits  fi }  saveSolution :: Config -> Result a -> IO () saveSolution cfg res = when (save cfg) $ do

+ src/Language/Fixpoint/Solver/Common.hs view

@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Language.Fixpoint.Solver.Common (askSMT, toSMT) where++import Language.Fixpoint.Types.Config (Config)+import Language.Fixpoint.Smt.Interface (Context(..), checkValidWithContext)+import Language.Fixpoint.Types+import Language.Fixpoint.Types.Visitor (kvarsExpr)+import Language.Fixpoint.Defunctionalize (defuncAny)+import Language.Fixpoint.SortCheck (elaborate)++mytracepp :: (PPrint a) => String -> a -> a+mytracepp = notracepp++askSMT :: Config -> Context -> [(Symbol, Sort)] -> Expr -> IO Bool+askSMT cfg ctx bs e+--   | isContraPred e  = return False+  | isTautoPred  e     = return True+  | null (kvarsExpr e) = checkValidWithContext ctx [] PTrue e'+  | otherwise          = return False+  where+    e' = toSMT "askSMT" cfg ctx bs e++toSMT :: String -> Config -> Context -> [(Symbol, Sort)] -> Expr -> Pred+toSMT msg cfg ctx bs e =+    defuncAny cfg senv .+        elaborate (dummyLoc msg) (elabEnv bs) .+            mytracepp ("toSMT from " ++ msg ++ showpp e) $+                e+  where+    elabEnv = insertsSymEnv senv+    senv    = ctxSymEnv ctx

src/Language/Fixpoint/Solver/Eliminate.hs view

@@ -29,13 +29,14 @@   where     cD             = elimDeps     sI es nKs ebs     sI'            = cutSInfo     sI kI cKs-    sHyp           = Sol.fromList sE mempty mempty kHyps kS [] $ fromListSEnv [ (x, (i, sr_sort sr)) | (i,x,sr) <- bindEnvToList (bs sI)]+    sHyp           = Sol.fromList sE mempty mempty kHyps kS [] sEnv+    sEnv           = fromListSEnv [ (x, (i, sr_sort sr)) | (i, (x,sr, _)) <- bindEnvToList (bs sI)]     kHyps          = nonCutHyps   sI kI nKs     kI             = kIndex       sI     (es, cKs, nKs) = kutVars cfg  sI     kS             = kvScopes     sI es     sE             = symbolEnv   cfg sI-    ebs            = S.fromList $ fst <$> flip lookupBindEnv (bs sI) <$> (ebinds sI)+    ebs            = S.fromList [x | i <- ebinds sI, let (x, _, _) = lookupBindEnv i (bs sI) ]   --------------------------------------------------------------------------------

src/Language/Fixpoint/Solver/EnvironmentReduction.hs view

@@ -1,19 +1,27 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | Functions to make environments smaller module Language.Fixpoint.Solver.EnvironmentReduction   ( reduceEnvironments   , simplifyBindings   , dropLikelyIrrelevantBindings+  , inlineInExpr   , inlineInSortedReft   , mergeDuplicatedBindings   , simplifyBooleanRefts   , undoANF+  , undoANFAndVV++  -- for use in tests+  , undoANFSimplifyingWith   ) where  import           Control.Monad (guard, mplus, msum)@@ -29,7 +37,7 @@ import           Data.ShareMap (ShareMap) import qualified Data.ShareMap as ShareMap import qualified Data.Text as Text-import           Language.Fixpoint.SortCheck (exprSort_maybe)+import           Language.Fixpoint.SortCheck (exprSortMaybe) import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.Constraints import           Language.Fixpoint.Types.Environments@@ -55,6 +63,7 @@   , isPrefixOfSym   , prefixOfSym   , symbolText+  , vvName   ) import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Refinements@@ -65,6 +74,7 @@   , Subst(..)   , pattern PTrue   , pattern PFalse+  , dropECst   , expr   , exprKVars   , exprSymbolsSet@@ -78,6 +88,9 @@   ) import           Language.Fixpoint.Types.Sorts (boolSort, sortSymbols) import           Language.Fixpoint.Types.Visitor (mapExprOnExpr)+import           Lens.Family2 (Lens', view, (%~))+import           Lens.Family2.Stock (_2)+import Language.Fixpoint.Misc (snd3)  -- | Strips from all the constraint environments the bindings that are -- irrelevant for their respective constraints.@@ -140,10 +153,10 @@    where     dropBindsMissingFrom-      :: HashMap BindId (Symbol, SortedReft)+      :: HashMap BindId (Symbol, SortedReft, a)       -> [(SubcId, SubC a)]       -> HashMap KVar (WfC a)-      -> HashMap BindId (Symbol, SortedReft)+      -> HashMap BindId (Symbol, SortedReft, a)     dropBindsMissingFrom be cs ws =       let ibindEnv = unionsIBindEnv $             map (senv . snd) cs ++@@ -168,7 +181,7 @@ -- 'relatedKVarBinds' or any substitution on the corresponding KVar anywhere. -- reduceWFConstraintEnvironments-  :: BindEnv    -- ^ Environment before reduction+  :: BindEnv a    -- ^ Environment before reduction   -> ([ReducedConstraint a], HashMap KVar (WfC a))      -- ^ @(cs, ws)@:      --  * @cs@ are the constraints with reduced environments@@ -183,8 +196,7 @@         HashMap.map (sortSymbols . (\(_, b, _) -> b) . wrft) wfs        kvarsRelevantBinds =-        HashMap.unionWith HashSet.union wfBindsPlusSortSymbols $-        kvarSubstSymbols+        HashMap.unionWith HashSet.union wfBindsPlusSortSymbols kvarSubstSymbols        ws' =         HashMap.mapWithKey@@ -209,7 +221,7 @@     -- additional bindings that are required by the kvar. These are added     -- in this function.     updateSubcEnvsWithKVarBinds-      :: BindEnv+      :: BindEnv a       -> HashMap KVar (HashSet Symbol)       -> [KVar]       -> ReducedConstraint a@@ -221,7 +233,7 @@             else fromListIBindEnv               [ bId               | bId <- elemsIBindEnv oldEnv-              , let (s, _sr) = lookupBindEnv bId be+              , let (s, _sr, _) = lookupBindEnv bId be               , any (neededByKVar s) kvs               ]           neededByKVar s kv =@@ -233,7 +245,7 @@     -- @reduceWFConstraintEnvironment be kbinds k c@ drops bindings from @c@     -- that aren't present in @kbinds ! k@.     reduceWFConstraintEnvironment-      :: BindEnv+      :: BindEnv a       -> HashMap KVar (HashSet Symbol)       -> KVar       -> WfC a@@ -246,7 +258,7 @@       where         relevantBindIds :: HashSet Symbol -> BindId -> Bool         relevantBindIds kbindSymbols bId =-          let (s, _) = lookupBindEnv bId bindEnv+          let (s, _, _) = lookupBindEnv bId bindEnv            in HashSet.member s kbindSymbols  data ReducedConstraint a = ReducedConstraint@@ -256,18 +268,18 @@   }  reduceConstraintEnvironment-  :: BindEnv+  :: BindEnv a   -> HashMap Symbol (HashSet Symbol)   -> (SubcId, SubC a)   -> ReducedConstraint a reduceConstraintEnvironment bindEnv aenvMap (cid, c) =-  let env = [ (s, bId, sr)+  let env = [ (s, bId, sr, a)             | bId <- elemsIBindEnv $ senv c-            , let (s, sr) = lookupBindEnv bId bindEnv+            , let (s, sr, a) = lookupBindEnv bId bindEnv             ]       prunedEnv =         fromListIBindEnv-        [ bId | (_, bId, _) <- dropIrrelevantBindings aenvMap constraintSymbols env ]+        [ bId | (_, bId, _,_) <- dropIrrelevantBindings aenvMap constraintSymbols env ]       constraintSymbols =         HashSet.union (sortedReftSymbols $ slhs c) (sortedReftSymbols $ srhs c)    in ReducedConstraint@@ -288,17 +300,17 @@ dropIrrelevantBindings   :: HashMap Symbol (HashSet Symbol)   -> HashSet Symbol-  -> [(Symbol, BindId, SortedReft)]-  -> [(Symbol, BindId, SortedReft)]+  -> [(Symbol, BindId, SortedReft, a)]+  -> [(Symbol, BindId, SortedReft, a)] dropIrrelevantBindings aenvMap extraSymbols env =   filter relevantBind env   where     allSymbols =       reachableSymbols (HashSet.union extraSymbols envSymbols) aenvMap     envSymbols =-      HashSet.unions $ map (\(_, _, sr) -> sortedReftSymbols sr) env+      HashSet.unions $ map (\(_, _, sr,_) -> sortedReftSymbols sr) env -    relevantBind (s, _, sr)+    relevantBind (s, _, sr, _)       | HashSet.member s allSymbols = True       | otherwise = case reftPred (sr_reft sr) of           PTrue -> False@@ -365,7 +377,7 @@ -- be needed by the other. -- relatedKVarBinds-  :: BindEnv+  :: BindEnv a   -> [ReducedConstraint a]   -> (HashMap KVar (HashSet Symbol), HashMap KVar (HashSet Symbol), [[KVar]]) relatedKVarBinds bindEnv cs =@@ -382,7 +394,7 @@   where     kvarsByBindId :: HashMap BindId (HashMap KVar [Subst])     kvarsByBindId =-      HashMap.map (exprKVars . reftPred . sr_reft . snd) $ beBinds bindEnv+      HashMap.map (exprKVars . reftPred . sr_reft . snd3) $ beBinds bindEnv      -- Returns all of the KVars used in the constraint, together with     -- the symbols that appear in substitutions of those KVars.@@ -418,12 +430,12 @@         let sm' = ShareMap.insertWith unionIBindEnv k bindIds sm          in foldr (ShareMap.mergeKeysWith unionIBindEnv k) sm' ks -asSymbolSet :: BindEnv -> IBindEnv -> HashSet Symbol+asSymbolSet :: BindEnv a -> IBindEnv -> HashSet Symbol asSymbolSet be ibinds =   HashSet.fromList     [ s     | bId <- elemsIBindEnv ibinds-    , let (s, _) = lookupBindEnv bId be+    , let (s, _,_) = lookupBindEnv bId be     ]  -- | @reachableSymbols x r@ computes the set of symbols reachable from @x@@@ -446,7 +458,7 @@ -- It runs 'mergeDuplicatedBindings' and 'simplifyBooleanRefts' -- on the environment of each constraint. ----- If 'inlineANFBindings cfg' is on, also runs 'undoANF' to inline+-- If 'inlineANFBindings cfg' is on, also runs 'undoANFAndVV' to inline -- @lq_anf@ bindings. simplifyBindings :: Config -> FInfo a -> FInfo a simplifyBindings cfg fi =@@ -474,39 +486,39 @@         ]      simplifyConstraints-      :: BindEnv+      :: BindEnv a       -> HashMap SubcId (SubC a)-      -> (BindEnv, HashMap SubcId (SubC a), HashMap BindId [BindId])+      -> (BindEnv a, HashMap SubcId (SubC a), HashMap BindId [BindId])     simplifyConstraints be cs =       let (be', cs', newToOld) =              HashMap.foldlWithKey' simplifyConstraintBindings (be, [], []) cs           oldToNew =             HashMap.fromListWith (++) $-            concatMap (\(n, olds) -> map (\o -> (o, [n])) olds) newToOld+            concatMap (\(n, olds) -> map (, [n]) olds) newToOld        in           (be', HashMap.fromList cs', oldToNew)      simplifyConstraintBindings-      :: (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])])+      :: (BindEnv a, [(SubcId, SubC a)], [(BindId, [BindId])])       -> SubcId       -> SubC a-      -> (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])])+      -> (BindEnv a, [(SubcId, SubC a)], [(BindId, [BindId])])     simplifyConstraintBindings (bindEnv, cs, newToOld) cid c =       let env =-            [ (s, ([bId], sr))+            [ (s, ([(bId, a)], sr))             | bId <- elemsIBindEnv $ senv c-            , let (s, sr) = lookupBindEnv bId bindEnv+            , let (s, sr, a) = lookupBindEnv bId bindEnv             ]            mergedEnv = mergeDuplicatedBindings env           undoANFEnv =-            if inlineANFBindings cfg then undoANF mergedEnv else HashMap.empty+            if inlineANFBindings cfg then undoANFOnlyModified mergedEnv else HashMap.empty           boolSimplEnv =             simplifyBooleanRefts $ HashMap.union undoANFEnv mergedEnv            modifiedBinds = HashMap.toList $ HashMap.union boolSimplEnv undoANFEnv -          modifiedBindIds = map (fst . snd) modifiedBinds+          modifiedBindIds = [ fst <$> bs | (_, (bs,_)) <- modifiedBinds ]            unchangedBindIds = senv c `diffIBindEnv` fromListIBindEnv (concat modifiedBindIds) @@ -518,9 +530,9 @@        in           (bindEnv', (cid, updateSEnv c (const newIBindEnv)) : cs, newToOld') -    insertBinds = foldl' $ \(xs, be) (s, (_, sr)) ->-      let (bId, be') = insertBindEnv s sr be-       in (bId : xs, be')+    insertBinds = foldl' $ \(xs, be) (s, (bIdAs, sr)) ->+      let (bId, be') = insertBindEnv s sr (snd . head $ bIdAs) be+      in (bId : xs, be')  -- | If the environment contains duplicated bindings, they are -- combined with conjunctions.@@ -559,45 +571,75 @@           ]         ) --- | Inlines some of the bindings introduced by ANF normalization--- at their use sites.+-- | Inlines some of the bindings whose symbol satisfies a given predicate. ----- Only modified bindings are returned.+-- Only works if the bindings don't form cycles.+substBindingsSimplifyingWith+  :: (SortedReft -> SortedReft)+  -> Lens' v SortedReft+  -> (Symbol -> Bool)+  -> HashMap Symbol v+  -> HashMap Symbol v+substBindingsSimplifyingWith simplifier vLens p env =+    -- Circular program here. This should terminate as long as the+    -- bindings introduced by ANF don't form cycles.+    let env' = HashMap.map (vLens %~ simplifier . inlineInSortedReft (srLookup filteredEnv)) env+        filteredEnv = HashMap.filterWithKey (\sym _v -> p sym) env'+     in env'+  where+    srLookup env' sym = view vLens <$> HashMap.lookup sym env'++substBindings+  :: Lens' v SortedReft+  -> (Symbol -> Bool)+  -> HashMap Symbol v+  -> HashMap Symbol v+substBindings = substBindingsSimplifyingWith simplify++-- | Like 'substBindings' but specialized for ANF bindings. ----- Only bindings with prefix lq_anf... might be inlined.+-- Only bindings with prefix lq_anf$... might be inlined. --+undoANFSimplifyingWith :: (SortedReft -> SortedReft) -> Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v+undoANFSimplifyingWith simplifier vLens = substBindingsSimplifyingWith simplifier vLens $ \sym -> anfPrefix `isPrefixOfSym` sym++undoANF :: Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v+undoANF = undoANFSimplifyingWith simplify++-- | Like 'undoANF' but also inlines VV bindings+-- -- This function is used to produced the prettified output, and the user -- can request to use it in the verification pipeline with -- @--inline-anf-bindings@. However, using it in the verification -- pipeline causes some tests in liquidhaskell to blow up.-undoANF :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)-undoANF env =-    -- Circular program here. This should terminate as long as the-    -- bindings introduced by ANF don't form cycles.-    let env' = HashMap.map (inlineInSortedReftChanged env') env-     in HashMap.mapMaybe dropUnchanged env'-  where-    dropUnchanged ((m, b), sr) = do-      guard b-      Just (m, sr)+--+-- Note: This function simplifies.+undoANFAndVV :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)+undoANFAndVV = substBindings _2 $ \sym -> anfPrefix `isPrefixOfSym` sym || vvName `isPrefixOfSym` sym -inlineInSortedReft-  :: HashMap Symbol (m, SortedReft) -> SortedReft -> SortedReft-inlineInSortedReft env sr =-  snd $ inlineInSortedReftChanged env (error "never should evaluate", sr)+-- | Like 'undoANF' but returns only modified bindings and **DOES NOT SIMPLIFY**.+undoANFOnlyModified :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)+undoANFOnlyModified env =+    let undoANFEnv = undoANFSimplifyingWith id _2 env+     in HashMap.differenceWith dropUnchanged env undoANFEnv+  where+    dropUnchanged (_, a) v@(_, b) | a == b = Just v+      | otherwise = Nothing  -- | Inlines bindings in env in the given 'SortedReft'.--- Attaches a 'Bool' telling if the 'SortedReft' was changed.-inlineInSortedReftChanged-  :: HashMap Symbol (a, SortedReft)-  -> (m, SortedReft)-  -> ((m, Bool), SortedReft)-inlineInSortedReftChanged env (m, sr) =-  let e = reftPred (sr_reft sr)-      e' = inlineInExpr env e-   in ((m, e /= e'), sr { sr_reft = mapPredReft (const e') (sr_reft sr) })+inlineInSortedReft+  :: (Symbol -> Maybe SortedReft)+  -> SortedReft+  -> SortedReft+inlineInSortedReft srLookup sr =+    let reft = sr_reft sr+     in sr { sr_reft = mapPredReft (inlineInExpr (filterBind (reftBind reft) srLookup)) reft }+  where+    filterBind b srLookup sym = do+      guard (sym /= b)+      srLookup sym --- | Inlines bindings preffixed with @lq_anf@ in the given expression+-- | Inlines bindings given by @srLookup@ in the given expression -- if they appear in equalities. -- -- Given a binding like @a : { v | v = e1 && e2 }@ and an expression @... e0 = a ...@,@@ -610,23 +652,17 @@ -- Given a binding like @a : { v | v = e1 }@ and an expression @... a ...@, -- this function produces the expression @... e1 ...@ if @v@ does not -- appear free in @e1@.------ The first parameter indicates the maximum amount of conjuncts that a--- binding is allowed to have. If the binding exceeds this threshold, it--- is not inlined.-inlineInExpr :: HashMap Symbol (m, SortedReft) -> Expr -> Expr-inlineInExpr env = simplify . mapExprOnExpr inlineExpr+inlineInExpr :: (Symbol -> Maybe SortedReft) -> Expr -> Expr+inlineInExpr srLookup = mapExprOnExpr inlineExpr   where     inlineExpr (EVar sym)-      | anfPrefix `isPrefixOfSym` sym-      , Just (_, sr) <- HashMap.lookup sym env+      | Just sr <- srLookup sym       , let r = sr_reft sr       , Just e <- isSingletonE (reftBind r) (reftPred r)       = wrapWithCoercion Eq (sr_sort sr) e     inlineExpr (PAtom br e0 e1@(dropECst -> EVar sym))-      | anfPrefix `isPrefixOfSym` sym-      , isEq br-      , Just (_, sr) <- HashMap.lookup sym env+      | isEq br+      , Just sr <- srLookup sym       , let r = sr_reft sr       , Just e <- isSingletonE (reftBind r) (reftPred r)       =@@ -648,14 +684,9 @@      isEq r = r == Eq || r == Ueq -    wrapWithCoercion br to e = case exprSort_maybe e of+    wrapWithCoercion br to e = case exprSortMaybe e of       Just from -> if from /= to then ECoerc from to e else e       Nothing -> if br == Ueq then ECst e to else e--dropECst :: Expr -> Expr-dropECst = \case-  ECst e _t -> dropECst e-  e -> e  -- | Transforms bindings of the form @{v:bool | v && P v}@ into -- @{v:Bool | v && P true}@, and bindings of the form @{v:bool | ~v && P v}@

src/Language/Fixpoint/Solver/Extensionality.hs view

@@ -1,116 +1,121 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE PatternGuards        #-} {-# LANGUAGE FlexibleContexts     #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ module Language.Fixpoint.Solver.Extensionality (expand) where  import           Control.Monad.State import qualified Data.HashMap.Strict       as M import           Data.Maybe  (fromMaybe)+import           Data.List (foldl')  import           Language.Fixpoint.Types.Config import           Language.Fixpoint.SortCheck import           Language.Fixpoint.Solver.Sanitize (symbolEnv) import           Language.Fixpoint.Types hiding (mapSort, Pos)-import           Language.Fixpoint.Types.Visitor ( (<$$>), mapSort )+import           Language.Fixpoint.Types.Visitor (mapSort)  mytracepp :: (PPrint a) => String -> a -> a-mytracepp = notracepp +mytracepp = notracepp  expand :: Config -> SInfo a -> SInfo a-expand cfg si = evalState (extend si) $ initST (symbolEnv cfg si) (ddecls si)+expand cfg si = evalState (ext si) $ initST (symbolEnv cfg si) (ddecls si)+  where+    ext ::SInfo a -> Ex a (SInfo a)+    ext = extend  -class Extend a where-  extend :: a -> Ex a+class Extend ann a where+  extend :: a -> Ex ann a  -instance Extend (SInfo a) where-  extend si = do +instance Extend a (SInfo a) where+  extend si = do     setBEnv (bs si)-    cm'      <- extend (cm si) -    bs'      <- exbenv <$> get  +    cm'      <- extend (cm si)+    bs'      <- gets exbenv     return $ si{ cm = cm' , bs = bs' } -instance (Extend a) => Extend (M.HashMap SubcId a) where -  extend h = M.fromList <$> mapM extend (M.toList h) +instance (Extend ann a) => Extend ann (M.HashMap SubcId a) where+  extend h = M.fromList <$> mapM extend (M.toList h) -instance (Extend a, Extend b) => Extend (a,b) where -  extend (a,b) = (,) <$> extend a <*> extend b +instance (Extend ann a, Extend ann b) => Extend ann (a,b) where+  extend (a,b) = (,) <$> extend a <*> extend b -instance Extend SubcId where-  extend i = return i +instance Extend ann SubcId where+  extend i = return i -instance Extend (SimpC a) where-  extend c = do +instance Extend a (SimpC a) where+  extend c = do     setExBinds (_cenv c)-    rhs <- extendExpr Pos (_crhs c)-    is  <- exbinds <$> get +    rhs <- extendExpr (sinfo c) Pos (_crhs c)+    is  <- gets exbinds     return $ c{_crhs = rhs, _cenv = is }  -extendExpr :: Pos -> Expr -> Ex Expr -extendExpr p e -  | p == Pos -  = mapMPosExpr Pos goP e' >>= mapMPosExpr Pos goN +extendExpr :: a -> Pos -> Expr -> Ex a Expr+extendExpr ann p e+  | p == Pos+  = mapMPosExpr Pos goP e' >>= mapMPosExpr Pos goN   | otherwise-  = mapMPosExpr Neg goP e' >>= mapMPosExpr Neg goN -    where  +  = mapMPosExpr Neg goP e' >>= mapMPosExpr Neg goN+    where       e' = normalize e       goP Pos (PAtom b e1 e2)-       | b == Eq || b == Ne  +       | b == Eq || b == Ne        , Just s <- getArg (exprSort "extensionality" e1)-       = mytracepp ("extending POS = " ++ showpp e) <$> (extendRHS b e1 e2 s >>= goP Pos) -      goP _ e = return e +       = mytracepp ("extending POS = " ++ showpp e) <$> (extendRHS ann b e1 e2 s >>= goP Pos)+      goP _ e = return e       goN Neg (PAtom b e1 e2)        | b == Eq || b == Ne        , Just s <- getArg (exprSort "extensionality" e1)-       = mytracepp ("extending NEG = " ++ showpp e) <$> (extendLHS b e1 e2 s >>= goN Neg) -      goN _ e = return e --getArg :: Sort -> Maybe Sort -getArg s = case bkFFunc s of -             Just (_,(a:_:_)) -> Just a -             _                -> Nothing +       = mytracepp ("extending NEG = " ++ showpp e) <$> (extendLHS ann b e1 e2 s >>= goN Neg)+      goN _ e = return e -extendRHS, extendLHS :: Brel -> Expr -> Expr -> Sort -> Ex Expr-extendRHS b e1 e2 s = -  do es <- generateArguments s -     (mytracepp "extendRHS = " . pAnd) <$> mapM (makeEq b e1 e2) es+getArg :: Sort -> Maybe Sort+getArg s = case bkFFunc s of+             Just (_, a:_:_) -> Just a+             _                -> Nothing -extendLHS b e1 e2 s = -  do es  <- generateArguments s -     dds <- exddecl <$> get -     is  <- instantiate dds s -     (mytracepp "extendLHS = " . pAnd . (PAtom b e1 e2:)) <$> mapM (makeEq b e1 e2) (es ++ is)+extendRHS, extendLHS :: a -> Brel -> Expr -> Expr -> Sort -> Ex a Expr+extendRHS ann b e1 e2 s =+  do es <- generateArguments ann s+     mytracepp "extendRHS = " . pAnd <$> mapM (makeEq b e1 e2) es +extendLHS ann b e1 e2 s =+  do es  <- generateArguments ann s+     dds <- gets exddecl+     is  <- instantiate ann dds s+     mytracepp "extendLHS = " . pAnd . (PAtom b e1 e2:) <$> mapM (makeEq b e1 e2) (es ++ is) -generateArguments :: Sort -> Ex [Expr]-generateArguments s = do -  st   <- get -  case breakSort (exddecl st) s of -    Left dds -> mapM freshArgDD dds  -    Right s  -> (\x -> [EVar x]) <$> freshArgOne s +generateArguments :: a -> Sort -> Ex a [Expr]+generateArguments ann s = do+  ddecls   <- gets exddecl+  case breakSort ddecls s of+    Left dds -> mapM (freshArgDD ann) dds+    Right s  -> (\x -> [EVar x]) <$> freshArgOne ann s -makeEq :: Brel-> Expr -> Expr -> Expr -> Ex Expr -makeEq b e1 e2 e = do -  env <- exenv <$> get +makeEq :: Brel-> Expr -> Expr -> Expr -> Ex ann Expr+makeEq b e1 e2 e = do+  env <- gets exenv   let elab = elaborate (dummyLoc "extensionality") env   return $ PAtom b (elab $ EApp (unElab e1) e)  (elab $ EApp (unElab e2) e) -instantiate :: [DataDecl]  -> Sort -> Ex [Expr]-instantiate ds s = instantiateOne (breakSort ds s)  +instantiate :: a -> [DataDecl]  -> Sort -> Ex a [Expr]+instantiate ann ds s = instantiateOne ann (breakSort ds s) -instantiateOne :: Either [(LocSymbol, [Sort])] Sort  -> Ex [Expr]-instantiateOne (Right s@(FVar _)) = -  (\x -> [EVar x]) <$> freshArgOne s-instantiateOne (Right s) = do -  xss <- excbs <$> get -  return [EVar x | (x,xs) <- xss, xs == s ] -instantiateOne (Left [(dc, ts)]) = -  (map (mkEApp dc) . combine) <$>  mapM instantiateOne (Right <$> ts) -instantiateOne _ = undefined +instantiateOne :: a -> Either [(LocSymbol, [Sort])] Sort  -> Ex a [Expr]+instantiateOne ann (Right s@(FVar _)) =+  (\x -> [EVar x]) <$> freshArgOne ann s+instantiateOne _ (Right s) = do+  xss <- gets excbs+  return [EVar x | (x,xs) <- xss, xs == s ]+instantiateOne ann (Left [(dc, ts)]) =+  map (mkEApp dc) . combine <$>  mapM (instantiateOne ann) (Right <$> ts)+instantiateOne _ _ = undefined  combine :: [[a]] -> [[a]] combine []          = [[]]@@ -118,45 +123,45 @@ combine ((x:xs):ys) = map (x:) (combine ys) ++ combine (xs:ys)  -data Pos = Pos | Neg deriving Eq -negatePos :: Pos -> Pos -negatePos Pos = Neg -negatePos Neg = Pos +data Pos = Pos | Neg deriving Eq+negatePos :: Pos -> Pos+negatePos Pos = Neg+negatePos Neg = Pos  mapMPosExpr :: (Monad m) => Pos -> (Pos -> Expr -> m Expr) -> Expr -> m Expr-mapMPosExpr p f = go p +mapMPosExpr p f = go p   where     go p e@(ESym _)      = f p e     go p e@(ECon _)      = f p e     go p e@(EVar _)      = f p e     go p e@(PKVar _ _)   = f p e-    go p (ENeg e)        = f p =<< (ENeg        <$>  go p e                     )-    go p (ECst e t)      = f p =<< ((`ECst` t)  <$>  go p e                     )-    go p (ECoerc a t e)  = f p =<< (ECoerc a t  <$>  go p e                     )+    go p (ENeg e)        = f p . ENeg =<< go p e+    go p (ECst e t)      = f p . (`ECst` t) =<< go p e+    go p (ECoerc a t e)  = f p . ECoerc a t =<< go p e     go p (EApp g e)      = f p =<< (EApp        <$>  go p g  <*> go p e             )     go p (EBin o e1 e2)  = f p =<< (EBin o      <$>  go p e1 <*> go p e2            )     go p (PAtom r e1 e2) = f p =<< (PAtom r     <$>  go p e1 <*> go p e2            )      go p (PImp p1 p2)    = f p =<< (PImp        <$>  go (negatePos p) p1 <*> go p p2)-    go p (PAnd ps)       = f p =<< (PAnd        <$> (go p <$$> ps)                  )+    go p (PAnd ps)       = f p . PAnd =<< (go p `traverse` ps)      -- The below cannot appear due to normalization-    go p (PNot e)        = f p =<< (PNot        <$>  go p e                     )+    go p (PNot e)        = f p . PNot =<< go p e     go p (PIff p1 p2)    = f p =<< (PIff        <$>  go p p1 <*> go p p2            )     go p (EIte e e1 e2)  = f p =<< (EIte        <$>  go p e  <*> go p e1 <*> go p e2)-    go p (POr  ps)       = f p =<< (POr         <$> (go p <$$> ps)                  )+    go p (POr  ps)       = f p . POr =<< (go p `traverse` ps) -    -- The following canot appear in general -    go p (PAll xts e)    = f p =<< (PAll   xts  <$>  go p e                     )-    go p (ELam (x,t) e)  = f p =<< (ELam (x,t)  <$>  go p e                     )-    go p (PExist xts e)  = f p =<< (PExist xts  <$>  go p e                     )-    go p (ETApp e s)     = f p =<< ((`ETApp` s) <$>  go p e                     )-    go p (ETAbs e s)     = f p =<< ((`ETAbs` s) <$>  go p e                     )-    go p (PGrad k s i e) = f p =<< (PGrad k s i <$>  go p e                     )+    -- The following canot appear in general+    go p (PAll xts e)    = f p . PAll   xts =<< go p e+    go p (ELam (x,t) e)  = f p . ELam (x,t) =<< go p e+    go p (PExist xts e)  = f p . PExist xts =<< go p e+    go p (ETApp e s)     = f p . (`ETApp` s) =<< go p e+    go p (ETAbs e s)     = f p . (`ETAbs` s) =<< go p e+    go p (PGrad k s i e) = f p . PGrad k s i =<< go p e -normalize :: Expr -> Expr -normalize e = mytracepp ("normalize: " ++ showpp e) $ go e  -  where +normalize :: Expr -> Expr+normalize e = mytracepp ("normalize: " ++ showpp e) $ go e+  where     go e@(ESym _)        = e     go e@(ECon _)        = e     go e@(EVar _)        = e@@ -164,35 +169,36 @@     go e@(ENeg _)        = e     go (PNot e)          = PImp e PFalse     go e@(ECst _ _)      = e-    go e@(ECoerc _ _ _)  = e-    go e@(EApp _ _)      = e -    go e@(EBin _ _ _)    = e +    go e@ECoerc{}        = e+    go e@(EApp _ _)      = e+    go e@EBin{}          = e     go (PImp p1 p2)      = PImp (go p1) (go p2)     go (PIff p1 p2)      = PAnd [PImp p1' p2', PImp p2' p1'] where (p1', p2') = (go p1, go p2)-    go e@(PAtom _ _ _)   = e +    go e@PAtom{}         = e     go (EIte e e1 e2)    = go $ PAnd [PImp e e1, PImp (PNot e) e2]     go (PAnd ps)         = pAnd (go <$> ps)-    go (POr  ps)         = foldl (\x y -> PImp (PImp (go x) PFalse) y) PFalse ps +    go (POr  ps)         = foldl' (\x y -> PImp (PImp (go x) PFalse) y) PFalse ps     go e@(PAll _ _)      = e -- Cannot appear     go e@(ELam _ _)      = e -- Cannot appear     go e@(PExist _ _)    = e -- Cannot appear     go e@(ETApp _ _)     = e -- Cannot appear     go e@(ETAbs _ _)     = e -- Cannot appear-    go e@(PGrad _ _ _ _) = e -- Cannot appear+    go e@PGrad{}         = e -- Cannot appear -    -type Ex    = State ExSt-data ExSt = ExSt { unique  :: Int-                 , exddecl :: [DataDecl]-                 , exenv   :: SymEnv        -- used for elaboration -                 , exbenv  :: BindEnv-                 , exbinds :: IBindEnv-                 , excbs   :: [(Symbol, Sort)] -                 } -initST :: SymEnv -> [DataDecl]  -> ExSt+type Ex a = State (ExSt a)+data ExSt a = ExSt+  { unique  :: Int+  , exddecl :: [DataDecl]+  , exenv   :: SymEnv        -- used for elaboration+  , exbenv  :: BindEnv a+  , exbinds :: IBindEnv+  , excbs   :: [(Symbol, Sort)]+  }++initST :: SymEnv -> [DataDecl]  -> ExSt ann initST env dd = ExSt 0 (d:dd) env mempty mempty mempty-  where +  where     -- NV: hardcore Haskell pairs because they do not appear in DataDecl (why?)     d = mytracepp "Tuple DataDecl" $ DDecl (symbolFTycon (dummyLoc tupConName)) 2 [ct]     ct = DCtor (dummyLoc (symbol "GHC.Tuple.(,)")) [@@ -201,58 +207,58 @@           ]  -setBEnv :: BindEnv -> Ex () +setBEnv :: BindEnv a -> Ex a () setBEnv benv = modify (\st -> st{exbenv = benv}) -setExBinds :: IBindEnv-> Ex ()+setExBinds :: IBindEnv -> Ex a () setExBinds bids = modify (\st -> st{ exbinds = bids-                                   , excbs   = [ (x, sr_sort r) | (i, x, r) <- bindEnvToList (exbenv st)+                                   , excbs   = [ (x, sr_sort r) | (i, (x, r, _)) <- bindEnvToList (exbenv st)                                                                 , memberIBindEnv i bids]})  -freshArgDD :: (LocSymbol, [Sort]) -> Ex Expr -freshArgDD (dc, xs) = do  -  xs <- mapM freshArgOne xs+freshArgDD :: a -> (LocSymbol, [Sort]) -> Ex a Expr+freshArgDD ann (dc, xs) = do+  xs <- mapM (freshArgOne ann) xs   return $ mkEApp dc (EVar <$> xs)  -freshArgOne :: Sort -> Ex Symbol -freshArgOne s = do -  st   <- get +freshArgOne :: ann -> Sort -> Ex ann Symbol+freshArgOne ann s = do+  st   <- get   let x = symbol ("ext$" ++ show (unique st))-  let (id, benv') = insertBindEnv x (trueSortedReft s) (exbenv st)+  let (id, benv') = insertBindEnv x (trueSortedReft s) ann (exbenv st)   modify (\st -> st{ exenv   = insertSymEnv x s (exenv st)                    , exbenv  = benv'                    , exbinds = insertsIBindEnv [id] (exbinds st)-                   , unique   = 1 + (unique st) -                   , excbs = (x,s):(excbs st)+                   , unique   = 1 + unique st+                   , excbs = (x,s) : excbs st                    })-  return x +  return x  -breakSort :: [DataDecl] -> Sort -> Either [(LocSymbol, [Sort])] Sort +breakSort :: [DataDecl] -> Sort -> Either [(LocSymbol, [Sort])] Sort breakSort ddecls s     | Just (tc, ts) <- splitTC s-    , [(dds,i)] <- [ (ddCtors dd,ddVars dd) | dd <- ddecls, ddTyCon dd == tc ] -    = Left ((\dd -> (dcName dd, (instSort  (Sub $ zip [0..(i-1)] ts)) <$> dfSort <$> dcFields dd)) <$> dds)-    | otherwise +    , [(dds,i)] <- [ (ddCtors dd,ddVars dd) | dd <- ddecls, ddTyCon dd == tc ]+    = Left ((\dd -> (dcName dd, instSort  (Sub $ zip [0..(i-1)] ts) . dfSort <$> dcFields dd)) <$> dds)+    | otherwise     = Right s -instSort :: Sub -> Sort -> Sort -instSort (Sub su) x = mapSort go x -  where -    go :: Sort -> Sort -    go (FVar i) = fromMaybe (FVar i) $ lookup i su  -    go s        = s -  +instSort :: Sub -> Sort -> Sort+instSort (Sub su) x = mapSort go x+  where+    go :: Sort -> Sort+    go (FVar i) = fromMaybe (FVar i) $ lookup i su+    go s        = s+ splitTC :: Sort -> Maybe (FTycon, [Sort])-splitTC s -     | (FTC f, ts) <- splitFApp s +splitTC s+     | (FTC f, ts) <- splitFApp s      = Just (f, ts)      | otherwise-     = Nothing +     = Nothing  splitFApp :: Sort -> (Sort, [Sort])-splitFApp = go [] -    where go acc (FApp s1 s2) = go (s2:acc) s1 +splitFApp = go []+    where go acc (FApp s1 s2) = go (s2:acc) s1           go acc s            = (s, acc)

src/Language/Fixpoint/Solver/GradualSolution.hs view

@@ -1,7 +1,8 @@ {-# LANGUAGE CPP                #-} {-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE TupleSections      #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Solver.GradualSolution   ( -- * Create Initial Solution     init@@ -11,9 +12,6 @@ import qualified Data.HashMap.Strict            as M import qualified Data.List                      as L import           Data.Maybe                     (maybeToList, isNothing)-#if !MIN_VERSION_base(4,14,0)-import           Data.Monoid                    ((<>))-#endif import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.PrettyPrint () import qualified Language.Fixpoint.SortCheck          as So@@ -30,7 +28,7 @@ -------------------------------------------------------------------------------- init :: (F.Fixpoint a) => Config -> F.SInfo a -> [(F.KVar, (F.GWInfo, [F.Expr]))] ---------------------------------------------------------------------------------init cfg si = map (elab . refineG si qs genv) gs `using` parList rdeepseq +init cfg si = map (elab . refineG si qs genv) gs `using` parList rdeepseq   where     qs         = F.quals si     gs         = snd <$> gs0@@ -38,8 +36,8 @@      gs0        = L.filter (isGWfc . snd) $ M.toList (F.ws si) -    elab (k,(x,es)) = ((k,) . (x,)) $ (elaborate (F.atLoc F.dummySpan "init") (sEnv (gsym x) (gsort x)) <$> es)-    +    elab (k, (x,es)) = (k, (x, elaborate (F.atLoc F.dummySpan "init") (sEnv (gsym x) (gsort x)) <$> es))+     sEnv x s    = isEnv {F.seSort = F.insertSEnv x s (F.seSort isEnv)}     isEnv       = symbolEnv cfg si @@ -47,8 +45,8 @@ -------------------------------------------------------------------------------- refineG :: F.SInfo a -> [F.Qualifier] -> F.SEnv F.Sort -> F.WfC a -> (F.KVar, (F.GWInfo, [F.Expr])) refineG fi qs genv w = (k, (F.gwInfo w, Sol.qbExprs qb))-  where -    (k, qb) = refine fi qs genv w +  where+    (k, qb) = refine fi qs genv w  refine :: F.SInfo a -> [F.Qualifier] -> F.SEnv F.Sort -> F.WfC a -> (F.KVar, Sol.QBind) refine fi qs genv w = refineK (allowHOquals fi) env qs $ F.wrft w@@ -86,14 +84,16 @@        -> F.Sort        -> F.Qualifier        -> [Sol.EQual]-instKQ ho env v t q-  = do (su0, v0) <- candidates senv [(t, [v])] qt-       xs        <- match senv tyss [v0] (So.apply su0 <$> qts)-       return     $ Sol.eQual q (reverse xs)-    where-       qt : qts   = qpSort <$> F.qParams q-       tyss       = instCands ho env-       senv       = (`F.lookupSEnvWithDistance` env)+instKQ ho env v t q =+  case qpSort <$> F.qParams q of+    (qt:qts) -> do+        (su0, v0) <- candidates senv [(t, [v])] qt+        xs        <- match senv tyss [v0] (So.apply su0 <$> qts)+        return     $ Sol.eQual q (reverse xs)+      where+        tyss       = instCands ho env+        senv       = (`F.lookupSEnvWithDistance` env)+    [] -> error "Empty qpSort of qParams q"  instCands :: Bool -> F.SEnv F.Sort -> [(F.Sort, [F.Symbol])] instCands ho env = filter isOk tyss@@ -112,7 +112,7 @@ -------------------------------------------------------------------------------- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.Sort -> [(So.TVSubst, F.Symbol)] ---------------------------------------------------------------------------------candidates env tyss tx = +candidates env tyss tx =     [(su, y) | (t, ys) <- tyss              , su      <- maybeToList $ So.unifyFast mono env tx t              , y       <- ys                                   ]@@ -126,6 +126,6 @@   where     sr            = F.RR t (F.Reft (v, p))     p             = Sol.eqPred eq-    tc            = So.checkSorted F.dummySpan env sr +    tc            = So.checkSorted F.dummySpan env sr

src/Language/Fixpoint/Solver/GradualSolve.hs view

@@ -1,7 +1,4 @@-{-# LANGUAGE PatternGuards     #-}-{-# LANGUAGE TupleSections     #-} {-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}  -------------------------------------------------------------------------------- -- | Solve a system of horn-clause constraints ---------------------------------

src/Language/Fixpoint/Solver/Instantiate.hs view

@@ -1,23 +1,24 @@ ----------------------------------------------------------------------------------- | This module implements "Proof by Logical Evaluation" where we +-- | This module implements "Proof by Logical Evaluation" where we --   unfold function definitions if they *must* be unfolded, to strengthen---   the environments with function-definition-equalities. +--   the environments with function-definition-equalities. --   The algorithm is discussed at length in:--- +-- --     1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842---     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf +--     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf --------------------------------------------------------------------------------  {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE PartialTypeSignatures     #-} {-# LANGUAGE TupleSections             #-}-{-# LANGUAGE BangPatterns              #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE ViewPatterns              #-} {-# LANGUAGE PatternGuards             #-} {-# LANGUAGE RecordWildCards           #-} {-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wno-name-shadowing    #-}+ module Language.Fixpoint.Solver.Instantiate (instantiate) where  import           Language.Fixpoint.Types@@ -26,12 +27,14 @@ import qualified Language.Fixpoint.Misc          as Misc -- (mapFst) import qualified Language.Fixpoint.Smt.Interface as SMT import           Language.Fixpoint.Defunctionalize-import qualified Language.Fixpoint.Utils.Trie    as T -import           Language.Fixpoint.Utils.Progress -- as T +import qualified Language.Fixpoint.Utils.Trie    as T+import           Language.Fixpoint.Utils.Progress -- as T import           Language.Fixpoint.SortCheck-import           Language.Fixpoint.Graph.Deps             (isTarget) +import           Language.Fixpoint.Graph.Deps             (isTarget) import           Language.Fixpoint.Solver.Sanitize        (symbolEnv) import qualified Language.Fixpoint.Solver.PLE as PLE      (instantiate)+import qualified Language.Fixpoint.Solver.Common as Common (toSMT)+import           Language.Fixpoint.Solver.Common          (askSMT) import           Control.Monad.State import           Data.Bifunctor (second) import qualified Data.Text            as T@@ -44,10 +47,10 @@ -- import           Text.Printf (printf)  mytracepp :: (PPrint a) => String -> a -> a-mytracepp = notracepp +mytracepp = notracepp  ----------------------------------------------------------------------------------- | Strengthen Constraint Environments via PLE +-- | Strengthen Constraint Environments via PLE -------------------------------------------------------------------------------- instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) instantiate cfg fi subcIds@@ -61,154 +64,154 @@   = incrInstantiate' cfg fi subcIds  -------------------------------------------------------------------------------- --- | New "Incremental" PLE -- see [NOTE:TREE-LIKE] +-------------------------------------------------------------------------------+-- | New "Incremental" PLE -- see [NOTE:TREE-LIKE] -{- | [NOTE:TREE-LIKE] incremental PLE relies crucially on the SInfo satisfying -     a "tree like"   invariant: -       forall constraints c, c'. -         if i in c and i in c' then +{- | [NOTE:TREE-LIKE] incremental PLE relies crucially on the SInfo satisfying+     a "tree like"   invariant:+       forall constraints c, c'.+         if i in c and i in c' then            forall 0 <= j < i, j in c and j in c'   -} -------------------------------------------------------------------------------- +------------------------------------------------------------------------------- incrInstantiate' :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)-------------------------------------------------------------------------------- +------------------------------------------------------------------------------- incrInstantiate' cfg fi subcIds = do     let cs = [ (i, c) | (i, c) <- M.toList (cm fi), isPleCstr aEnv i c                       ,  maybe True (i `L.elem`) subcIds ]     let t  = mkCTrie cs                                               -- 1. BUILD the Trie-    res   <- withProgress (1 + length cs) $ +    res   <- withProgress (1 + length cs) $                withCtx cfg file sEnv (pleTrie t . instEnv cfg fi cs)  -- 2. TRAVERSE Trie to compute InstRes     return $ resSInfo cfg sEnv fi res                                 -- 3. STRENGTHEN SInfo using InstRes   where     file   = srcFile cfg ++ ".evals"     sEnv   = symbolEnv cfg fi-    aEnv   = ae fi +    aEnv   = ae fi   -------------------------------------------------------------------------------- --- | Step 1a: @instEnv@ sets up the incremental-PLE environment -instEnv :: (Loc a) => Config -> SInfo a -> [(SubcId, SimpC a)] -> SMT.Context -> InstEnv a +-------------------------------------------------------------------------------+-- | Step 1a: @instEnv@ sets up the incremental-PLE environment+instEnv :: (Loc a) => Config -> SInfo a -> [(SubcId, SimpC a)] -> SMT.Context -> InstEnv a instEnv cfg fi cs ctx = InstEnv cfg ctx bEnv aEnv (M.fromList cs) γ s0-  where +  where     bEnv              = bs fi     aEnv              = ae fi-    γ                 = knowledge cfg ctx aEnv -    s0                = EvalEnv 0 [] aEnv (SMT.ctxSymEnv ctx) cfg +    γ                 = knowledge cfg ctx aEnv+    s0                = EvalEnv 0 [] aEnv (SMT.ctxSymEnv ctx) cfg ----------------------------------------------------------------------------------------------- --- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments -mkCTrie :: [(SubcId, SimpC a)] -> CTrie +----------------------------------------------------------------------------------------------+-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments+mkCTrie :: [(SubcId, SimpC a)] -> CTrie mkCTrie ics  = mytracepp  "TRIE" $ T.fromList [ (cBinds c, i) | (i, c) <- ics ]   where-    cBinds   = L.sort . elemsIBindEnv . senv +    cBinds   = L.sort . elemsIBindEnv . senv ----------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------- -- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE pleTrie :: CTrie -> InstEnv a -> IO InstRes-pleTrie t env = loopT env ctx0 diff0 Nothing res0 t -  where +pleTrie t env = loopT env ctx0 diff0 Nothing res0 t+  where     diff0        = []-    res0         = M.empty +    res0         = M.empty     ctx0         = initCtx es0     es0          = eqBody <$> L.filter (null . eqArgs) (aenvEqs . ieAenv $ env)  loopT :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CTrie -> IO InstRes-loopT env ctx delta i res t = case t of +loopT env ctx delta i res t = case t of   T.Node []  -> return res   T.Node [b] -> loopB env ctx delta i res b-  T.Node bs  -> withAssms env ctx delta Nothing $ \ctx' -> do -                  (ctx'', res') <- ple1 env ctx' i Nothing res +  T.Node bs  -> withAssms env ctx delta Nothing $ \ctx' -> do+                  (ctx'', res') <- ple1 env ctx' i Nothing res                   foldM (loopB env ctx'' [] i) res' bs  loopB :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CBranch -> IO InstRes-loopB env ctx delta iMb res b = case b of +loopB env ctx delta iMb res b = case b of   T.Bind i t -> loopT env ctx (i:delta) (Just i) res t-  T.Val cid  -> withAssms env ctx delta (Just cid) $ \ctx' -> do +  T.Val cid  -> withAssms env ctx delta (Just cid) $ \ctx' -> do                   progressTick-                  (snd <$> ple1 env ctx' iMb (Just cid) res) +                  snd <$> ple1 env ctx' iMb (Just cid) res  -withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b -withAssms env@(InstEnv {..}) ctx delta cidMb act = do -  let ctx'  = updCtx env ctx delta cidMb +withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b+withAssms env@InstEnv{..} ctx delta cidMb act = do+  let ctx'  = updCtx env ctx delta cidMb   let assms = mytracepp  ("ple1-assms: " ++ show (cidMb, delta)) (icAssms ctx')   SMT.smtBracket ieSMT  "PLE.evaluate" $ do-    forM_ assms (SMT.smtAssert ieSMT) +    forM_ assms (SMT.smtAssert ieSMT)     act ctx' --- | @ple1@ performs the PLE at a single "node" in the Trie +-- | @ple1@ performs the PLE at a single "node" in the Trie ple1 :: InstEnv a -> ICtx -> Maybe BindId -> Maybe SubcId -> InstRes -> IO (ICtx, InstRes)-ple1 env@(InstEnv {..}) ctx i cidMb res = do -  let cands = mytracepp  ("ple1-cands: "  ++ show cidMb) $ S.toList (icCands ctx) -  -- unfolds  <- evalCands ieKnowl ieEvEnv cands   -  unfolds  <- evalCandsLoop ieCfg ieSMT ieKnowl ieEvEnv cands   +ple1 env@InstEnv{..} ctx i cidMb res = do+  let cands = mytracepp  ("ple1-cands: "  ++ show cidMb) $ S.toList (icCands ctx)+  -- unfolds  <- evalCands ieKnowl ieEvEnv cands+  unfolds  <- evalCandsLoop ieCfg ieSMT ieKnowl ieEvEnv cands   return    $ updCtxRes env ctx res i cidMb (mytracepp  ("ple1-cands-unfolds: " ++ show cidMb) unfolds) -_evalCands :: Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] +_evalCands :: Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] _evalCands _ _  []    = return [] _evalCands γ s0 cands = do eqs <- mapM (evalOne γ s0) cands                            return $ mkUnfolds (zip (Just <$> cands) eqs) -unfoldPred :: Config -> SMT.Context -> [Unfold] -> Pred -unfoldPred cfg ctx = toSMT cfg ctx [] . pAnd . concatMap snd  +unfoldPred :: Config -> SMT.Context -> [Unfold] -> Pred+unfoldPred cfg ctx = toSMT cfg ctx [] . pAnd . concatMap snd -evalCandsLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] -evalCandsLoop cfg ctx γ s0 cands = go [] cands -  where -    go acc []    = return acc +evalCandsLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Expr] -> IO [Unfold]+evalCandsLoop cfg ctx γ s0 cands = go [] cands+  where+    go acc []    = return acc     go acc cands = do eqss   <- SMT.smtBracket ctx "PLE.evaluate" $ do-                                  SMT.smtAssert ctx (unfoldPred cfg ctx acc) +                                  SMT.smtAssert ctx (unfoldPred cfg ctx acc)                                   mapM (evalOne γ s0) cands-                      let us  = zip (Just <$> cands) eqss -                      case mkUnfolds us of -                        []  -> return acc -                        us' -> do let acc'   = acc ++ us' +                      let us  = zip (Just <$> cands) eqss+                      case mkUnfolds us of+                        []  -> return acc+                        us' -> do let acc'   = acc ++ us'                                   let oks    = S.fromList [ e | (Just e, _) <- us' ]-                                  let cands' = [ e | e <- cands, not (S.member e oks) ] -                                  go acc' cands' +                                  let cands' = [ e | e <- cands, not (S.member e oks) ]+                                  go acc' cands'  ----------------------------------------------------------------------------------------------- --- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo +----------------------------------------------------------------------------------------------+-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo  resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a-resSInfo cfg env fi res = strengthenBinds fi res' +resSInfo cfg env fi res = strengthenBinds fi res'   where     res'     = M.fromList $ mytracepp  "ELAB-INST:  " $ zip is ps''-    ps''     = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' +    ps''     = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps'     ps'      = defuncAny cfg env ps     (is, ps) = unzip (M.toList res) ----------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------- -- | @InstEnv@ has the global information needed to do PLE-data InstEnv a = InstEnv +data InstEnv a = InstEnv   { ieCfg   :: !Config   , ieSMT   :: !SMT.Context-  , ieBEnv  :: !BindEnv-  , ieAenv  :: !AxiomEnv +  , ieBEnv  :: !(BindEnv a)+  , ieAenv  :: !AxiomEnv   , ieCstrs :: !(M.HashMap SubcId (SimpC a))   , ieKnowl :: !Knowledge   , ieEvEnv :: !EvalEnv-  } +  }  -- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE-data ICtx    = ICtx -  { icAssms  :: ![Pred]          -- ^ Hypotheses, already converted to SMT format +data ICtx    = ICtx+  { icAssms  :: ![Pred]          -- ^ Hypotheses, already converted to SMT format   , icCands  :: S.HashSet Expr   -- ^ "Candidates" for unfolding   , icEquals :: ![Expr]          -- ^ "Known" equalities   , icSolved :: S.HashSet Expr   -- ^ Terms that we have already expanded-  } +  }  -- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId type InstRes = M.HashMap BindId Expr --- | @Unfold is the result of running PLE at a single equality; ---     (e, [(e1, e1')...]) is the source @e@ and the (possible empty) ---   list of PLE-generated equalities (e1, e1') ... +-- | @Unfold is the result of running PLE at a single equality;+--     (e, [(e1, e1')...]) is the source @e@ and the (possible empty)+--   list of PLE-generated equalities (e1, e1') ... -- type Unfold  = (Maybe Expr, [(Expr, Expr)]) type Unfold  = (Maybe Expr, [Expr]) type CTrie   = T.Trie   SubcId@@ -216,32 +219,32 @@ type Diff    = [BindId]    -- ^ in "reverse" order  initCtx :: [Expr] -> ICtx-initCtx es = ICtx -  { icAssms  = [] -  , icCands  = mempty -  , icEquals = mytracepp  "INITIAL-STUFF-INCR" es +initCtx es = ICtx+  { icAssms  = []+  , icCands  = mempty+  , icEquals = mytracepp  "INITIAL-STUFF-INCR" es   , icSolved = mempty   }  equalitiesPred :: [(Expr, Expr)] -> [Expr]-equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ] +equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ] -updCtxRes :: InstEnv a -> ICtx -> InstRes -> Maybe BindId -> Maybe SubcId -> [Unfold] -> (ICtx, InstRes) -updCtxRes env ctx res iMb cidMb us -                       = -- trace _msg +updCtxRes :: InstEnv a -> ICtx -> InstRes -> Maybe BindId -> Maybe SubcId -> [Unfold] -> (ICtx, InstRes)+updCtxRes env ctx res iMb cidMb us+                       = -- trace _msg                          ( ctx { {- icCands  = cands', -} icSolved = solved', icEquals = mempty}                          , res'-                         ) -  where +                         )+  where     _msg               = Mb.maybe "nuttin\n" (debugResult env res') cidMb-    res'               = updRes res iMb (pAnd solvedEqs) -    _cands'             = ((icCands ctx) `S.union` newCands) `S.difference` solved' -    solved'            = S.union (icSolved ctx) solvedCands -    newCands           = S.fromList (concatMap topApps newEqs) -    solvedCands        = S.fromList [ e | (Just e, _) <- okUnfolds ] -    solvedEqs          = icEquals ctx ++ newEqs +    res'               = updRes res iMb (pAnd solvedEqs)+    _cands'             = (icCands ctx `S.union` newCands) `S.difference` solved'+    solved'            = S.union (icSolved ctx) solvedCands+    newCands           = S.fromList (concatMap topApps newEqs)+    solvedCands        = S.fromList [ e | (Just e, _) <- okUnfolds ]+    solvedEqs          = icEquals ctx ++ newEqs     newEqs             = concatMap snd okUnfolds-    okUnfolds          = mytracepp  _str [ (eMb, ps)  | (eMb, ps) <- us, {- let ps = equalitiesPred eqs, -} not (null ps) ] +    okUnfolds          = mytracepp  _str [ (eMb, ps)  | (eMb, ps) <- us, {- let ps = equalitiesPred eqs, -} not (null ps) ]     _str               = "okUnfolds " ++ showpp (iMb, cidMb)     -- cands'             = S.difference (icCands ctx) (S.fromList solvedCands)     -- solvedEqs          = icEquals ctx ++ concatMap snd us@@ -250,46 +253,48 @@ mkUnfolds :: [(a, [(Expr, Expr)])] -> [(a, [Expr])] mkUnfolds us = [ (eMb, ps)  | (eMb, eqs) <- us                             , let ps = equalitiesPred eqs-                            , not (null ps) -               ] +                            , not (null ps)+               ] -debugResult :: InstEnv a -> InstRes -> SubcId -> String -debugResult (InstEnv {..}) res i = msg -  where -    msg                          = "INCR-INSTANTIATE i = " ++ show i ++ ": " ++ showpp cidEqs -    cidEqs                       = pAnd [ e | i <- cBinds, e <- Mb.maybeToList $ M.lookup i res ] +debugResult :: InstEnv a -> InstRes -> SubcId -> String+debugResult InstEnv{..} res i = msg+  where+    msg                          = "INCR-INSTANTIATE i = " ++ show i ++ ": " ++ showpp cidEqs+    cidEqs                       = pAnd [ e | i <- cBinds, e <- Mb.maybeToList $ M.lookup i res ]     cBinds                       = L.sort . elemsIBindEnv . senv . getCstr ieCstrs $ i   updRes :: InstRes -> Maybe BindId -> Expr -> InstRes-updRes res (Just i) e = M.insert i e res -updRes res  Nothing _ = res +updRes res (Just i) e = M.insert i e res+updRes res  Nothing _ = res --- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ ---   to the context. -updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx -updCtx InstEnv {..} ctx delta cidMb -              = ctx { icAssms  = ctxEqs  +-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@+--   to the context.+updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx+updCtx InstEnv {..} ctx delta cidMb+              = ctx { icAssms  = ctxEqs                     , icCands  = cands   <> icCands  ctx                     , icEquals = initEqs <> icEquals ctx }-  where         +  where     initEqs   = equalitiesPred (initEqualities ieSMT ieAenv bs)-    cands     = (S.fromList (concatMap topApps es0)) `S.difference` (icSolved ctx)-    ctxEqs    = toSMT ieCfg ieSMT [] <$> concat -                  [ initEqs -                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]-                  ]+    cands     = S.fromList (concatMap topApps es0) `S.difference` icSolved ctx+    ctxEqs    = toSMT ieCfg ieSMT [] <$>+                  (initEqs +++                  [ expr xr+                  | xr@(_, r) <- bs+                  , null (Vis.kvarsExpr $ reftPred $ sr_reft r)+                  ])     (bs, es0) = (second unElabSortedReft <$> binds, unElab <$> es)-    es        = eRhs : (expr <$> binds) +    es        = eRhs : (expr <$> binds)     eRhs      = maybe PTrue crhs subMb-    binds     = [ lookupBindEnv i ieBEnv | i <- delta ] +    binds     = [ (x, y)  | i <- delta, let (x, y, _) = lookupBindEnv i ieBEnv ]     subMb     = getCstr ieCstrs <$> cidMb -getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a +getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env  ----------------------------------------------------------------------------------- | "Old" GLOBAL PLE +-- | "Old" GLOBAL PLE -------------------------------------------------------------------------------- instantiate' :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) instantiate' cfg fi subcIds = sInfo cfg env fi <$> withCtx cfg file env act@@ -300,69 +305,69 @@                                ,  maybe True (i `L.elem`) subcIds ]     file            = srcFile cfg ++ ".evals"     env             = symbolEnv cfg fi-    aenv            = {- mytracepp  "AXIOM-ENV" -} (ae fi)+    aenv            = {- mytracepp  "AXIOM-ENV" -} ae fi  sInfo :: Config -> SymEnv -> SInfo a -> [((SubcId, SrcSpan), Expr)] -> SInfo a sInfo cfg env fi ips = strengthenHyp fi (mytracepp  "ELAB-INST:  " $ zip (fst <$> is) ps'')   where     (is, ps)         = unzip ips     ps'              = defuncAny cfg env ps-    ps''             = zipWith (\(i, sp) -> elaborate (atLoc sp ("PLE1 " ++ show i)) env) is ps' +    ps''             = zipWith (\(i, sp) -> elaborate (atLoc sp ("PLE1 " ++ show i)) env) is ps' -instSimpC :: Config -> SMT.Context -> BindEnv -> AxiomEnv -> SubcId -> SimpC a -> IO Expr-instSimpC cfg ctx bds aenv sid sub +instSimpC :: Config -> SMT.Context -> BindEnv a -> AxiomEnv -> SubcId -> SimpC a -> IO Expr+instSimpC cfg ctx bds aenv sid sub   | isPleCstr aenv sid sub = do-    let is0       = mytracepp  "INITIAL-STUFF" $ eqBody <$> L.filter (null . eqArgs) (aenvEqs aenv) +    let is0       = mytracepp  "INITIAL-STUFF" $ eqBody <$> L.filter (null . eqArgs) (aenvEqs aenv)     let (bs, es0) = cstrExprs bds sub-    equalities   <- evaluate cfg ctx aenv bs es0 sid -    let evalEqs   = [ EEq e1 e2 | (e1, e2) <- equalities, e1 /= e2 ] -    return        $ pAnd (is0 ++ evalEqs)  +    equalities   <- evaluate cfg ctx aenv bs es0 sid+    let evalEqs   = [ EEq e1 e2 | (e1, e2) <- equalities, e1 /= e2 ]+    return        $ pAnd (is0 ++ evalEqs)   | otherwise     = return PTrue  isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool-isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) +isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) -cstrExprs :: BindEnv -> SimpC a -> ([(Symbol, SortedReft)], [Expr])+cstrExprs :: BindEnv a -> SimpC a -> ([(Symbol, SortedReft)], [Expr]) cstrExprs bds sub = (second unElabSortedReft <$> binds, unElab <$> es)   where-    es            = (crhs sub) : (expr <$> binds)+    es            = crhs sub : (expr <$> binds)     binds         = envCs bds (senv sub)  -------------------------------------------------------------------------------- -- | Symbolic Evaluation with SMT -------------------------------------------------------------------------------- evaluate :: Config -> SMT.Context -> AxiomEnv -- ^ Definitions-         -> [(Symbol, SortedReft)]            -- ^ Environment of "true" facts -         -> [Expr]                            -- ^ Candidates for unfolding +         -> [(Symbol, SortedReft)]            -- ^ Environment of "true" facts+         -> [Expr]                            -- ^ Candidates for unfolding          -> SubcId                            -- ^ Constraint Id          -> IO [(Expr, Expr)]                 -- ^ Newly unfolded equalities ---------------------------------------------------------------------------------evaluate cfg ctx aenv facts es sid = do -  let eqs      = initEqualities ctx aenv facts  -  let γ        = knowledge cfg ctx aenv +evaluate cfg ctx aenv facts es sid = do+  let eqs      = initEqualities ctx aenv facts+  let γ        = knowledge cfg ctx aenv   let cands    = mytracepp  ("evaluate-cands " ++ showpp sid) $ Misc.hashNub (concatMap topApps es)   let s0       = EvalEnv 0 [] aenv (SMT.ctxSymEnv ctx) cfg   let ctxEqs   = [ toSMT cfg ctx [] (EEq e1 e2) | (e1, e2)  <- eqs ]               ++ [ toSMT cfg ctx [] (expr xr)   | xr@(_, r) <- facts, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]-  eqss        <- _evalLoop cfg ctx γ s0 ctxEqs cands +  eqss        <- _evalLoop cfg ctx γ s0 ctxEqs cands   return       $ eqs ++ eqss  - + _evalLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Pred] -> [Expr] -> IO [(Expr, Expr)]-_evalLoop cfg ctx γ s0 ctxEqs cands = loop 0 [] cands -  where +_evalLoop cfg ctx γ s0 ctxEqs cands = loop 0 [] cands+  where     loop _ acc []    = return acc     loop i acc cands = do let eqp = toSMT cfg ctx [] $ pAnd $ equalitiesPred acc                           eqss <- SMT.smtBracket ctx "PLE.evaluate" $ do-                                    forM_ (eqp : ctxEqs) (SMT.smtAssert ctx) +                                    forM_ (eqp : ctxEqs) (SMT.smtAssert ctx)                                     mapM (evalOne γ s0) cands-                          case concat eqss of -                            []   -> return acc -                            eqs' -> do let acc'   = acc ++ eqs' +                          case concat eqss of+                            []   -> return acc+                            eqs' -> do let acc'   = acc ++ eqs'                                        let oks    = S.fromList (fst <$> eqs')-                                       let cands' = [ e | e <- cands, not (S.member e oks) ] -                                       loop (i+1) acc' cands'+                                       let cands' = [ e | e <- cands, not (S.member e oks) ]+                                       loop (i + 1 :: Integer) acc' cands'   @@ -380,41 +385,41 @@  evalOne :: Knowledge -> EvalEnv -> Expr -> IO [(Expr, Expr)] evalOne γ s0 e = do-  (e', st) <- runStateT (eval γ initCS (mytracepp "evalOne: " e)) s0 +  (e', st) <- runStateT (eval γ initCS (mytracepp "evalOne: " e)) s0   if e' == e then return [] else return ((e, e') : evSequence st) -{- | [NOTE: Eval-Ite]  We should not be doing any PLE/eval under if-then-else where +{- | [NOTE: Eval-Ite]  We should not be doing any PLE/eval under if-then-else where      the guard condition does not provably hold. For example, see issue #387.-     However, its ok and desirable to `eval` in this case, as long as one is not -     unfolding recursive functions. To permit this, we track the "call-stack" and -     whether or not, `eval` is occurring under an unresolved guard: if so, we do not +     However, its ok and desirable to `eval` in this case, as long as one is not+     unfolding recursive functions. To permit this, we track the "call-stack" and+     whether or not, `eval` is occurring under an unresolved guard: if so, we do not      expand under any function that is already on the call-stack.   -}  data Recur  = Ok | Stop deriving (Eq, Show) type CStack = ([Symbol], Recur) -instance PPrint Recur where -  pprintTidy _ = Misc.tshow +instance PPrint Recur where+  pprintTidy _ = Misc.tshow -initCS :: CStack +initCS :: CStack initCS = ([], Ok) -pushCS :: CStack -> Symbol -> CStack +pushCS :: CStack -> Symbol -> CStack pushCS (fs, r) f = (f:fs, r) -recurCS :: CStack -> Symbol -> Bool -recurCS (_,  Ok) _ = True --- recurCS (_,  _ ) _ = False -- not (f `elem` fs) -recurCS (fs, _) f  = not (f `elem` fs) +recurCS :: CStack -> Symbol -> Bool+recurCS (_,  Ok) _ = True+-- recurCS (_,  _ ) _ = False -- not (f `elem` fs)+recurCS (fs, _) f  = f `notElem` fs -noRecurCS :: CStack -> CStack +noRecurCS :: CStack -> CStack noRecurCS (fs, _) = (fs, Stop)  -- Don't evaluate under Lam, App, Ite, or Constants topApps :: Expr -> [Expr]-topApps = go -  where +topApps = go+  where     go (PAnd es)       = concatMap go es     go (POr es)        = concatMap go es     go (PAtom _ e1 e2) = go e1  ++ go e2@@ -431,12 +436,12 @@ makeLam γ e = L.foldl' (flip ELam) e (knLams γ)  eval :: Knowledge -> CStack -> Expr -> EvalST Expr-eval γ stk = go -  where +eval γ stk = go+  where     go (ELam (x,s) e)   = ELam (x, s) <$> eval γ' stk e where γ' = γ { knLams = (x, s) : knLams γ }     go e@(EIte b e1 e2) = go b        >>= \b' -> evalIte γ stk e b' e1 e2     go (ECoerc s t e)   = ECoerc s t  <$> go e-    go e@(EApp _ _)     = evalArgs γ stk e >>= evalApp γ stk e +    go e@(EApp _ _)     = evalArgs γ stk e >>= evalApp γ stk e     go e@(EVar _)       = evalApp  γ stk e (e, [])     go (PAtom r e1 e2)  = PAtom r      <$> go e1 <*> go e2     go (ENeg e)         = ENeg         <$> go e@@ -446,21 +451,18 @@     go (PNot e)         = PNot         <$> go e     go (PImp e1 e2)     = PImp         <$> go e1 <*> go e2     go (PIff e1 e2)     = PIff         <$> go e1 <*> go e2-    go (PAnd es)        = PAnd         <$> (go  <$$> es)-    go (POr es)         = POr          <$> (go  <$$> es)+    go (PAnd es)        = PAnd         <$> (go `traverse` es)+    go (POr es)         = POr          <$> (go `traverse` es)     go e                = return e -(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b]-f <$$> xs = f Misc.<$$> xs- -- | `evalArgs` also evaluates all the partial applications for hacky reasons,---   suppose `foo g = id` then we want `foo g 10 = 10` and for that we need +--   suppose `foo g = id` then we want `foo g 10 = 10` and for that we need --   to `eval` the term `foo g` into `id` to tickle the `eval` on `id 10`.---   This seems a bit of a hack. At any rate, this can lead to divergence. +--   This seems a bit of a hack. At any rate, this can lead to divergence. --   TODO: distill a .fq test from the MOSSAKA-hw3 example.  evalArgs :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr])-evalArgs γ stk e = go [] e +evalArgs γ stk e = go [] e   where     go acc (EApp f e)       = do f' <- evalOk γ stk f@@ -472,41 +474,41 @@ -- | Minimal test case illustrating this `evalOk` hack is LH#tests/ple/pos/MossakaBug.hs --   too tired & baffled to generate simple .fq version. TODO:nuke and rewrite PLE! evalOk :: Knowledge -> CStack -> Expr -> EvalST Expr-evalOk γ stk@(_, Ok) e = eval γ stk e -evalOk _ _           e = pure e +evalOk γ stk@(_, Ok) e = eval γ stk e+evalOk _ _           e = pure e -{- +{- evalArgs :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr])-evalArgs -  | True  = evalArgsOLD -  | False = evalArgsNEW +evalArgs+  | True  = evalArgsOLD+  | False = evalArgsNEW  evalArgsNEW :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr])-evalArgsNEW γ stk e = do -    let (e1, es) = splitEApp e -    e1' <- eval γ stk e1 -    es' <- mapM (eval γ stk) es +evalArgsNEW γ stk e = do+    let (e1, es) = splitEApp e+    e1' <- eval γ stk e1+    es' <- mapM (eval γ stk) es     return (e1', es')  -}-    + evalApp :: Knowledge -> CStack -> Expr -> (Expr, [Expr]) -> EvalST Expr -- evalApp γ stk e (e1, es) = tracepp ("evalApp:END" ++ showpp (e1,es)) <$> (evalAppAc γ stk e (e1, es))-evalApp γ stk e (e1, es) = do +evalApp γ stk e (e1, es) = do   res     <- evalAppAc γ stk e (e1, es)-  let diff = (res /= (eApps e1 es))-  return   $ mytracepp ("evalApp:END:" ++ showpp diff) res +  let diff = res /= eApps e1 es+  return   $ mytracepp ("evalApp:END:" ++ showpp diff) res  evalAppAc :: Knowledge -> CStack -> Expr -> (Expr, [Expr]) -> EvalST Expr -{- MOSSAKA-} +{- MOSSAKA-} evalAppAc γ stk e (EVar f, [ex])   | (EVar dc, es) <- splitEApp ex   , Just simp <- L.find (\simp -> (smName simp == f) && (smDC simp == dc)) (knSims γ)   , length (smArgs simp) == length es   = do let msg    = "evalAppAc:ePop: " ++ showpp (f, dc, es)        let ePopIf = mytracepp msg $ substPopIf (zip (smArgs simp) es) (smBody simp)-       e'    <- eval γ stk ePopIf +       e'    <- eval γ stk ePopIf        (e, "Rewrite -" ++ showpp f) ~> e'  evalAppAc γ stk _ (EVar f, es)@@ -514,20 +516,20 @@   | Just eq <- L.find (( == f) . eqName) (knAms γ)   , Just bd <- getEqBody eq   , length (eqArgs eq) == length es-  , f `notElem` syms bd               -- non-recursive equations << HACK! misses MUTUALLY RECURSIVE definitions! -  , recurCS stk f -  = do env   <- seSort <$> gets evEnv+  , f `notElem` syms bd               -- non-recursive equations << HACK! misses MUTUALLY RECURSIVE definitions!+  , recurCS stk f+  = do env   <- gets (seSort . evEnv)        let ee = substEq env PopIf eq es bd-       assertSelectors γ ee -       eval γ (pushCS stk f) ee +       assertSelectors γ ee+       eval γ (pushCS stk f) ee  evalAppAc γ stk _e (EVar f, es)   | Just eq <- L.find ((== f) . eqName) (knAms γ)   , Just bd <- getEqBody eq   , length (eqArgs eq) == length es   -- recursive equations-  , recurCS stk f -  = do env      <- seSort <$> gets evEnv-       mytracepp ("EVAL-REC-APP" ++ showpp (stk, _e)) +  , recurCS stk f+  = do env      <- gets (seSort . evEnv)+       mytracepp ("EVAL-REC-APP" ++ showpp (stk, _e))          <$> evalRecApplication γ (pushCS stk f) (eApps (EVar f) es) (substEq env Normal eq es bd)  evalAppAc _ _ _ (f, es)@@ -553,20 +555,20 @@  substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr -> Expr substEqCoerce env eq es bd = Vis.applyCoSub coSub bd-  where +  where     ts    = snd    <$> eqArgs eq     sp    = panicSpan "mkCoSub"     eTs   = sortExpr sp env <$> es     coSub = mytracepp  ("substEqCoerce" ++ showpp (eqName eq, es, eTs, ts)) $ mkCoSub env eTs ts  mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub-mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] +mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ]   where     unite ts    = mytracepp ("UNITE: " ++ showpp ts) $ Mb.fromMaybe (uError ts) (unifyTo1 senv ts)     senv        = mkSearchEnv env-    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) +    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts)     xys         = mytracepp "mkCoSubXXX" $ Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs-    (_xTs,_eTs) = mytracepp "mkCoSub:MATCH" $ (xTs, eTs)+    (_xTs,_eTs) = mytracepp "mkCoSub:MATCH" (xTs, eTs)  matchSorts :: Sort -> Sort -> [(Symbol, Sort)] matchSorts s1 s2 = mytracepp  ("matchSorts :" ++ showpp (s1, s2)) $ go s1 s2@@ -616,16 +618,16 @@             b1 <- liftIO (isValid γ b')             if b1               then addEquality γ e e1 >>-                   ({- SCC "assertSelectors-1" #-} assertSelectors γ e1) >>+                   {- SCC "assertSelectors-1" -} assertSelectors γ e1 >>                    eval γ stk (mytracepp ("evalREC-1: " ++ showpp stk) e1) >>=                    ((e, "App1: ") ~>)               else do                    b2 <- liftIO (isValid γ (PNot b'))                    if b2                       then addEquality γ e e2 >>-                           ({- SCC "assertSelectors-2" #-} assertSelectors γ e2) >>+                           {- SCC "assertSelectors-2" -} assertSelectors γ e2 >>                            eval γ stk (mytracepp ("evalREC-2: " ++ showpp stk) e2) >>=-                           ((e, ("App2: " ++ showpp stk ) ) ~>)+                           ((e, "App2: " ++ showpp stk ) ~>)                       else return e evalRecApplication _ _ _ e   = return e@@ -635,14 +637,14 @@   modify (\st -> st{evSequence = (makeLam γ e1, makeLam γ e2):evSequence st})  evalIte :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> EvalST Expr-evalIte γ stk e b e1 e2 = mytracepp "evalIte:END: " <$> -                            evalIteAc γ stk e b e1 (mytracepp msg e2) -  where -    msg = "evalIte:BEGINS: " ++ showpp (stk, e) +evalIte γ stk e b e1 e2 = mytracepp "evalIte:END: " <$>+                            evalIteAc γ stk e b e1 (mytracepp msg e2)+  where+    msg = "evalIte:BEGINS: " ++ showpp (stk, e)   evalIteAc :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> EvalST Expr-evalIteAc γ stk e b e1 e2 +evalIteAc γ stk e b e1 e2   = join $ evalIte' γ stk e b e1 e2 <$> liftIO (isValid γ b) <*> liftIO (isValid γ (PNot b))  evalIte' :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> Bool -> Bool -> EvalST Expr@@ -655,14 +657,14 @@   = do e' <- eval γ stk e2        (e, "If-False") ~> e' evalIte' γ stk _ b e1 e2 _ _-  -- see [NOTE:Eval-Ite] #387 -  = EIte b <$> eval γ stk' e1 <*> eval γ stk' e2 -    where stk' = mytracepp "evalIte'" $ noRecurCS stk +  -- see [NOTE:Eval-Ite] #387+  = EIte b <$> eval γ stk' e1 <*> eval γ stk' e2+    where stk' = mytracepp "evalIte'" $ noRecurCS stk  -------------------------------------------------------------------------------- -- | Knowledge (SMT Interaction) ---------------------------------------------------------------------------------data Knowledge = KN +data Knowledge = KN   { knSims    :: ![Rewrite]           -- ^ Measure info, asserted for each new Ctor ('assertSelectors')   , knAms     :: ![Equation]          -- ^ (Recursive) function definitions, used for PLE   , knContext :: SMT.Context@@ -671,20 +673,20 @@   }  isValid :: Knowledge -> Expr -> IO Bool-isValid γ e = mytracepp ("isValid: " ++ showpp e) <$> +isValid γ e = mytracepp ("isValid: " ++ showpp e) <$>                 knPreds γ (knContext γ) (knLams γ) e -isProof :: (a, SortedReft) -> Bool +isProof :: (a, SortedReft) -> Bool isProof (_, RR s _) = showpp s == "Tuple"  knowledge :: Config -> SMT.Context -> AxiomEnv -> Knowledge-knowledge cfg ctx aenv = KN +knowledge cfg ctx aenv = KN   { knSims    = aenvSimpl aenv   , knAms     = aenvEqs   aenv-  , knContext = ctx -  , knPreds   = askSMT    cfg -  , knLams    = [] -  } +  , knContext = ctx+  , knPreds   = askSMT    cfg+  , knLams    = []+  }  -- | This creates the rewrite rule e1 -> e2, applied when: -- 1. when e2 is a DataCon and can lead to further reductions@@ -693,26 +695,15 @@ initEqualities ctx aenv es = concatMap (makeSimplifications (aenvSimpl aenv)) dcEqs   where     dcEqs                  = Misc.hashNub (Mb.catMaybes [getDCEquality senv e1 e2 | EEq e1 e2 <- atoms])-    atoms                  = splitPAnd =<< (expr <$> filter isProof es)+    atoms                  = splitPAnd . expr =<< filter isProof es     senv                   = SMT.ctxSymEnv ctx --- AT: Non-obvious needed invariant: askSMT True is always the +-- AT: Non-obvious needed invariant: askSMT True is always the -- totality-effecting one.--- RJ: What does "totality effecting" mean? --askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool-askSMT cfg ctx bs e-  | isTautoPred  e     = return True-  | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e'-  | otherwise          = return False-  where -    e'                 = toSMT cfg ctx bs e +-- RJ: What does "totality effecting" mean?  toSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> Pred-toSMT cfg ctx bs = defuncAny cfg senv . elaborate "makeKnowledge" (elabEnv bs)-  where-    elabEnv      = insertsSymEnv senv-    senv         = SMT.ctxSymEnv ctx+toSMT = Common.toSMT "Instantiate.toSMT"  makeSimplifications :: [Rewrite] -> (Symbol, [Expr], Expr) -> [(Expr, Expr)] makeSimplifications sis (dc, es, e)@@ -750,9 +741,9 @@   = Nothing  isUpperSymbol :: Symbol -> Bool-isUpperSymbol x = (0 < lengthSym x') && (isUpper $ headSym x')-  where -    x' = dropModuleNames x +isUpperSymbol x = (0 < lengthSym x') && isUpper (headSym x')+  where+    x' = dropModuleNames x  dropModuleNames :: Symbol -> Symbol dropModuleNames = mungeNames (symbol . last) "."@@ -782,11 +773,10 @@  assertSelectors :: Knowledge -> Expr -> EvalST () assertSelectors γ e = do-    sims <- aenvSimpl <$> gets _evAEnv+    sims <- gets (aenvSimpl . _evAEnv)     -- cfg  <- gets evCfg     -- _    <- foldlM (\_ s -> Vis.mapMExpr (go s) e) (mytracepp  "assertSelector" e) sims     forM_ sims $ \s -> Vis.mapMExpr (go s) e-    return ()   where     go :: Rewrite -> Expr -> EvalST Expr     go (SMeasure f dc xs bd) e@(EApp _ _)@@ -812,9 +802,9 @@   _   <- SMT.cleanupContext ctx   return res +infixl 9 ~> (~>) :: (Expr, String) -> Expr -> EvalST Expr (e, _str) ~> e' = do-  let msg = "PLE: " ++ _str ++ showpp (e, e') -  modify (\st -> st {evId = (mytracepp msg $ evId st) + 1})+  let msg = "PLE: " ++ _str ++ showpp (e, e')+  modify (\st -> st {evId = mytracepp msg (evId st) + 1})   return e'-

+ src/Language/Fixpoint/Solver/Interpreter.hs view

@@ -0,0 +1,733 @@+--------------------------------------------------------------------------------+-- | This module is a preliminary part of the implementation of "Proof by+--   Logical Evaluation" where we unfold function definitions if they *must* be+--   unfolded, to strengthen the environments with function-definition-equalities.+--+--   In this module, we attempt to verify as many of the PLE constaints as+--   possible without invoking the SMT solver or performing any I/O at all.+--   To this end, we use an interpreter in Haskell to attempt to evaluate down+--   expressions and generate equalities.+--------------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ExistentialQuantification #-}++{-# OPTIONS_GHC -Wno-name-shadowing    #-}++module Language.Fixpoint.Solver.Interpreter+  ( instInterpreter++  -- The following exports are for property testing.+  , ICtx(..)+  , Knowledge(..)+  , Simplifiable(..)+  , interpret+  ) where++import           Language.Fixpoint.Types hiding (simplify)+import           Language.Fixpoint.Types.Config  as FC+import           Language.Fixpoint.Types.Solutions        (CMap)+import qualified Language.Fixpoint.Types.Visitor as Vis+import qualified Language.Fixpoint.Misc          as Misc+import           Language.Fixpoint.Defunctionalize+import qualified Language.Fixpoint.Utils.Trie    as T+import           Language.Fixpoint.Utils.Progress+import           Language.Fixpoint.SortCheck+import           Language.Fixpoint.Graph.Deps             (isTarget)+import           Language.Fixpoint.Solver.Sanitize        (symbolEnv)+import           Language.Fixpoint.Solver.Simplify+import           Control.Monad.State+import qualified Data.HashMap.Strict  as M+import qualified Data.HashSet         as S+import qualified Data.List            as L+import qualified Data.Maybe           as Mb+--import           Debug.Trace                              (trace)++mytracepp :: (PPrint a) => String -> a -> a+mytracepp = notracepp++--mytrace :: String -> a -> a+--mytrace = {-trace-} flip const++--------------------------------------------------------------------------------+-- | Strengthen Constraint Environments via PLE+--------------------------------------------------------------------------------+instInterpreter :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+instInterpreter cfg fi' subcIds = do+    let cs = M.filterWithKey+               (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds)+               (cm fi)+    let t  = mkCTrie (M.toList cs)                      -- 1. BUILD the Trie+    res   <- withProgress (1 + M.size cs) $+               pleTrie t $ instEnv fi cs sEnv           -- 2. TRAVERSE Trie to compute InstRes+    return $ resSInfo cfg sEnv fi res                   -- 3. STRENGTHEN SInfo using InstRes+  where+    sEnv   = symbolEnv cfg fi+    aEnv   = ae fi+    fi     = normalize fi'++-------------------------------------------------------------------------------+-- | Step 1a: @instEnv@ sets up the incremental-PLE environment+instEnv :: (Loc a) => SInfo a -> CMap (SimpC a) -> SymEnv -> InstEnv a+instEnv fi cs sEnv = InstEnv bEnv aEnv cs γ s0+  where+    csBinds           = M.foldl' (\acc c -> unionIBindEnv acc (senv c)) emptyIBindEnv cs+    bEnv              = filterBindEnv (\i _ _ -> memberIBindEnv i csBinds) (bs fi)+    aEnv              = ae fi+    γ                 = knowledge fi+    s0                = EvalEnv sEnv mempty++----------------------------------------------------------------------------------------------+-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments+mkCTrie :: [(SubcId, SimpC a)] -> CTrie+mkCTrie ics  = T.fromList [ (cBinds c, i) | (i, c) <- ics ]+  where+    cBinds   = L.sort . elemsIBindEnv . senv++----------------------------------------------------------------------------------------------+-- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE+pleTrie :: CTrie -> InstEnv a -> IO InstRes+pleTrie t env = loopT env ctx0 diff0 Nothing res0 t+  where+    diff0        = []+    res0         = M.empty+    ctx0         = initCtx env ((mkEq <$> es0) ++ (mkEq' <$> es0'))+    es0          = L.filter (null . eqArgs) (aenvEqs   . ieAenv $ env)+    es0'         = L.filter (null . smArgs) (aenvSimpl . ieAenv $ env)+    mkEq  eq     = (EVar $ eqName eq, eqBody eq)+    mkEq' rw     = (EApp (EVar $ smName rw) (EVar $ smDC rw), smBody rw)++loopT :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CTrie -> IO InstRes+loopT env ctx delta i res t = case t of+  T.Node []  -> return res+  T.Node [b] -> loopB env ctx delta i res b+  T.Node bs  -> withAssms env ctx delta Nothing $ \ctx' -> do+                  (ctx'', res') <- ple1 env ctx' i res+                  foldM (loopB env ctx'' [] i) res' bs++loopB :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CBranch -> IO InstRes+loopB env ctx delta iMb res b = case b of+  T.Bind i t -> loopT env ctx (i:delta) (Just i) res t+  T.Val cid  -> withAssms env ctx delta (Just cid) $ \ctx' -> do+                  progressTick+                  snd <$> ple1 env ctx' iMb res++-- Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@+-- and the rhs of @cidMb@.+--+-- Adds to @ctx@ assumptions from @env@ and @delta@ plus rewrites that+-- candidates can use+withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b+withAssms env@InstEnv{} ctx delta cidMb act = act $+  updCtx env ctx delta cidMb++-- | @ple1@ performs the PLE at a single "node" in the Trie+ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstRes)+ple1 InstEnv{..} ctx i res =+  updCtxRes res i <$> evalCandsLoop {-anfEnv-} M.empty ctx ieKnowl ieEvEnv++evalCandsLoop :: ConstMap -> ICtx -> Knowledge -> EvalEnv -> IO ICtx+evalCandsLoop ie ictx0 γ env = go ictx0+  where+    withRewrites exprs =+      let+        rws = [rewrite e rw | rw <- snd <$> M.toList (knSims γ)+                            ,  e <- S.toList (snd `S.map` exprs)]+      in+        exprs <> S.fromList (concat rws)+    go ictx | S.null (icCands ictx) = return ictx+    go ictx =  do let cands = icCands ictx+                  let env' = env { evAccum = icEquals ictx <> evAccum env }+                  (ictx', evalResults)  <-+                               foldM (evalOneCandStep ie γ env') (ictx, []) (S.toList cands)+                  let us = mconcat evalResults+                  if S.null (us `S.difference` icEquals ictx)+                        then return ictx+                        else do  let oks      = fst `S.map` us+                                 let us'      = withRewrites us+                                 let ictx''   = ictx' { icSolved = icSolved ictx <> oks+                                                      , icEquals = icEquals ictx <> us' }+                                 let newcands = mconcat (makeCandidates γ ictx'' <$> S.toList (cands <> (snd `S.map` us)))+                                 go (ictx'' { icCands = S.fromList newcands})++-- evalOneCands :: Knowledge -> EvalEnv -> ICtx -> [Expr] -> IO (ICtx, [EvAccum])+-- evalOneCands γ env' ictx = foldM step (ictx, [])+evalOneCandStep :: ConstMap -> Knowledge -> EvalEnv -> (ICtx, [EvAccum]) -> Expr -> IO (ICtx, [EvAccum])+evalOneCandStep env γ env' (ictx, acc) e = do+  res <- evalOne env γ env' ictx e+  return (ictx, res : acc)++rewrite :: Expr -> Rewrite -> [(Expr,Expr)]+rewrite e rw = Mb.mapMaybe (`rewriteTop` rw) (notGuardedApps e)++rewriteTop :: Expr -> Rewrite -> Maybe (Expr,Expr)+rewriteTop e rw+  | (EVar f, es) <- splitEApp e+  , f == smDC rw+  , length es == length (smArgs rw)+  = Just (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw))+  | otherwise+  = Nothing++----------------------------------------------------------------------------------------------+-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo+----------------------------------------------------------------------------------------------++resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a+resSInfo cfg env fi res = strengthenBinds fi res'+  where+    res'     = M.fromList $ zip is ps''+    ps''     = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps'+    ps'      = defuncAny cfg env ps+    (is, ps) = unzip (M.toList res)++----------------------------------------------------------------------------------------------+-- | @InstEnv@ has the global information needed to do PLE+----------------------------------------------------------------------------------------------++data InstEnv a = InstEnv+  { ieBEnv  :: !(BindEnv a)+  , ieAenv  :: !AxiomEnv+  , ieCstrs :: !(CMap (SimpC a))+  , ieKnowl :: !Knowledge+  , ieEvEnv :: !EvalEnv+  }++----------------------------------------------------------------------------------------------+-- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE+----------------------------------------------------------------------------------------------++data ICtx    = ICtx+  { icCands    :: S.HashSet Expr            -- ^ "Candidates" for unfolding+  , icEquals   :: EvAccum                   -- ^ Accumulated equalities+  , icSolved   :: S.HashSet Expr            -- ^ Terms that we have already expanded+  , icSimpl    :: !ConstMap                 -- ^ Map of expressions to constants+  , icSubcId   :: Maybe SubcId              -- ^ Current subconstraint ID+  }++----------------------------------------------------------------------------------------------+-- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId+----------------------------------------------------------------------------------------------++type InstRes = M.HashMap BindId Expr++----------------------------------------------------------------------------------------------+-- | @Unfold is the result of running PLE at a single equality;+--     (e, [(e1, e1')...]) is the source @e@ and the (possible empty)+--   list of PLE-generated equalities (e1, e1') ...+----------------------------------------------------------------------------------------------++type CTrie   = T.Trie   SubcId+type CBranch = T.Branch SubcId+type Diff    = [BindId]    -- ^ in "reverse" order++initCtx :: InstEnv a -> [(Expr,Expr)] -> ICtx+initCtx _   es   = ICtx+  { icCands  = mempty+  , icEquals = S.fromList es+  , icSolved = mempty+  , icSimpl  = mempty+  , icSubcId = Nothing+  }++equalitiesPred :: S.HashSet (Expr, Expr) -> [Expr]+equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- S.toList eqs, e1 /= e2 ]++updCtxRes :: InstRes -> Maybe BindId -> ICtx -> (ICtx, InstRes)+updCtxRes res iMb ctx = (ctx, res')+  where+    res' = updRes res iMb (pAnd $ equalitiesPred $ icEquals ctx)+++updRes :: InstRes -> Maybe BindId -> Expr -> InstRes+updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res+updRes res  Nothing _ = res+++----------------------------------------------------------------------------------------------+-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@+--   to the context.+----------------------------------------------------------------------------------------------++updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx+updCtx InstEnv{..} ctx delta cidMb+    = ctx { icCands  = S.fromList cands           <> icCands  ctx+          , icEquals = initEqs                    <> icEquals ctx+          , icSimpl  = M.fromList (S.toList sims) <> icSimpl ctx <> econsts+          , icSubcId = cidMb -- fst <$> L.find (\(_, b) -> (head delta) `memberIBindEnv` (_cenv b)) ieCstrs+          }                  -- eliminate above if nothing broken+  where+    initEqs   = S.fromList $ concat [rewrite e rw | e  <- cands ++ (snd <$> S.toList (icEquals ctx))+                                                  , rw <- snd <$> M.toList (knSims ieKnowl)]+    cands     = concatMap (makeCandidates ieKnowl ctx) (rhs:es)+    sims      = S.filter (isSimplification (knDCs ieKnowl)) (initEqs <> icEquals ctx)+    econsts   = M.fromList $ findConstants ieKnowl es+    rhs       = unElab eRhs+    es        = unElab . expr <$> [ (x, y) | (x, y,_ ) <- binds ]+    eRhs      = maybe PTrue crhs subMb+    binds     = [ lookupBindEnv i ieBEnv | i <- delta ]+    subMb     = getCstr ieCstrs <$> cidMb+++findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)]+findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)]+  where+    go su ess = if ess == ess'+                  then su+                  else go (su ++ su') ess'+       where ess' = subst (mkSubst su') <$> ess+             su'  = makeSu ess+    makeSu exprs  = [(x,c) | (EEq (EVar x) c) <- exprs+                           , isConstant (knDCs γ) c+                           , EVar x /= c ]++makeCandidates :: Knowledge -> ICtx -> Expr -> [Expr]+makeCandidates γ ctx expr+  = mytracepp ("\n" ++ show (length cands) ++ " New Candidates") cands+  where+    cands =+      filter (\e -> isRedex γ e && not (e `S.member` icSolved ctx)) (notGuardedApps expr) +++      filter (\e -> hasConstructors γ e && not (e `S.member` icSolved ctx)) (largestApps expr)++    -- Constructor occurrences need to be considered as candidadates since+    -- they identify relevant measure equations. The function 'rewrite'+    -- introduces these equations.+    hasConstructors :: Knowledge -> Expr -> Bool+    hasConstructors γ e =  not $ S.null $ S.intersection (exprSymbolsSet e) (knDCs γ)++isRedex :: Knowledge -> Expr -> Bool+isRedex γ e = isGoodApp γ e || isIte e+  where+    isIte EIte {} = True+    isIte _       = False+++isGoodApp :: Knowledge -> Expr -> Bool+isGoodApp γ e+  | (EVar f, es) <- splitEApp e+  , Just i       <- L.lookup f (knSummary γ)+  = length es >= i+  | otherwise+  = False+++++getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a+getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env++isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool+isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv)++type EvAccum = S.HashSet (Expr, Expr)++--------------------------------------------------------------------------------+data EvalEnv = EvalEnv+  { evEnv      :: !SymEnv+  , evAccum    :: EvAccum+  }++type EvalST a = StateT EvalEnv IO a+--------------------------------------------------------------------------------+++evalOne :: ConstMap -> Knowledge -> EvalEnv -> ICtx -> Expr -> IO EvAccum+evalOne ienv γ env ctx e {- null (getAutoRws γ ctx) -} = do+    (e', st) <- runStateT (fastEval ienv γ ctx e) env+    let evAcc' = if mytracepp ("evalOne: " ++ showpp e) e' == e then evAccum st else S.insert (e, e') (evAccum st)+    return evAcc'++notGuardedApps :: Expr -> [Expr]+notGuardedApps = flip go []+  where+    go e0 acc = case e0 of+      EApp e1 e2 -> e0 : go e1 (go e2 acc)+      PAnd es    -> foldr go acc es+      POr es     -> foldr go acc es+      PAtom _ e1 e2 -> go e1 $ go e2 acc+      PIff e1 e2 -> go e1 $ go e2 acc+      PImp e1 e2 -> go e1 $ go e2 acc+      EBin  _ e1 e2 -> go e1 $ go e2 acc+      PNot e -> go e acc+      ENeg e -> go e acc+      EIte b _ _ -> go b $ e0 : acc+      ECoerc _ _ e -> go e acc+      ECst e _ -> go e acc+      ESym _ -> acc+      ECon _ -> acc+      EVar _ -> acc+      ELam _ _ -> acc+      ETApp _ _ -> acc+      ETAbs _ _ -> acc+      PKVar _ _ -> acc+      PAll _ _ -> acc+      PExist _ _ -> acc+      PGrad{} -> acc++largestApps :: Expr -> [Expr]+largestApps = flip go []+  where+    go e0 acc = case e0 of+      EApp _ _ -> e0 : acc+      PAnd es -> foldr go acc es+      POr es -> foldr go acc es+      PAtom _ e1 e2 -> go e1 $ go e2 acc+      PIff e1 e2 -> go e1 $ go e2 acc+      PImp e1 e2 -> go e1 $ go e2 acc+      EBin  _ e1 e2 -> go e1 $ go e2 acc+      PNot e -> go e acc+      ENeg e -> go e acc+      EIte b _ _ -> go b $ e0 : acc+      ECoerc _ _ e -> go e acc+      ECst e _ -> go e acc+      ESym _ -> acc+      ECon _ -> acc+      EVar _ -> e0 : acc+      ELam _ _ -> acc+      ETApp _ _ -> acc+      ETAbs _ _ -> acc+      PKVar _ _ -> acc+      PAll _ _ -> acc+      PExist _ _ -> acc+      PGrad{} -> acc++fastEval :: ConstMap -> Knowledge -> ICtx -> Expr -> EvalST Expr+fastEval ienv γ ctx e+    = do env  <- gets (seSort . evEnv)+         return $ mytracepp ("evaluating" ++ show e) $ interpret ienv γ ctx env $ simplify γ ctx e++--------------------------------------------------------------------------------+-- | 'substEq' unfolds or instantiates an equation at a particular list of+--   argument values. We must also substitute the sort-variables that appear+--   as coercions. See tests/proof/ple1.fq+--------------------------------------------------------------------------------++unfoldExpr :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> {-EvalST-} Expr+unfoldExpr ie γ ctx env (EIte e0 e1 e2) = let g' = interpret' ie γ ctx env e0 in+                                             if g' == PTrue+                                                then unfoldExpr ie γ ctx env e1+                                                else if g' == PFalse+                                                        then unfoldExpr ie γ ctx env e2+                                                        else EIte g' e1 e2+unfoldExpr _  _ _   _   e               = e++substEq :: SEnv Sort -> Equation -> [Expr] -> Expr+substEq env eq es = subst su (substEqCoerce env eq es)+  where su = mkSubst $ zip (eqArgNames eq) es++substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr+substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq+  where+    ts    = snd    <$> eqArgs eq+    sp    = panicSpan "mkCoSub"+    eTs   = sortExpr sp env <$> es+    coSub = mkCoSub env eTs ts++mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub+mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ]+  where+    unite ts    = Mb.fromMaybe (uError ts) (unifyTo1 senv ts)+    senv        = mkSearchEnv env+    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts)+    xys         = Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs+    (_xTs,_eTs) = (xTs, eTs)++matchSorts :: Sort -> Sort -> [(Symbol, Sort)]+matchSorts s1 s2 = go s1 s2+  where+    go (FObj x)      {-FObj-} y    = [(x, y)]+    go (FAbs _ t1)   (FAbs _ t2)   = go t1 t2+    go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2+    go (FApp s1 t1)  (FApp s2 t2)  = go s1 s2 ++ go t1 t2+    go _             _             = []++--------------------------------------------------------------------------------++eqArgNames :: Equation -> [Symbol]+eqArgNames = map fst . eqArgs++interpret' :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> Expr+interpret' ie γ ctx env e = mytracepp ("Interpreting " ++ show e) $ interpret ie γ ctx env e++interpret :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> Expr+interpret _  _ _   _   e@(ESym _)       = e+interpret _  _ _   _   e@(ECon _)       = e+interpret ie γ ctx env (EVar sym)+    | Just e' <- M.lookup (EVar sym) (icSimpl ctx)+    = interpret' ie γ ctx env e'+interpret _  _ _   _   e@(EVar _)       = e+interpret ie γ ctx env   (EApp e1 e2)+  | isSetPred e1                        = let e2' = interpret' ie γ ctx env e2 in+                                             applySetFolding e1 e2'+interpret ie γ ctx env e@(EApp _ _)     = case splitEApp e of+  (f, es) -> let g = interpret' ie γ ctx env in+    interpretApp ie γ ctx env (g f) (map g es)+    where+      interpretApp ie γ ctx env (EVar f) es+        | Just eq <- M.lookup f (knAms γ)+        , length (eqArgs eq) <= length es+        = let (es1,es2) = splitAt (length (eqArgs eq)) es+              ges       = substEq env eq es1+              exp       = unfoldExpr ie γ ctx env ges+              exp'      = eApps exp es2 in  --exp' -- TODO undo+            if eApps (EVar f) es == exp' then exp' else interpret' ie γ ctx env exp'++      interpretApp ie γ ctx env (EVar f) (e1:es)+        | (EVar dc, as) <- splitEApp e1+        , Just rw <- M.lookup (f, dc) (knSims γ)+        , length as == length (smArgs rw)+        = let e' = eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es in --e' -- TODO undo+            if eApps (EVar f) es == e' then e' else interpret' ie γ ctx env e'++      interpretApp _  γ _   _   (EVar f) [e0]+        | (EVar dc, _as) <- splitEApp e0+        , isTestSymbol f+        = if testSymbol dc == f then PTrue else+            if S.member dc (knAllDCs γ) then PFalse else {-simplify γ ctx $-} eApps (EVar f) [e0]++      interpretApp _  _ _   _   f        es     = {-simplify γ ctx $-} eApps f es+interpret ie γ ctx env   (ENeg e1)      = let e1' = interpret' ie γ ctx env e1 in+                                            applyConstantFolding Minus (ECon (I 0)) e1'+--                                          simplify γ ctx (ENeg e1')+interpret ie γ ctx env   (EBin o e1 e2) = let e1' = interpret' ie γ ctx env e1+                                              e2' = interpret' ie γ ctx env e2 in+                                            applyConstantFolding o e1' e2'+--                                          simplify γ ctx (EBin o e1' e2')+interpret ie γ ctx env   (EIte g e1 e2) = let b = interpret' ie γ ctx env g in+                                            if b == PTrue then interpret' ie γ ctx env e1 else+                                              if b == PFalse then interpret' ie γ ctx env e2 else+                                                simplify γ ctx $ EIte b e1 e2+--                                          EIte b (interpret' γ ctx env e1) (interpret' γ ctx env e2)+interpret ie γ ctx env   (ECst e1 s)    = let e1' = interpret' ie γ ctx env e1 in+                                            simplifyCasts e1' s -- ECst e1' s+interpret ie γ ctx env (ELam (x,s) e)   = let γ' = γ { knLams = (x, s) : knLams γ }+                                              e' = interpret' ie γ' ctx env e in+                                            ELam (x, s) e'+interpret ie γ ctx env   (ETApp e1 t)   = let e1' = interpret' ie γ ctx env e1 in ETApp e1' t+interpret ie γ ctx env   (ETAbs e1 sy)  = let e1' = interpret' ie γ ctx env e1 in ETAbs e1' sy+interpret ie γ ctx env   (PAnd es)      = let es' = map (interpret' ie γ ctx env) es in go [] (reverse es')+  where+    go []  []         = PTrue+    go [p] []         = interpret' ie γ ctx env p+    go acc []         = PAnd acc+    go acc (PTrue:es) = go acc es+    go _   (PFalse:_) = PFalse+    go acc (e:es)     = go (e:acc) es+interpret ie γ ctx env (POr es)         = let es' = map (interpret' ie γ ctx env) es in go [] (reverse es')+  where+    go []  []          = PFalse+    go [p] []          = interpret' ie γ ctx env p+    go acc []          = POr acc+    go _   (PTrue:_)   = PTrue+    go acc (PFalse:es) = go acc es+    go acc (e:es)      = go (e:acc) es+interpret ie γ ctx env (PNot e)         = let e' = interpret' ie γ ctx env e in case e' of+    (PNot e'')    -> e''+    PTrue         -> PFalse+    PFalse        -> PTrue+    _             -> PNot e'+interpret ie γ ctx env (PImp e1 e2)     = let e1' = interpret' ie γ ctx env e1+                                              e2' = interpret' ie γ ctx env e2 in+                                            if e1' == PFalse || e2' == PTrue then PTrue else+                                              if e1' == PTrue then e2' else+                                                if e2' == PFalse then interpret' ie γ ctx env (PNot e1') else+                                                  PImp e1' e2'+interpret ie γ ctx env (PIff e1 e2)     = let e1' = interpret' ie γ ctx env e1+                                              e2' = interpret' ie γ ctx env e2 in+                                            if e1' == PTrue then e2' else+                                              if e2' == PTrue then e1' else+                                                if e1' == PFalse then interpret' ie γ ctx env (PNot e2') else+                                                  if e2' == PFalse then interpret' ie γ ctx env (PNot e1') else+                                                    PIff e1' e2'+interpret ie γ ctx env (PAtom o e1 e2)  = let e1' = interpret' ie γ ctx env e1+                                              e2' = interpret' ie γ ctx env e2 in+                                            applyBooleanFolding o e1' e2'+interpret _  _ _   _   e@(PKVar _ _)    = e+interpret ie γ ctx env e@(PAll xss e1)  = case xss of+  [] -> interpret' ie γ ctx env e1+  _  -> e+interpret ie γ ctx env e@(PExist xss e1) = case xss of+  [] -> interpret' ie γ ctx env e1+  _  -> e+interpret _  _ _   _   e@PGrad{}         = e+interpret ie γ ctx env (ECoerc s t e)    = let e' = interpret' ie γ ctx env e in+                                             if s == t then e' else ECoerc s t e'+++--------------------------------------------------------------------------------+-- | Knowledge (SMT Interaction)+--------------------------------------------------------------------------------+data Knowledge = KN+  { knSims              :: M.HashMap (Symbol, Symbol) Rewrite  -- ^ Rewrite rules came from match and data type definitions+  , knAms               :: M.HashMap Symbol Equation  -- ^ All function definitions -- restore ! here?+  , knLams              :: ![(Symbol, Sort)]+  , knSummary           :: ![(Symbol, Int)]     -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity+  , knDCs               :: !(S.HashSet Symbol)  -- ^ data constructors drawn from Rewrite+  , knAllDCs            :: !(S.HashSet Symbol)  -- ^+  , knSels              :: !SelectorMap+  , knConsts            :: !ConstDCMap+  }++knowledge :: SInfo a -> Knowledge+knowledge si = KN+  { knSims                     = M.fromList $ (\r -> ((smName r, smDC r), r)) <$> sims+  , knAms                      = M.fromList $ (\a -> (eqName a, a)) <$> aenvEqs aenv+  , knLams                     = []+  , knSummary                  =    ((\s -> (smName s, 1)) <$> sims)+                                 ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv)+  , knDCs                      = S.fromList (smDC <$> sims)  <> constNames si+  , knAllDCs                   = S.fromList $ val . dcName <$> concatMap ddCtors (ddecls si)+  , knSels                     = M.fromList $ Mb.mapMaybe makeSel  sims+  , knConsts                   = M.fromList $ Mb.mapMaybe makeCons sims+  }+  where+    sims = aenvSimpl aenv+    aenv = ae si++    makeCons rw+      | null (syms $ smBody rw)+      = Just (smName rw, (smDC rw, smBody rw))+      | otherwise+      = Nothing++    makeSel rw+      | EVar x <- smBody rw+      = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw)+      | otherwise+      = Nothing++    constNames si = (S.fromList . map fst . toListSEnv . gLits $ si) `S.union`+                      (S.fromList . map fst . toListSEnv . dLits $ si)+-- testSymbol (from names)+++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++-- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi,+-- i.e., sel_i selects the ith value for the data constructor D+type SelectorMap = M.HashMap Symbol (Symbol, Int)+type ConstDCMap  = M.HashMap Symbol (Symbol, Expr)++-- ValueMap maps expressions to constants (including data constructors)+type ConstMap = M.HashMap Expr Expr+type LDataCon = Symbol              -- Data Constructors++isSimplification :: S.HashSet LDataCon -> (Expr,Expr) -> Bool+isSimplification dcs (_,c) = isConstant dcs c++isConstant :: S.HashSet LDataCon -> Expr -> Bool+isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs)++class Simplifiable a where+  simplify :: Knowledge -> ICtx -> a -> a+++instance Simplifiable Expr where+  simplify γ ictx e = mytracepp ("simplification of " ++ show e) $ fix (Vis.mapExpr tx) e+    where+      fix f e = if e == e' then e else fix f e' where e' = f e+      tx e+        | Just e' <- M.lookup e (icSimpl ictx)+        = e'++      tx (PAtom rel e1 e2) = applyBooleanFolding rel e1 e2+      tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2+      tx (ENeg e)         = applyConstantFolding Minus (ECon (I 0)) e+      tx (EApp e1 e2)+        | isSetPred e1    = applySetFolding e1 e2++      tx (EApp (EVar f) a)+        | Just (dc, c)  <- M.lookup f (knConsts γ)+        , (EVar dc', _) <- splitEApp a+        , dc == dc'+        = c+      tx (EIte b e1 e2)+        | isTautoPred b  = e1+        | isContraPred b = e2+      tx (ECst e s)       = simplifyCasts e s+      tx (ECoerc s t e)+        | s == t = e+      tx (EApp (EVar f) a)+        | Just (dc, i)  <- M.lookup f (knSels γ)+        , (EVar dc', es) <- splitEApp a+        , dc == dc'+        = es!!i+      tx (PAnd es)         = go [] (reverse es)+        where+          go []  []     = PTrue+          go [p] []     = p+          go acc []     = PAnd acc+          go acc (e:es)+            | e == PTrue = go acc es+            | e == PFalse = PFalse+            | otherwise = go (e:acc) es+      tx (POr es)          = go [] (reverse es)+        where+          go []  []     = PFalse+          go [p] []     = p+          go acc []     = POr acc+          go acc (e:es)+            | e == PTrue = PTrue+            | e == PFalse = go acc es+            | otherwise = go (e:acc) es+      tx (PNot e)+        | e == PTrue = PFalse+        | e == PFalse = PTrue+        | otherwise = PNot e+      tx e = e++simplifyCasts :: Expr -> Sort -> Expr+simplifyCasts (ECon (I n)) FInt  = ECon (I n)+simplifyCasts (ECon (R x)) FReal = ECon (R x)+simplifyCasts e            s     = ECst e s++-------------------------------------------------------------------------------+-- | Normalization of Equation: make their arguments unique -------------------+-------------------------------------------------------------------------------++class Normalizable a where+  normalize :: a -> a++instance Normalizable (GInfo c a) where+  normalize si = si {ae = normalize $ ae si}++instance Normalizable AxiomEnv where+  normalize aenv = aenv { aenvEqs   = {-notracepp-} mytracepp "aenvEqs"   (normalize <$> aenvEqs   aenv)+                        , aenvSimpl = {-notracepp-} mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) }++instance Normalizable Rewrite where+  normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw }+    where+      su  = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'+      xs  = smArgs rw+      xs' = zipWith mkSymbol xs [0 :: Integer ..]+      mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i++instance Normalizable Equation where+  normalize eq = eq {eqArgs = zip xs' ss,+                     eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq }+    where+      su           = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'+      (xs,ss)      = unzip (eqArgs eq)+      xs'          = zipWith mkSymbol xs [0 :: Integer ..]+      mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i++normalizeBody :: Symbol -> Expr -> Expr+normalizeBody f = go+  where+    go e+      | elem f (syms e)+      = go' e+    go e+      = e++    go' (PAnd [PImp c e1,PImp (PNot c') e2])+      | c == c' = EIte c e1 (go' e2)+    go' e = e

src/Language/Fixpoint/Solver/Monad.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-}  -- | This is a wrapper around IO that permits SMT queries@@ -59,12 +58,12 @@ -- | Solver Monadic API -------------------------------------------------------- -------------------------------------------------------------------------------- -type SolveM = StateT SolverState IO+type SolveM ann = StateT (SolverState ann) IO -data SolverState = SS -  { ssCtx     :: !Context          -- ^ SMT Solver Context-  , ssBinds   :: !F.BindEnv        -- ^ All variables and types-  , ssStats   :: !Stats            -- ^ Solver Statistics+data SolverState ann = SS+  { ssCtx     :: !Context         -- ^ SMT Solver Context+  , ssBinds   :: !(F.BindEnv ann) -- ^ All variables and types+  , ssStats   :: !Stats           -- ^ Solver Statistics   }  stats0    :: F.GInfo c b -> Stats@@ -73,7 +72,7 @@     nCs   = M.size $ F.cm fi  ---------------------------------------------------------------------------------runSolverM :: Config -> SolverInfo b c -> SolveM a -> IO a+runSolverM :: Config -> SolverInfo ann c -> SolveM ann a -> IO a -------------------------------------------------------------------------------- runSolverM cfg sI act =   bracket acquire release $ \ctx -> do@@ -94,34 +93,34 @@   ---------------------------------------------------------------------------------getBinds :: SolveM F.BindEnv +getBinds :: SolveM ann (F.BindEnv ann) -------------------------------------------------------------------------------- getBinds = ssBinds <$> get  ---------------------------------------------------------------------------------getIter :: SolveM Int+getIter :: SolveM ann Int -------------------------------------------------------------------------------- getIter = numIter . ssStats <$> get  ---------------------------------------------------------------------------------incIter, incBrkt :: SolveM ()+incIter, incBrkt :: SolveM ann () -------------------------------------------------------------------------------- incIter   = modifyStats $ \s -> s {numIter = 1 + numIter s} incBrkt   = modifyStats $ \s -> s {numBrkt = 1 + numBrkt s}  ---------------------------------------------------------------------------------incChck, incVald :: Int -> SolveM ()+incChck, incVald :: Int -> SolveM ann () -------------------------------------------------------------------------------- incChck n = modifyStats $ \s -> s {numChck = n + numChck s} incVald n = modifyStats $ \s -> s {numVald = n + numVald s} -withContext :: (Context -> IO a) -> SolveM a+withContext :: (Context -> IO a) -> SolveM ann a withContext k = (lift . k) =<< getContext -getContext :: SolveM Context+getContext :: SolveM ann Context getContext = ssCtx <$> get -modifyStats :: (Stats -> Stats) -> SolveM ()+modifyStats :: (Stats -> Stats) -> SolveM ann () modifyStats f = modify $ \s -> s { ssStats = f (ssStats s) }  --------------------------------------------------------------------------------@@ -133,12 +132,12 @@ -- -- Yields the ids of bindings known to the SMT sendConcreteBindingsToSMT-  :: F.IBindEnv -> (F.IBindEnv -> SolveM a) -> SolveM a+  :: F.IBindEnv -> (F.IBindEnv -> SolveM ann a) -> SolveM ann a sendConcreteBindingsToSMT known act = do   be <- getBinds   let concretePreds =         [ (i, F.subst1 p (v, F.EVar s))-        | (i, s, F.RR _ (F.Reft (v, p))) <- F.bindEnvToList be+        | (i, (s, F.RR _ (F.Reft (v, p)),_)) <- F.bindEnvToList be         , F.isConc p         , not (isShortExpr p)         , not (F.memberIBindEnv i known)@@ -159,7 +158,7 @@ -- | `filterRequired [(x1, p1),...,(xn, pn)] q` returns a minimal list [xi] s.t. --   /\ [pi] => q ---------------------------------------------------------------------------------filterRequired :: F.Cand a -> F.Expr -> SolveM [a]+filterRequired :: F.Cand a -> F.Expr -> SolveM ann [a] -------------------------------------------------------------------------------- filterRequired = error "TBD:filterRequired" @@ -183,10 +182,10 @@ -}  ----------------------------------------------------------------------------------- | `filterValid p [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]`+-- | `filterValid p [(q1, x1),...,(qn, xn)]` returns the list `[ xi | p => qi]` -------------------------------------------------------------------------------- {-# SCC filterValid #-}-filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM [a]+filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM ann [a] -------------------------------------------------------------------------------- filterValid sp p qs = do   qs' <- withContext $ \me ->@@ -215,7 +214,7 @@ -- | `filterValidGradual ps [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]` -- | for some p in the list ps ---------------------------------------------------------------------------------filterValidGradual :: [F.Expr] -> F.Cand a -> SolveM [a]+filterValidGradual :: [F.Expr] -> F.Cand a -> SolveM ann [a] -------------------------------------------------------------------------------- filterValidGradual p qs = do   qs' <- withContext $ \me ->@@ -229,7 +228,7 @@  filterValidGradual_ :: [F.Expr] -> F.Cand a -> Context -> IO [a] filterValidGradual_ ps qs me-  = (map snd . fst) <$> foldM partitionCandidates ([], qs) ps+  = map snd . fst <$> foldM partitionCandidates ([], qs) ps   where     partitionCandidates :: (F.Cand a, F.Cand a) -> F.Expr -> IO (F.Cand a, F.Cand a)     partitionCandidates (ok, candidates) p = do@@ -244,14 +243,14 @@     smtBracket me "filterValidRHS" $ do       smtAssert me (F.PNot q)       valid <- smtCheckUnsat me-      return $ ((q, x), valid)+      return ((q, x), valid) -smtEnablembqi :: SolveM ()+smtEnablembqi :: SolveM ann () smtEnablembqi   = withContext smtSetMbqi  ---------------------------------------------------------------------------------checkSat :: F.Expr -> SolveM  Bool+checkSat :: F.Expr -> SolveM ann Bool -------------------------------------------------------------------------------- checkSat p   = withContext $ \me ->@@ -259,20 +258,20 @@         smtCheckSat me p  ---------------------------------------------------------------------------------assumesAxioms :: [F.Triggered F.Expr] -> SolveM ()+assumesAxioms :: [F.Triggered F.Expr] -> SolveM ann () -------------------------------------------------------------------------------- assumesAxioms es = withContext $ \me -> forM_  es $ smtAssertAxiom me   ----------------------------------------------------------------------------stats :: SolveM Stats+stats :: SolveM ann Stats --------------------------------------------------------------------------- stats = ssStats <$> get  ----------------------------------------------------------------------------tickIter :: Bool -> SolveM Int+tickIter :: Bool -> SolveM ann Int --------------------------------------------------------------------------- tickIter newScc = progIter newScc >> incIter >> getIter -progIter :: Bool -> SolveM ()+progIter :: Bool -> SolveM ann () progIter newScc = lift $ when newScc progressTick

src/Language/Fixpoint/Solver/PLE.hs view

@@ -1,1167 +1,1218 @@ ----------------------------------------------------------------------------------- | This module implements "Proof by Logical Evaluation" where we ---   unfold function definitions if they *must* be unfolded, to strengthen---   the environments with function-definition-equalities. ---   The algorithm is discussed at length in:--- ---     1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842---     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf -----------------------------------------------------------------------------------{-# LANGUAGE DeriveGeneric             #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE PartialTypeSignatures     #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ExistentialQuantification #-}--module Language.Fixpoint.Solver.PLE (instantiate) where--import           Language.Fixpoint.Types hiding (simplify)-import           Language.Fixpoint.Types.Config  as FC-import           Language.Fixpoint.Types.Solutions (CMap)-import qualified Language.Fixpoint.Types.Visitor as Vis-import qualified Language.Fixpoint.Misc          as Misc -import qualified Language.Fixpoint.Smt.Interface as SMT-import           Language.Fixpoint.Defunctionalize-import qualified Language.Fixpoint.Utils.Files   as Files-import qualified Language.Fixpoint.Utils.Trie    as T -import           Language.Fixpoint.Utils.Progress -import           Language.Fixpoint.SortCheck-import           Language.Fixpoint.Graph.Deps             (isTarget) -import           Language.Fixpoint.Solver.Sanitize        (symbolEnv)-import           Language.Fixpoint.Solver.Rewrite--import Language.REST.AbstractOC as OC-import Language.REST.ExploredTerms as ET-import Language.REST.RuntimeTerm as RT-import Language.REST.OrderingConstraints.ADT (ConstraintsADT)-import Language.REST.Op-import Language.REST.SMT (withZ3, SolverHandle)--import           Control.Monad.State-import           Control.Monad.Trans.Maybe-import           Data.Bifunctor (second)-import qualified Data.HashMap.Strict  as M-import qualified Data.HashSet         as S-import qualified Data.List            as L-import           Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Maybe           as Mb-import qualified Data.Text            as Tx-import           Debug.Trace          (trace)-import           Text.PrettyPrint.HughesPJ.Compat---- Type of Ordering Constraints for REST-type OCType = ConstraintsADT--mytracepp :: (PPrint a) => String -> a -> a-mytracepp = notracepp--traceE :: (Expr,Expr) -> (Expr,Expr)-traceE (e,e')-  | isEnabled-  , e /= e'-  = trace ("\n" ++ showpp e ++ " ~> " ++ showpp e') (e,e')-  | otherwise-  = (e,e')-  where-    isEnabled :: Bool-    isEnabled = False------------------------------------------------------------------------------------- | Strengthen Constraint Environments via PLE ----------------------------------------------------------------------------------{-# SCC instantiate #-}-instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)-instantiate cfg fi' subcIds = do-    let cs = M.filterWithKey-               (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds)-               (cm fi)-    let t  = mkCTrie (M.toList cs)                                          -- 1. BUILD the Trie-    res   <- withRESTSolver $ \solver -> withProgress (1 + M.size cs) $-               withCtx cfg file sEnv (pleTrie t . instEnv cfg fi cs solver) -- 2. TRAVERSE Trie to compute InstRes-    savePLEEqualities cfg fi res-    return $ resSInfo cfg sEnv fi res                                       -- 3. STRENGTHEN SInfo using InstRes-  where-    withRESTSolver :: (Maybe SolverHandle -> IO a) -> IO a-    withRESTSolver f | null (concat $ M.elems $ aenvAutoRW aEnv) = f Nothing-    withRESTSolver f | otherwise = withZ3 (\z3 -> f (Just z3))--    file   = srcFile cfg ++ ".evals"-    sEnv   = symbolEnv cfg fi-    aEnv   = ae fi -    fi     = normalize fi' --savePLEEqualities :: Config -> SInfo a -> InstRes -> IO ()-savePLEEqualities cfg fi res = when (save cfg) $ do-    let fq   = queryFile Files.Fq cfg ++ ".ple"-    putStrLn $ "\nSaving PLE equalities: "   ++ fq ++ "\n"-    Misc.ensurePath fq-    let constraint_equalities =-          map equalitiesPerConstraint $ Misc.hashMapToAscList $ cm fi-    writeFile fq $ render $ vcat $-      map renderConstraintRewrite constraint_equalities-  where-    equalitiesPerConstraint (cid, c) =-      (cid, L.sort [ e | i <- elemsIBindEnv (senv c), Just e <- [M.lookup i res] ])-    renderConstraintRewrite (cid, eqs) =-      "constraint id" <+> text (show cid ++ ":")-      $+$ nest 2 (toFix (pAnd eqs))-      $+$ ""--------------------------------------------------------------------------------- --- | Step 1a: @instEnv@ sets up the incremental-PLE environment -instEnv :: (Loc a) => Config -> SInfo a -> CMap (SimpC a) -> Maybe SolverHandle -> SMT.Context -> InstEnv a-instEnv cfg fi cs restSolver ctx = InstEnv cfg ctx bEnv aEnv cs γ s0-  where-    bEnv              = bs fi-    aEnv              = ae fi-    γ                 = knowledge cfg ctx fi  -    s0                = EvalEnv (SMT.ctxSymEnv ctx) mempty (defFuelCount cfg) et restSolver-    et                = fmap makeET restSolver-    makeET solver     =-      ET.empty (EF (OC.union (ordConstraints solver)) (OC.notStrongerThan (ordConstraints solver)))------------------------------------------------------------------------------------------------ --- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments------ The trie is a way to unfold the equalities a minimum number of times.--- Say you have------ > 1: [1, 2, 3, 4, 5] => p1--- > 2: [1, 2, 3, 6, 7] => p2------ Then you build the tree------ >  1 -> 2 -> 3 -> 4 -> 5 — [Constraint 1]--- >            | -> 6 -> 7 — [Constraint 2]------ which you use to unfold everything in 1, 2, and 3 once (instead of twice)--- and with the proper existing environment----mkCTrie :: [(SubcId, SimpC a)] -> CTrie -mkCTrie ics  = T.fromList [ (cBinds c, i) | (i, c) <- ics ]-  where-    cBinds   = L.sort . elemsIBindEnv . senv ------------------------------------------------------------------------------------------------ --- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE-pleTrie :: CTrie -> InstEnv a -> IO InstRes-pleTrie t env = loopT env ctx0 diff0 Nothing res0 t -  where -    diff0        = []-    res0         = M.empty -    ctx0         = initCtx env ((mkEq <$> es0) ++ (mkEq' <$> es0'))-    es0          = L.filter (null . eqArgs) (aenvEqs   . ieAenv $ env)-    es0'         = L.filter (null . smArgs) (aenvSimpl . ieAenv $ env)-    mkEq  eq     = (EVar $ eqName eq, eqBody eq)-    mkEq' rw     = (EApp (EVar $ smName rw) (EVar $ smDC rw), smBody rw)--loopT-  :: InstEnv a-  -> ICtx-  -> Diff         -- ^ The longest path suffix without forks in reverse order-  -> Maybe BindId -- ^ bind id of the branch ancestor of the trie if any.-                  --   'Nothing' when this is the top-level trie.-  -> InstRes-  -> CTrie-  -> IO InstRes-loopT env ctx delta i res t = case t of-  T.Node []  -> return res-  T.Node [b] -> loopB env ctx delta i res b-  T.Node bs  -> withAssms env ctx delta Nothing $ \ctx' -> do -                  (ctx'', res') <- ple1 env ctx' i res -                  foldM (loopB env ctx'' [] i) res' bs--loopB-  :: InstEnv a-  -> ICtx-  -> Diff         -- ^ The longest path suffix without forks in reverse order-  -> Maybe BindId -- ^ bind id of the branch ancestor of the branch if any.-                  --   'Nothing' when this is a branch of the top-level trie.-  -> InstRes-  -> CBranch-  -> IO InstRes-loopB env ctx delta iMb res b = case b of-  T.Bind i t -> loopT env ctx (i:delta) (Just i) res t-  T.Val cid  -> withAssms env ctx delta (Just cid) $ \ctx' -> do -                  progressTick-                  (snd <$> ple1 env ctx' iMb res) ---- | Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@--- and the rhs of @cidMb@.------ Adds to @ctx@ assumptions from @env@ and @delta@ plus rewrites that--- candidates can use.------ Sets the current constraint id in @ctx@ to @cidMb@.------ Pushes assumptions from the modified context to the SMT solver, runs @act@,--- and then pops the assumptions.----withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b -withAssms env@(InstEnv {..}) ctx delta cidMb act = do-  let ctx'  = updCtx env ctx delta cidMb -  let assms = icAssms ctx'-  SMT.smtBracket ieSMT  "PLE.evaluate" $ do-    forM_ assms (SMT.smtAssert ieSMT) -    act ctx' { icAssms = mempty }---- | @ple1@ performs the PLE at a single "node" in the Trie -ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstRes)-ple1 (InstEnv {..}) ctx i res = -  updCtxRes res i <$> evalCandsLoop ieCfg ctx ieSMT ieKnowl ieEvEnv---evalToSMT :: String -> Config -> SMT.Context -> (Expr, Expr) -> Pred -evalToSMT msg cfg ctx (e1,e2) = toSMT ("evalToSMT:" ++ msg) cfg ctx [] (EEq e1 e2)--evalCandsLoop :: Config -> ICtx -> SMT.Context -> Knowledge -> EvalEnv -> IO ICtx -evalCandsLoop cfg ictx0 ctx γ env = go ictx0 0-  where-    withRewrites exprs =-      let-        rws = [rewrite e (knSims γ) | e <- S.toList (snd `S.map` exprs)]-      in -        exprs <> (S.fromList $ concat rws)-    go ictx _ | S.null (icCands ictx) = return ictx-    go ictx i =  do-                  let cands = icCands ictx-                  let env' = env { evAccum = icEquals ictx <> evAccum env -                                 , evFuel  = icFuel   ictx -                                 }-                  (ictx', evalResults)  <- do-                               SMT.smtAssert ctx (pAndNoDedup (S.toList $ icAssms ictx))-                               let ictx' = ictx { icAssms = mempty }-                               foldM (evalOneCandStep γ env' i) (ictx', []) (S.toList cands)-                               -- foldM (\ictx e -> undefined) -                               -- mapM (evalOne γ env' ictx) (S.toList cands)-                  let us = mconcat evalResults -                  if S.null (us `S.difference` icEquals ictx)-                        then return ictx -                        else do  let oks      = fst `S.map` us-                                 let us'      = withRewrites us -                                 let eqsSMT   = evalToSMT "evalCandsLoop" cfg ctx `S.map` us'-                                 let ictx''   = ictx' { icSolved = icSolved ictx <> oks -                                                      , icEquals = icEquals ictx <> us'-                                                      , icAssms  = S.filter (not . isTautoPred) eqsSMT }-                                 let newcands = mconcat (makeCandidates γ ictx'' <$> S.toList (cands <> (snd `S.map` us)))-                                 go (ictx'' { icCands = S.fromList newcands}) (i + 1)-                                 -evalOneCandStep :: Knowledge -> EvalEnv -> Int -> (ICtx, [EvAccum]) -> Expr -> IO (ICtx, [EvAccum])-evalOneCandStep γ env' i (ictx, acc) e = do-  (res, fm) <- evalOne γ env' ictx i e-  return (ictx { icFuel = fm}, res : acc)--rewrite :: Expr -> Map Symbol [Rewrite] -> [(Expr,Expr)] -rewrite e rwEnv = concat $ map (`rewriteTop` rwEnv) (notGuardedApps e)--rewriteTop :: Expr -> Map Symbol [Rewrite] -> [(Expr,Expr)]-rewriteTop e rwEnv =-  [ (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw))-  | (EVar f, es) <- [splitEApp e]-  , Just rws <- [Map.lookup f rwEnv]-  , rw <- rws-  , length es == length (smArgs rw)-  ]------------------------------------------------------------------------------------------------ --- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo ----------------------------------------------------------------------------------------------- --resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a-resSInfo cfg env fi res = strengthenBinds fi res' -  where-    res'     = M.fromList $ zip is ps''-    ps''     = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' -    ps'      = defuncAny cfg env ps-    (is, ps) = unzip (M.toList res)------------------------------------------------------------------------------------------------ --- | @InstEnv@ has the global information needed to do PLE----------------------------------------------------------------------------------------------- --data InstEnv a = InstEnv -  { ieCfg   :: !Config-  , ieSMT   :: !SMT.Context-  , ieBEnv  :: !BindEnv-  , ieAenv  :: !AxiomEnv -  , ieCstrs :: !(CMap (SimpC a))-  , ieKnowl :: !Knowledge-  , ieEvEnv :: !EvalEnv-  } ------------------------------------------------------------------------------------------------ --- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE----------------------------------------------------------------------------------------------- --data ICtx    = ICtx -  { icAssms    :: S.HashSet Pred            -- ^ Equalities converted to SMT format-  , icCands    :: S.HashSet Expr            -- ^ "Candidates" for unfolding-  , icEquals   :: EvAccum                   -- ^ Accumulated equalities-  , icSolved   :: S.HashSet Expr            -- ^ Terms that we have already expanded-  , icSimpl    :: !ConstMap                 -- ^ Map of expressions to constants-  , icSubcId   :: Maybe SubcId              -- ^ Current subconstraint ID-  , icFuel     :: !FuelCount                -- ^ Current fuel-count-  , icANFs     :: S.HashSet Pred            -- Hopefully contain only ANF things-  } ------------------------------------------------------------------------------------------------ --- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId----------------------------------------------------------------------------------------------- --type InstRes = M.HashMap BindId Expr------------------------------------------------------------------------------------------------ --- | @Unfold is the result of running PLE at a single equality; ---     (e, [(e1, e1')...]) is the source @e@ and the (possible empty) ---   list of PLE-generated equalities (e1, e1') ... ----------------------------------------------------------------------------------------------- --type CTrie   = T.Trie   SubcId-type CBranch = T.Branch SubcId-type Diff    = [BindId]    -- ^ in "reverse" order--initCtx :: InstEnv a -> [(Expr,Expr)] -> ICtx-initCtx env es   = ICtx -  { icAssms  = mempty -  , icCands  = mempty -  , icEquals = S.fromList es-  , icSolved = mempty-  , icSimpl  = mempty -  , icSubcId = Nothing-  , icFuel   = evFuel (ieEvEnv env)-  , icANFs   = mempty-  }--equalitiesPred :: S.HashSet (Expr, Expr) -> [Expr]-equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- S.toList eqs, e1 /= e2 ] --updCtxRes :: InstRes -> Maybe BindId -> ICtx -> (ICtx, InstRes) -updCtxRes res iMb ctx = (ctx, res')-  where -    res' = updRes res iMb (pAnd $ equalitiesPred $ icEquals ctx)---updRes :: InstRes -> Maybe BindId -> Expr -> InstRes-updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res-updRes res  Nothing _ = res ------------------------------------------------------------------------------------------------ --- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ ---   to the context. ----------------------------------------------------------------------------------------------- --updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx-updCtx InstEnv {..} ctx delta cidMb -              = ctx { icAssms  = S.fromList (filter (not . isTautoPred) ctxEqs)  -                    , icCands  = S.fromList cands           <> icCands  ctx-                    , icEquals = initEqs                    <> icEquals ctx-                    , icSimpl  = M.fromList (S.toList sims) <> icSimpl ctx <> econsts-                    , icSubcId = cidMb-                    , icANFs   = anfs <> icANFs ctx-                    }-  where         -    initEqs   = S.fromList $ concat [rewrite e (knSims ieKnowl) | e  <- cands]-    anfs      = S.fromList (toSMT "updCtx" ieCfg ieSMT [] <$> L.nub [ expr xr | xr <- bs ])-    cands     = concatMap (makeCandidates ieKnowl ctx) (rhs:es)-    sims      = S.filter (isSimplification (knDCs ieKnowl)) (initEqs <> icEquals ctx)-    econsts   = M.fromList $ findConstants ieKnowl es-    ctxEqs    = toSMT "updCtx" ieCfg ieSMT [] <$> L.nub (concat-                  [ equalitiesPred initEqs -                  , equalitiesPred sims -                  , equalitiesPred (icEquals ctx)-                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]-                  ])-    bs        = second unElabSortedReft <$> binds-    (rhs:es)  = unElab <$> (eRhs : (expr <$> binds))-    eRhs      = maybe PTrue crhs subMb-    binds     = [ lookupBindEnv i ieBEnv | i <- delta ]-    subMb     = getCstr ieCstrs <$> cidMb---findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)]-findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)]  -  where -    go su ess = if ess == ess' -                  then su -                  else go (su ++ su') ess' -       where ess' = subst (mkSubst su') <$> ess-             su'  = makeSu ess -    makeSu exprs  = [(x,c) | (EEq (EVar x) c) <- exprs -                           , isConstant (knDCs γ) c-                           , EVar x /= c ]--makeCandidates :: Knowledge -> ICtx -> Expr -> [Expr]-makeCandidates γ ctx expr -  = mytracepp ("\n" ++ show (length cands) ++ " New Candidates") cands-  where -    cands = filter (\e -> isRedex γ e && not (e `S.member` icSolved ctx)) (notGuardedApps expr)--isRedex :: Knowledge -> Expr -> Bool -isRedex γ e = isGoodApp γ e || isIte e -  where -    isIte EIte {} = True -    isIte _       = False ---isGoodApp :: Knowledge -> Expr -> Bool -isGoodApp γ e -  | (EVar f, es) <- splitEApp e-  , Just i       <- L.lookup f (knSummary γ)-  = length es >= i-  | otherwise-  = False -    ----getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a -getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env--isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool-isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) --type EvAccum = S.HashSet (Expr, Expr)-----------------------------------------------------------------------------------data EvalEnv = EvalEnv-  { evEnv      :: !SymEnv-  , evAccum    :: EvAccum-  , evFuel     :: FuelCount--  -- REST parameters-  , explored   :: Maybe (ExploredTerms RuntimeTerm (OCType Op) IO)-  , restSolver :: Maybe SolverHandle-  }--data FuelCount = FC -  { fcMap :: M.HashMap Symbol Int-  , fcMax :: Maybe Int-  } -  deriving (Show)--defFuelCount :: Config -> FuelCount-defFuelCount cfg = FC mempty (fuel cfg)--type EvalST a = StateT EvalEnv IO a------------------------------------------------------------------------------------getAutoRws :: Knowledge -> ICtx -> [AutoRewrite]-getAutoRws γ ctx =-  Mb.fromMaybe [] $ do-    cid <- icSubcId ctx-    M.lookup cid $ knAutoRWs γ--evalOne :: Knowledge -> EvalEnv -> ICtx -> Int -> Expr -> IO (EvAccum, FuelCount)-evalOne γ env ctx i e | i > 0 || null (getAutoRws γ ctx) = do-    ((e', _), st) <- runStateT (eval γ ctx NoRW e) (env { evFuel = icFuel ctx })-    let evAcc' = if (mytracepp ("evalOne: " ++ showpp e) e') == e then evAccum st else S.insert (e, e') (evAccum st)-    return (evAcc', evFuel st) -evalOne γ env ctx _ e | otherwise = do-  env' <- execStateT (evalREST γ ctx rp) (env { evFuel = icFuel ctx })-  return (evAccum env', evFuel env')-  where-    oc :: AbstractOC (OCType Op) Expr IO-    oc = ordConstraints (Mb.fromJust $ restSolver env)--    rp = RP oc [(e, PLE)] constraints-    constraints = foldl go (OC.top oc) []-      where-        go c (t, u) = refine oc c t u----- | @notGuardedApps e@ yields all the subexpressions that are--- applications not under an if-then-else, lambda abstraction, type abstraction,--- type application, or quantifier.-notGuardedApps :: Expr -> [Expr]-notGuardedApps = go -  where -    go e@(EApp e1 e2)  = [e] ++ go e1 ++ go e2-    go (PAnd es)       = concatMap go es-    go (POr es)        = concatMap go es-    go (PAtom _ e1 e2) = go e1  ++ go e2-    go (PIff e1 e2)    = go e1  ++ go e2-    go (PImp e1 e2)    = go e1  ++ go e2 -    go (EBin  _ e1 e2) = go e1  ++ go e2-    go (PNot e)        = go e-    go (ENeg e)        = go e-    go e@(EIte b _ _)  = go b ++ [e] -- ++ go e1 ++ go e2  -    go (ECoerc _ _ e)  = go e -    go (ECst e _)      = go e -    go (ESym _)        = []-    go (ECon _)        = []-    go (EVar _)        = []-    go (ELam _ _)      = []-    go (ETApp _ _)     = []-    go (ETAbs _ _)     = []-    go (PKVar _ _)     = []-    go (PAll _ _)      = []-    go (PExist _ _)    = []-    go (PGrad{})       = []------ The FuncNormal and RWNormal evaluation strategies are used for REST--- For example, consider the following function:---   add(x, y) = if x == 0 then y else add(x - 1, y + 1)--- And a rewrite rule:---   forall a, b . add(a,b) -> add(b, a)--- Then the expression add(t, add(2, 1)) would evaluate under NoRW to:---   if t == 0 then 3 else add(t - 1, 4)--- However, under FuncNormal, it would evaluate to: add(t, 3)--- Thus, FuncNormal could engage the rewrite rule add(t, 3) = add(3, t)---data EvalType =-    NoRW       -- Normal PLE-  | FuncNormal -- REST: Expand function definitions only when the branch can be decided-  | RWNormal   -- REST: Fully Expand Defs in the context of rewriting (similar to NoRW)-  deriving (Eq)---- Indicates whether or not the evaluation has expanded a function statement--- into a conditional branch.--- In this case, rewriting should stop--- It's unclear whether or not rewriting in either branch makes sense,--- since one branch could be an ill-formed expression.-newtype FinalExpand = FE Bool deriving (Show)--noExpand :: FinalExpand-noExpand = FE False--expand :: FinalExpand-expand = FE True--mapFE :: (Expr -> Expr) -> (Expr, FinalExpand) -> (Expr, FinalExpand)-mapFE f (e, fe) = (f e, fe)--feVal :: FinalExpand -> Bool-feVal (FE f) = f--feAny :: [FinalExpand] -> FinalExpand-feAny xs = FE $ any id (map feVal xs)--(<|>) :: FinalExpand -> FinalExpand -> FinalExpand-(<|>) (FE True) _ = expand-(<|>) _         f = f---feSeq :: [(Expr, FinalExpand)] -> ([Expr], FinalExpand)-feSeq xs = (map fst xs, feAny (map snd xs))---- | Unfolds expressions using rewrites and equations.------ Also reduces if-then-else when the boolean condition or the negation can be--- proved valid. This is the actual implementation of guard-validation-before-unfolding--- that is described in publications.------ Also folds constants.------ Also adds to the monad state all the subexpressions that have been rewritten--- as pairs @(original_subexpression, rewritten_subexpression)@.----eval :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand)-eval _ ctx _ e-  | Just v <- M.lookup e (icSimpl ctx)-  = return (v, noExpand)-  -eval γ ctx et e =-  do acc <- gets (S.toList . evAccum)-     case L.lookup e acc of-        -- If rewriting, don't lookup, as evAccum may contain loops-        Just e' | null (getAutoRws γ ctx) -> eval γ ctx et e'-        _ -> do-          (e0', fe)  <- go e-          let e' = simplify γ ctx e0'-          if e /= e' -            then-              case et of-                NoRW -> do-                  modify (\st -> st { evAccum = S.insert (traceE (e, e')) (evAccum st) })-                  (e'',  fe') <- eval γ (addConst (e,e') ctx) et e'-                  return (e'', fe <|> fe')-                _ -> return (e', fe)-            else -              return (e, fe)-  where-    addConst (e,e') ctx = if isConstant (knDCs γ) e'-                           then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx -    go (ELam (x,s) e)   = mapFE (ELam (x, s)) <$> eval γ' ctx et e where γ' = γ { knLams = (x, s) : knLams γ }-    go (EIte b e1 e2) = evalIte γ ctx et b e1 e2-    go (ECoerc s t e)   = mapFE (ECoerc s t)  <$> go e-    go e@(EApp _ _)     =-      case splitEApp e of-       (f, es) | et == RWNormal ->-          -- Just evaluate the arguments first, to give rewriting a chance to step in-          -- if necessary-          do-            (es', fe) <- feSeq <$> mapM (eval γ ctx et) es-            r <- if es /= es'-              then return (eApps f es', fe)-              else do-                (f', fe)  <- eval γ ctx et f-                (e', fe') <- evalApp γ ctx f' es et-                return $ (e', fe <|> fe')-            return r-       (f, es) ->-          do-            ((f':es'), fe) <- feSeq <$> mapM (eval γ ctx et) (f:es)-            (e', fe') <- evalApp γ ctx f' es' et-            return $ (e', fe <|> fe')--    go e@(PAtom r e1 e2) = evalBoolOr e (binOp (PAtom r) e1 e2)-    go (ENeg e)         = do (e', fe)  <- eval γ ctx et e-                             return $ ((ENeg e'), fe)-    go (EBin o e1 e2)   = do (e1', fe1) <- eval γ ctx et e1-                             (e2', fe2) <- eval γ ctx et e2-                             return (EBin o e1' e2', fe1 <|> fe2)-    go (ETApp e t)      = mapFE (flip ETApp t) <$> go e-    go (ETAbs e s)      = mapFE (flip ETAbs s) <$> go e-    go e@(PNot e')      = evalBoolOr e (mapFE PNot <$> go e')-    go e@(PImp e1 e2)   = evalBoolOr e (binOp PImp e1 e2)-    go e@(PIff e1 e2)   = evalBoolOr e (binOp PIff e1 e2)-    go e@(PAnd es)      = evalBoolOr e (efAll PAnd (go  <$$> es))-    go e@(POr es)       = evalBoolOr e (efAll POr (go <$$> es))-    go e                = return (e, noExpand)--    binOp f e1 e2 = do-      (e1', fe1) <- go e1-      (e2', fe2) <- go e2-      return (f e1' e2', fe1 <|> fe2)--    efAll f mes = do-      xs <- mes-      let (xs', fe) = feSeq xs-      return (f xs', fe)--    evalBoolOr :: Expr -> EvalST (Expr, FinalExpand) -> EvalST (Expr, FinalExpand)-    evalBoolOr ee fallback = do-      b <- evalBool γ ee-      case b of-        Just r  -> return (r, noExpand)-        Nothing -> fallback--data RESTParams oc = RP-  { oc   :: AbstractOC oc Expr IO-  , path :: [(Expr, TermOrigin)]-  , c    :: oc-  }--getANFSubs :: Expr -> [(Symbol, Expr)]-getANFSubs (PAnd es)                                   = concatMap getANFSubs es-getANFSubs (EEq lhs rhs) | (EVar v) <- unElab lhs-                           , anfPrefix `isPrefixOfSym` v = [(v, unElab rhs)]-getANFSubs (EEq lhs rhs) | (EVar v) <- unElab rhs-                           , anfPrefix `isPrefixOfSym` v = [(v, unElab lhs)]-getANFSubs _                                           = []---- Reverse the ANF transformation-deANF :: ICtx -> Expr -> Expr-deANF ctx e = subst' e where-  ints  = concatMap getANFSubs (S.toList $ icANFs ctx)-  ints' = map go (L.groupBy (\x y -> fst x == fst y) $ L.sortOn fst $ L.nub ints) where-    go ([(t, u)]) = (t, u)-    go ts         = (fst (head ts), getBest (map snd ts))-  su          = Su (M.fromList ints')-  subst' ee =-    let-      ee' = subst su ee-    in-      if ee == ee'-        then ee-        else subst' ee'--  getBest ts | Just t <- L.find isVar ts = t-    where-      -- Hack : Vars starting with ds_ are probably constants-      isVar (EVar t) = not $ Tx.isPrefixOf "ds_" (symbolText t)-      isVar _        = False--  -- If the only match is a ds_ var, use it-  getBest ts | Just t <- L.find isVar ts = t-    where-      isVar (EVar _) = True-      isVar _        = False--  getBest ts | otherwise = head ts---- |--- Adds to the monad state all the subexpressions that have been rewritten--- as pairs @(original_subexpression, rewritten_subexpression)@.------ Also folds constants.------ The main difference with 'eval' is that 'evalREST' takes into account--- autorewrites.----evalREST :: Knowledge -> ICtx -> RESTParams (OCType Op) -> EvalST ()-evalREST _ ctx rp-  | pathExprs <- map fst (mytracepp "EVAL1: path" $ path rp)-  , e         <- last pathExprs-  , Just v    <- M.lookup e (icSimpl ctx)-  = when (v /= e) $ modify (\st -> st { evAccum = S.insert (e, v) (evAccum st)})-        -evalREST γ ctx rp =-  do-    Just exploredTerms <- gets explored-    se <- liftIO (shouldExploreTerm exploredTerms e)-    when se $ do-      possibleRWs <- getRWs-      rws <- notVisitedFirst exploredTerms <$> filterM (liftIO . allowed) possibleRWs-      (e', FE fe) <- do-        r@(ec, _) <- eval γ ctx FuncNormal e-        if ec /= e-          then return r-          else eval γ ctx RWNormal e--      let evalIsNewExpr = e' `L.notElem` pathExprs-      let exprsToAdd    = [e' | evalIsNewExpr]  ++ map fst rws-      let evAccum'      = S.fromList $ map (e,) $ exprsToAdd--      modify (\st ->-                st {-                  evAccum  = S.union evAccum' (evAccum st)-                , explored = Just $ ET.insert-                  (convert e)-                  (c rp)-                  (S.insert (convert e') $ S.fromList (map (convert . fst) possibleRWs))-                  (Mb.fromJust $ explored st)-                })--      when evalIsNewExpr $-        if fe && any isRW (path rp)-          then eval γ (addConst (e, e')) NoRW e' >> return ()-          else evalREST γ (addConst (e, e')) (rpEval e')--      mapM_ (\rw -> evalREST γ ctx (rpRW rw)) rws-  where-    shouldExploreTerm et e =-      case rwTerminationOpts rwArgs of-        RWTerminationCheckDisabled -> return $ not $ visited (convert e) et-        RWTerminationCheckEnabled  -> shouldExplore (convert e) (c rp) et--    allowed (rwE, _) | rwE `elem` pathExprs = return False-    allowed (_, c)   | otherwise = termCheck c-    termCheck c = passesTerminationCheck (oc rp) rwArgs c--    notVisitedFirst et rws =-      let-        (v, nv) = L.partition (\(e, _) -> visited (convert e) et) rws-      in-        nv ++ v--    rpEval e' =-      let-        c' =-          if any isRW (path rp)-            then refine (oc rp) (c rp) e e'-            else c rp--      in-        rp{path = path rp ++ [(e', PLE)], c = c'}--    isRW (_, r) = r == RW--    rpRW (e', c') = rp{path = path rp ++ [(e', RW)], c = c' }--    pathExprs       = map fst (mytracepp "EVAL2: path" $ path rp)-    e               = last pathExprs-    autorws         = getAutoRws γ ctx--    rwArgs = RWArgs (isValid γ) $ knRWTerminationOpts γ--    getRWs =-      do-        ok <- if (isRW $ last (path rp)) then (return True) else (liftIO $ termCheck (c rp))-        if ok-          then-            do-              let e'         = deANF ctx e-              let getRW e ar = getRewrite (oc rp) rwArgs (c rp) e ar-              let getRWs' s  = Mb.catMaybes <$> mapM (liftIO . runMaybeT . getRW s) autorws-              concat <$> mapM getRWs' (subExprs e')-          else return []--    addConst (e,e') = if isConstant (knDCs γ) e'-                      then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx --(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b]-f <$$> xs = f Misc.<$$> xs----- | @evalApp kn ctx e es@ unfolds expressions in @eApps e es@ using rewrites--- and equations-evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Expr, FinalExpand)-evalApp γ ctx (EVar f) es et-  | Just eq <- Map.lookup f (knAms γ)-  , length (eqArgs eq) <= length es -  = do -       env  <- gets (seSort . evEnv)-       okFuel <- checkFuel f-       if okFuel && et /= FuncNormal-         then do-                useFuel f-                let (es1,es2) = splitAt (length (eqArgs eq)) es-                shortcut (substEq env eq es1) es2 -- TODO:FUEL this is where an "unfolding" happens, CHECK/BUMP counter-         else return $ (eApps (EVar f) es, noExpand)-  where-    shortcut (EIte i e1 e2) es2 = do-      (b, _) <- eval γ ctx et i-      b'  <- liftIO $ (mytracepp ("evalEIt POS " ++ showpp (i, b)) <$> isValid γ b)-      nb' <- liftIO $ (mytracepp ("evalEIt NEG " ++ showpp (i, PNot b)) <$> isValid γ (PNot b))-      r <- if b' -        then shortcut e1 es2-        else if nb' then shortcut e2 es2-        else return $ (eApps (EIte b e1 e2) es2, expand)-      return r-    shortcut e' es2 = return $ (eApps e' es2, noExpand)--evalApp γ _ (EVar f) (e:es) _-  | (EVar dc, as) <- splitEApp e-  , Just rws <- Map.lookup dc (knSims γ)-  , Just rw <- L.find (\rw -> smName rw == f) rws-  , length as == length (smArgs rw)-  = return (eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es, noExpand)--evalApp _ _ e es _-  = return $ (eApps e es, noExpand)------------------------------------------------------------------------------------- | 'substEq' unfolds or instantiates an equation at a particular list of---   argument values. We must also substitute the sort-variables that appear---   as coercions. See tests/proof/ple1.fq----------------------------------------------------------------------------------substEq :: SEnv Sort -> Equation -> [Expr] -> Expr-substEq env eq es = subst su (substEqCoerce env eq es)-  where su = mkSubst $ zip (eqArgNames eq) es--substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr-substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq-  where -    ts    = snd    <$> eqArgs eq-    sp    = panicSpan "mkCoSub"-    eTs   = sortExpr sp env <$> es-    coSub = mkCoSub env eTs ts--mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub-mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] -  where-    unite ts    = Mb.fromMaybe (uError ts) (unifyTo1 senv ts)-    senv        = mkSearchEnv env-    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) -    xys         = Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs-    (_xTs,_eTs) = (xTs, eTs)--matchSorts :: Sort -> Sort -> [(Symbol, Sort)]-matchSorts s1 s2 = go s1 s2-  where-    go (FObj x)      {-FObj-} y    = [(x, y)]-    go (FAbs _ t1)   (FAbs _ t2)   = go t1 t2-    go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2-    go (FApp s1 t1)  (FApp s2 t2)  = go s1 s2 ++ go t1 t2-    go _             _             = []------------------------------------------------------------------------------------eqArgNames :: Equation -> [Symbol]-eqArgNames = map fst . eqArgs--evalBool :: Knowledge -> Expr -> EvalST (Maybe Expr) -evalBool γ e = do -  bt <- liftIO $ isValid γ e-  if bt then return $ Just PTrue -   else do -    bf <- liftIO $ isValid γ (PNot e)-    if bf then return $ Just PFalse -          else return Nothing-               -evalIte :: Knowledge -> ICtx -> EvalType -> Expr -> Expr -> Expr -> EvalST (Expr, FinalExpand)-evalIte γ ctx et b0 e1 e2 = do-  (b, fe) <- eval γ ctx et b0-  b'  <- liftIO $ (mytracepp ("evalEIt POS " ++ showpp b) <$> isValid γ b)-  nb' <- liftIO $ (mytracepp ("evalEIt NEG " ++ showpp (PNot b)) <$> isValid γ (PNot b))-  if b' -    then return (e1, noExpand)-    else if nb' then return $ (e2, noExpand)-    else return $ (EIte b e1 e2, fe)------------------------------------------------------------------------------------- | Knowledge (SMT Interaction)----------------------------------------------------------------------------------data Knowledge = KN -  { knSims              :: Map Symbol [Rewrite]   -- ^ Rewrites rules came from match and data type definitions -                                                  --   They are grouped by the data constructor that they unfold-  , knAms               :: Map Symbol Equation -- ^ All function definitions-  , knContext           :: SMT.Context-  , knPreds             :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool-  , knLams              :: ![(Symbol, Sort)]-  , knSummary           :: ![(Symbol, Int)]     -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity-  , knDCs               :: !(S.HashSet Symbol)  -- ^ data constructors drawn from Rewrite -  , knSels              :: !SelectorMap -  , knConsts            :: !ConstDCMap-  , knAutoRWs           :: M.HashMap SubcId [AutoRewrite]-  , knRWTerminationOpts :: RWTerminationOpts-  }--isValid :: Knowledge -> Expr -> IO Bool-isValid γ e = do -  contra <- knPreds γ (knContext γ) (knLams γ) PFalse-  if contra -    then return False -    else knPreds γ (knContext γ) (knLams γ) e--knowledge :: Config -> SMT.Context -> SInfo a -> Knowledge-knowledge cfg ctx si = KN -  { knSims                     = Map.fromListWith (++) [ (smDC rw, [rw]) | rw <- sims]-  , knAms                      = Map.fromList [(eqName eq, eq) | eq <- aenvEqs aenv]-  , knContext                  = ctx -  , knPreds                    = askSMT  cfg -  , knLams                     = [] -  , knSummary                  =    ((\s -> (smName s, 1)) <$> sims) -                                 ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv)-                                 ++ rwSyms-  , knDCs                      = S.fromList (smDC <$> sims)-  , knSels                     = Mb.catMaybes $ map makeSel  sims -  , knConsts                   = Mb.catMaybes $ map makeCons sims -  , knAutoRWs                  = aenvAutoRW aenv-  , knRWTerminationOpts        =-      if (rwTerminationCheck cfg)-      then RWTerminationCheckEnabled-      else RWTerminationCheckDisabled-  } -  where -    sims = aenvSimpl aenv-    aenv = ae si--    inRewrites :: Symbol -> Bool-    inRewrites e =-      let-        syms = Mb.catMaybes $ map (lhsHead . arLHS) $ concat $ M.elems $ aenvAutoRW aenv-      in-        e `L.elem` syms--    lhsHead :: Expr -> Maybe Symbol-    lhsHead e | (EVar f, _) <- splitEApp e = Just f-    lhsHead _ | otherwise = Nothing---    rwSyms = filter (inRewrites . fst) $ map toSum (toListSEnv (gLits si))-      where-        toSum (sym, sort)      = (sym, getArity sort)--        getArity (FFunc _ rhs) = 1 + getArity rhs-        getArity _             = 0----    makeCons rw -      | null (syms $ smBody rw)-      = Just (smName rw, (smDC rw, smBody rw))-      | otherwise-      = Nothing --    makeSel rw -      | EVar x <- smBody rw-      = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw)-      | otherwise -      = Nothing --askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool-askSMT cfg ctx bs e---   | isContraPred e     = return False -  | isTautoPred  e     = return True-  | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e'-  | otherwise          = return False-  where -    e'                 = toSMT "askSMT" cfg ctx bs e --toSMT :: String ->  Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> Pred-toSMT msg cfg ctx bs e = defuncAny cfg senv . elaborate "makeKnowledge" (elabEnv bs) . mytracepp ("toSMT from " ++ msg ++ showpp e)-                          $ e -  where-    elabEnv      = insertsSymEnv senv-    senv         = SMT.ctxSymEnv ctx-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------withCtx :: Config -> FilePath -> SymEnv -> (SMT.Context -> IO a) -> IO a-withCtx cfg file env k = do-  ctx <- SMT.makeContextWithSEnv cfg file env-  _   <- SMT.smtPush ctx-  res <- k ctx-  _   <- SMT.cleanupContext ctx-  return res----- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi, --- i.e., sel_i selects the ith value for the data constructor D  -type SelectorMap = [(Symbol, (Symbol, Int))]-type ConstDCMap = [(Symbol, (Symbol, Expr))]---- ValueMap maps expressions to constants (including data constructors)-type ConstMap = M.HashMap Expr Expr-type LDataCon = Symbol              -- Data Constructors --isSimplification :: S.HashSet LDataCon -> (Expr,Expr) -> Bool -isSimplification dcs (_,c) = isConstant dcs c -  --isConstant :: S.HashSet LDataCon -> Expr -> Bool -isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs)--class Simplifiable a where -  simplify :: Knowledge -> ICtx -> a -> a ---instance Simplifiable Expr where-  simplify γ ictx e = mytracepp ("simplification of " ++ showpp e) $ fix (Vis.mapExprOnExpr tx) e-    where -      fix f e = if e == e' then e else fix f e' where e' = f e -      tx e -        | Just e' <- M.lookup e (icSimpl ictx)-        = e' -      tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2-      tx (ENeg e)         = applyConstantFolding Minus (ECon (I 0)) e-      tx (EApp (EVar f) a)-        | Just (dc, c)  <- L.lookup f (knConsts γ) -        , (EVar dc', _) <- splitEApp a-        , dc == dc' -        = c-      tx (EIte b e1 e2)-        | isTautoPred b  = e1 -        | isContraPred b = e2-      tx (ECoerc s t e)-        | s == t = e -      tx (EApp (EVar f) a)-        | Just (dc, i)  <- L.lookup f (knSels γ) -        , (EVar dc', es) <- splitEApp a-        , dc == dc' -        = es!!i-      tx e = e-      -applyConstantFolding :: Bop -> Expr -> Expr -> Expr-applyConstantFolding bop e1 e2 =-  case (e1, e2) of-    ((ECon (R left)), (ECon (R right))) ->-      Mb.fromMaybe e (cfR bop left right)-    ((ECon (R left)), (ECon (I right))) ->-      Mb.fromMaybe e (cfR bop left (fromIntegral right))-    ((ECon (I left)), (ECon (R right))) ->-      Mb.fromMaybe e (cfR bop (fromIntegral left) right)-    ((ECon (I left)), (ECon (I right))) ->-      Mb.fromMaybe e (cfI bop left right)-    _ -> e-  where-    -    e = EBin bop e1 e2-    -    getOp :: Num a => Bop -> Maybe (a -> a -> a)-    getOp Minus    = Just (-)-    getOp Plus     = Just (+)-    getOp Times    = Just (*)-    getOp RTimes   = Just (*)-    getOp _        = Nothing--    cfR :: Bop -> Double -> Double -> Maybe Expr-    cfR bop left right = fmap go (getOp' bop)-      where-        go f = ECon $ R $ f left right-        -        getOp' Div      = Just (/)-        getOp' RDiv     = Just (/)-        getOp' op       = getOp op--    cfI :: Bop -> Integer -> Integer -> Maybe Expr-    cfI bop left right = fmap go (getOp' bop)-      where-        go f = ECon $ I $ f left right-        -        getOp' Mod = Just mod-        getOp' op  = getOp op------------------------------------------------------------------------------------- | Normalization of Equation: make their arguments unique -----------------------------------------------------------------------------------------------------class Normalizable a where -  normalize :: a -> a --instance Normalizable (GInfo c a) where -  normalize si = si {ae = normalize $ ae si}--instance Normalizable AxiomEnv where -  normalize aenv = aenv { aenvEqs   = mytracepp "aenvEqs"  (normalize <$> aenvEqs   aenv)-                        , aenvSimpl = mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) }--instance Normalizable Rewrite where -  normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw }-    where -      su  = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'-      xs  = smArgs rw -      xs' = zipWith mkSymbol xs [0..]-      mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i ---instance Normalizable Equation where -  normalize eq = eq {eqArgs = zip xs' ss, eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq }-    where -      su      = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'-      (xs,ss) = unzip (eqArgs eq) -      xs'     = zipWith mkSymbol xs [0..]-      mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i ---normalizeBody :: Symbol -> Expr -> Expr-normalizeBody f = go   -  where -    go e -      | any (== f) (syms e) -      = go' e -    go e -      = e -    -    go' (PAnd [PImp c e1,PImp (PNot c') e2])-      | c == c' = EIte c e1 (go' e2)-    go' e = e --_splitBranches :: Symbol -> Expr -> [(Expr, Expr)]-_splitBranches f = go   -  where -    go (PAnd es) -      | any (== f) (syms es) -      = go' <$> es-    go e -      = [(PTrue, e)]--    go' (PImp c e) = (c, e) -    go' e          = (PTrue, e)---- -- TODO:FUEL Config--- maxFuel :: Int--- maxFuel = 11 --useFuel :: Symbol -> EvalST ()-useFuel f = do -  modify (\st -> st { evFuel = useFuelCount f (evFuel st) })--useFuelCount :: Symbol -> FuelCount -> FuelCount -useFuelCount f fc = fc { fcMap = M.insert f (k + 1) m }-  where -    k             = M.lookupDefault 0 f m -    m             = fcMap fc--checkFuel :: Symbol -> EvalST Bool-checkFuel f = do +-- | This module implements "Proof by Logical Evaluation" where we+--   unfold function definitions if they *must* be unfolded, to strengthen+--   the environments with function-definition-equalities.+--   The algorithm is discussed at length in:+--+--     1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842+--     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf+--------------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ExistentialQuantification #-}++{-# OPTIONS_GHC -Wno-name-shadowing    #-}++module Language.Fixpoint.Solver.PLE+  ( instantiate++  -- The following exports are for property testing.+  , FuelCount(..)+  , ICtx(..)+  , Knowledge(..)+  , simplify+  )+  where++import           Language.Fixpoint.Types hiding (simplify)+import           Language.Fixpoint.Types.Config  as FC+import           Language.Fixpoint.Types.Solutions (CMap)+import qualified Language.Fixpoint.Types.Visitor as Vis+import qualified Language.Fixpoint.Misc          as Misc+import qualified Language.Fixpoint.Smt.Interface as SMT+import           Language.Fixpoint.Defunctionalize+import           Language.Fixpoint.Solver.EnvironmentReduction (inlineInExpr, undoANF)+import qualified Language.Fixpoint.Utils.Files   as Files+import qualified Language.Fixpoint.Utils.Trie    as T+import           Language.Fixpoint.Utils.Progress+import           Language.Fixpoint.SortCheck+import           Language.Fixpoint.Graph.Deps             (isTarget)+import           Language.Fixpoint.Solver.Common          (askSMT, toSMT)+import           Language.Fixpoint.Solver.Sanitize        (symbolEnv)+import           Language.Fixpoint.Solver.Simplify+import           Language.Fixpoint.Solver.Rewrite as Rewrite++import Language.REST.OCAlgebra as OC+import Language.REST.ExploredTerms as ExploredTerms+import Language.REST.RuntimeTerm as RT+import Language.REST.SMT (withZ3, SolverHandle)++import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import           Data.Bifunctor (second)+import qualified Data.HashMap.Strict  as M+import qualified Data.HashMap.Lazy  as HashMap.Lazy+import qualified Data.HashSet         as S+import           Data.IORef+import qualified Data.List            as L+import           Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe           as Mb+import qualified Data.Set as Set+import           Text.PrettyPrint.HughesPJ.Compat++mytracepp :: (PPrint a) => String -> a -> a+mytracepp = notracepp++--------------------------------------------------------------------------------+-- | Strengthen Constraint Environments via PLE+--------------------------------------------------------------------------------+{-# SCC instantiate #-}+instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+instantiate cfg fi' subcIds = do+    let cs = M.filterWithKey+               (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds)+               (cm fi)+    let t  = mkCTrie (M.toList cs)                                          -- 1. BUILD the Trie+    res   <- withRESTSolver $ \solver -> withProgress (1 + M.size cs) $+               withCtx cfg file sEnv $ \ctx -> do+                  env <- instEnv cfg fi cs solver ctx+                  pleTrie t env                                             -- 2. TRAVERSE Trie to compute InstRes+    savePLEEqualities cfg fi sEnv res+    return $ resSInfo cfg sEnv fi res                                       -- 3. STRENGTHEN SInfo using InstRes+  where+    withRESTSolver :: (Maybe SolverHandle -> IO a) -> IO a+    withRESTSolver f | all null (M.elems $ aenvAutoRW aEnv) = f Nothing+    withRESTSolver f = withZ3 (f . Just)++    file   = srcFile cfg ++ ".evals"+    sEnv   = symbolEnv cfg fi+    aEnv   = ae fi+    fi     = normalize fi'++savePLEEqualities :: Config -> SInfo a -> SymEnv -> InstRes -> IO ()+savePLEEqualities cfg fi sEnv res = when (save cfg) $ do+    let fq   = queryFile Files.Fq cfg ++ ".ple"+    putStrLn $ "\nSaving PLE equalities: "   ++ fq ++ "\n"+    Misc.ensurePath fq+    let constraint_equalities =+          map equalitiesPerConstraint $ Misc.hashMapToAscList $ cm fi+    writeFile fq $ render $ vcat $+      map renderConstraintRewrite constraint_equalities+  where+    equalitiesPerConstraint (cid, c) =+      (cid, L.sort [ e | i <- elemsIBindEnv (senv c), Just e <- [M.lookup i res] ])+    renderConstraintRewrite (cid, eqs) =+      "constraint id" <+> text (show cid ++ ":")+      $+$ nest 2+           (vcat $ L.intersperse "" $+            map (toFix . unElab) $ Set.toList $ Set.fromList $+            -- call elabExpr to try to bring equations that are missing+            -- some casts into a fully annotated form for comparison+            map (elabExpr "savePLEEqualities" sEnv) $+            concatMap conjuncts eqs+           )+      $+$ ""++-------------------------------------------------------------------------------+-- | Step 1a: @instEnv@ sets up the incremental-PLE environment+instEnv :: (Loc a) => Config -> SInfo a -> CMap (SimpC a) -> Maybe SolverHandle -> SMT.Context -> IO (InstEnv a)+instEnv cfg fi cs restSolver ctx = do+    refRESTCache <- newIORef mempty+    refRESTSatCache <- newIORef mempty+    let+        restOC = FC.restOC cfg+        oc0 = ordConstraints restOC $ Mb.fromJust restSolver+        oc :: OCAlgebra OCType RuntimeTerm IO+        oc = oc0+             { OC.isSat = cachedIsSat refRESTSatCache oc0+             , OC.notStrongerThan = cachedNotStrongerThan refRESTCache oc0+             }+        et :: ExploredTerms RuntimeTerm OCType IO+        et = ExploredTerms.empty+               EF+                 { ExploredTerms.union = OC.union oc+                 , ExploredTerms.subsumes = OC.notStrongerThan oc+                 , exRefine = OC.refine oc+                 }+                 ExploreWhenNeeded+        s0 = EvalEnv+              { evEnv = SMT.ctxSymEnv ctx+              , evPendingUnfoldings = mempty+              , evNewEqualities = mempty+              , evSMTCache = mempty+              , evFuel = defFuelCount cfg+              , explored = Just et+              , restSolver = restSolver+              , restOCA = restOC+              , evOCAlgebra = oc+              }+    return $ InstEnv+       { ieCfg = cfg+       , ieSMT = ctx+       , ieBEnv = bs fi+       , ieAenv = ae fi+       , ieCstrs = cs+       , ieKnowl = knowledge cfg ctx fi+       , ieEvEnv = s0+       }+  where+    cachedNotStrongerThan refRESTCache oc a b = do+      m <- readIORef refRESTCache+      case M.lookup (a, b) m of+        Nothing -> do+          nst <- OC.notStrongerThan oc a b+          writeIORef refRESTCache (M.insert (a, b) nst m)+          return nst+        Just nst ->+          return nst++    cachedIsSat refRESTSatCache oc a = do+      m <- readIORef refRESTSatCache+      case M.lookup a m of+        Nothing -> do+          sat <- OC.isSat oc a+          writeIORef refRESTSatCache (M.insert a sat m)+          return sat+        Just sat ->+          return sat++----------------------------------------------------------------------------------------------+-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments+--+-- The trie is a way to unfold the equalities a minimum number of times.+-- Say you have+--+-- > 1: [1, 2, 3, 4, 5] => p1+-- > 2: [1, 2, 3, 6, 7] => p2+--+-- Then you build the tree+--+-- >  1 -> 2 -> 3 -> 4 -> 5 — [Constraint 1]+-- >            | -> 6 -> 7 — [Constraint 2]+--+-- which you use to unfold everything in 1, 2, and 3 once (instead of twice)+-- and with the proper existing environment+--+mkCTrie :: [(SubcId, SimpC a)] -> CTrie+mkCTrie ics  = T.fromList [ (cBinds c, i) | (i, c) <- ics ]+  where+    cBinds   = L.sort . elemsIBindEnv . senv++----------------------------------------------------------------------------------------------+-- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE+pleTrie :: CTrie -> InstEnv a -> IO InstRes+pleTrie t env = loopT env' ctx0 diff0 Nothing res0 t+  where+    env'         = env+    diff0        = []+    res0         = M.empty+    ctx0         = ICtx+      { icAssms  = mempty+      , icCands  = mempty+      , icEquals = mempty+      , icSimpl  = mempty+      , icSubcId = Nothing+      , icANFs   = []+      }++loopT+  :: InstEnv a+  -> ICtx+  -> Diff         -- ^ The longest path suffix without forks in reverse order+  -> Maybe BindId -- ^ bind id of the branch ancestor of the trie if any.+                  --   'Nothing' when this is the top-level trie.+  -> InstRes+  -> CTrie+  -> IO InstRes+loopT env ctx delta i res t = case t of+  T.Node []  -> return res+  T.Node [b] -> loopB env ctx delta i res b+  T.Node bs  -> withAssms env ctx delta Nothing $ \env' ctx' -> do+                  (ctx'', env'', res') <- ple1 env' ctx' i res+                  foldM (loopB env'' ctx'' [] i) res' bs++loopB+  :: InstEnv a+  -> ICtx+  -> Diff         -- ^ The longest path suffix without forks in reverse order+  -> Maybe BindId -- ^ bind id of the branch ancestor of the branch if any.+                  --   'Nothing' when this is a branch of the top-level trie.+  -> InstRes+  -> CBranch+  -> IO InstRes+loopB env ctx delta iMb res b = case b of+  T.Bind i t -> loopT env ctx (i:delta) (Just i) res t+  T.Val cid  -> withAssms env ctx delta (Just cid) $ \env' ctx' -> do+                  progressTick+                  (\(_, _, r) -> r) <$> ple1 env' ctx' iMb res++-- | Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@+-- and the rhs of @cidMb@.+--+-- Adds to @ctx@ assumptions from @env@ and @delta@.+--+-- Sets the current constraint id in @ctx@ to @cidMb@.+--+-- Pushes assumptions from the modified context to the SMT solver, runs @act@,+-- and then pops the assumptions.+--+withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (InstEnv a -> ICtx -> IO b) -> IO b+withAssms env@InstEnv{..} ctx delta cidMb act = do+  let (ctx', env')  = updCtx env ctx delta cidMb+  let assms = icAssms ctx'+  SMT.smtBracket ieSMT  "PLE.evaluate" $ do+    forM_ assms (SMT.smtAssert ieSMT)+    act env' ctx' { icAssms = mempty }++-- | @ple1@ performs the PLE at a single "node" in the Trie+--+-- It will generate equalities for all function invocations in the candidates+-- in @ctx@ for which definitions are known. The function definitions are in+-- @ieKnowl@.+ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstEnv a, InstRes)+ple1 ie@InstEnv {..} ctx i res = do+  (ctx', env) <- runStateT (evalCandsLoop ieCfg ctx ieSMT ieKnowl) ieEvEnv+  let pendings = collectPendingUnfoldings env (icSubcId ctx)+      newEqs = pendings ++ S.toList (S.difference (icEquals ctx') (icEquals ctx))+  return (ctx', ie { ieEvEnv = env }, updCtxRes res i newEqs)+  where+    -- Pending unfoldings (i.e. with undecided guards) are collected only+    -- when we reach a leaf in the Trie, and only if the user asked for them.+    collectPendingUnfoldings env (Just _) | pleWithUndecidedGuards ieCfg =+      M.toList (evPendingUnfoldings env)+    collectPendingUnfoldings _ _ = []++evalToSMT :: String -> Config -> SMT.Context -> (Expr, Expr) -> Pred+evalToSMT msg cfg ctx (e1,e2) = toSMT ("evalToSMT:" ++ msg) cfg ctx [] (EEq e1 e2)++-- | Generate equalities for all function invocations in the candidates+-- in @ctx@ for which definitions are known. The function definitions are in+-- @ieKnowl@.+--+-- In pseudocode:+--+-- > do+-- >     for every candidate+-- >         discover equalities,+-- >         unfold function invocations,+-- >         update candidates with the unfolded expressions+-- >     send newly discovered equalities to the SMT solver+-- > until no new equalities are discovered+-- >       or the environment becomes inconsistent+--+evalCandsLoop :: Config -> ICtx -> SMT.Context -> Knowledge -> EvalST ICtx+evalCandsLoop cfg ictx0 ctx γ = go ictx0 0+  where+    go ictx _ | S.null (icCands ictx) = return ictx+    go ictx i = do+      inconsistentEnv <- testForInconsistentEnvironment+      if inconsistentEnv+        then return ictx+        else do+                  liftIO $ SMT.smtAssert ctx (pAndNoDedup (S.toList $ icAssms ictx))+                  let ictx' = ictx { icAssms = mempty }+                      cands = S.toList $ icCands ictx+                  candss <- mapM (evalOne γ ictx' i) cands+                  us <- gets evNewEqualities+                  modify $ \st -> st { evNewEqualities = mempty }+                  let noCandidateChanged = and (zipWith eqCand candss cands)+                      unknownEqs = us `S.difference` icEquals ictx+                  if S.null unknownEqs && noCandidateChanged+                        then return ictx+                        else do  let eqsSMT   = evalToSMT "evalCandsLoop" cfg ctx `S.map` unknownEqs+                                 let ictx''   = ictx' { icEquals = icEquals ictx <> unknownEqs+                                                      , icAssms  = S.filter (not . isTautoPred) eqsSMT }+                                 go (ictx'' { icCands = S.fromList (concat candss) }) (i + 1)++    testForInconsistentEnvironment =+      liftIO $ knPreds γ (knContext γ) (knLams γ) PFalse++    eqCand [e0] e1 = e0 == e1+    eqCand _ _ = False++----------------------------------------------------------------------------------------------+-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo+----------------------------------------------------------------------------------------------++resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a+resSInfo cfg env fi res = strengthenBinds fi res'+  where+    res'     = M.fromList $ zip is ps''+    ps''     = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps'+    ps'      = defuncAny cfg env ps+    (is, ps) = unzip (M.toList res)++----------------------------------------------------------------------------------------------+-- | @InstEnv@ has the global information needed to do PLE+----------------------------------------------------------------------------------------------++data InstEnv a = InstEnv+  { ieCfg   :: !Config+  , ieSMT   :: !SMT.Context+  , ieBEnv  :: !(BindEnv a)+  , ieAenv  :: !AxiomEnv+  , ieCstrs :: !(CMap (SimpC a))+  , ieKnowl :: !Knowledge+  , ieEvEnv :: !EvalEnv+  }++----------------------------------------------------------------------------------------------+-- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE+----------------------------------------------------------------------------------------------++data ICtx    = ICtx+  { icAssms    :: S.HashSet Pred            -- ^ Equalities converted to SMT format+  , icCands    :: S.HashSet Expr            -- ^ "Candidates" for unfolding+  , icEquals   :: EvEqualities              -- ^ Accumulated equalities+  , icSimpl    :: !ConstMap                 -- ^ Map of expressions to constants+  , icSubcId   :: Maybe SubcId              -- ^ Current subconstraint ID+  , icANFs     :: [[(Symbol, SortedReft)]]  -- Hopefully contain only ANF things+  }++----------------------------------------------------------------------------------------------+-- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId+----------------------------------------------------------------------------------------------++type InstRes = M.HashMap BindId Expr++----------------------------------------------------------------------------------------------+-- | @Unfold is the result of running PLE at a single equality;+--     (e, [(e1, e1')...]) is the source @e@ and the (possible empty)+--   list of PLE-generated equalities (e1, e1') ...+----------------------------------------------------------------------------------------------++type CTrie   = T.Trie   SubcId+type CBranch = T.Branch SubcId+type Diff    = [BindId]    -- ^ in "reverse" order++equalitiesPred :: [(Expr, Expr)] -> [Expr]+equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ]++updCtxRes :: InstRes -> Maybe BindId -> [(Expr, Expr)] -> InstRes+updCtxRes res iMb = updRes res iMb . pAndNoDedup . equalitiesPred+++updRes :: InstRes -> Maybe BindId -> Expr -> InstRes+updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res+updRes res  Nothing _ = res++----------------------------------------------------------------------------------------------+-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@+--   to the context.+----------------------------------------------------------------------------------------------++updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx, InstEnv a)+updCtx env@InstEnv{..} ctx delta cidMb+            = ( ctx { icAssms  = S.fromList (filter (not . isTautoPred) ctxEqs)+                    , icCands  = S.fromList cands           <> icCands  ctx+                    , icSimpl  = icSimpl ctx <> econsts+                    , icSubcId = cidMb+                    , icANFs   = bs : icANFs ctx+                    }+              , env+              )+  where+    cands     = rhs:es+    econsts   = M.fromList $ findConstants ieKnowl es+    ctxEqs    = toSMT "updCtx" ieCfg ieSMT [] <$> L.nub+                  [ c | xr <- bs, c <- conjuncts (expr xr), null (Vis.kvarsExpr c) ]+    bs        = second unApplySortedReft <$> binds+    rhs       = unApply eRhs+    es        = expr <$> bs+    eRhs      = maybe PTrue crhs subMb+    binds     = [ (x, y) | i <- delta, let (x, y, _) =  lookupBindEnv i ieBEnv]+    subMb     = getCstr ieCstrs <$> cidMb+++findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)]+findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)]+  where+    go su ess = if ess == ess'+                  then su+                  else go (su ++ su') ess'+       where ess' = subst (mkSubst su') <$> ess+             su'  = makeSu ess+    makeSu exprs  = [(x,c) | (EEq (EVar x) c) <- exprs+                           , isConstant (knDCs γ) c+                           , EVar x /= c ]++getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a+getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env++isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool+isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv)++type EvEqualities = S.HashSet (Expr, Expr)++--------------------------------------------------------------------------------+data EvalEnv = EvalEnv+  { evEnv      :: !SymEnv+    -- | Equalities where we couldn't evaluate the guards+  , evPendingUnfoldings :: M.HashMap Expr Expr+  , evNewEqualities :: EvEqualities -- ^ Equalities discovered during a traversal of+                                    -- an expression+  , evSMTCache :: M.HashMap Expr Bool -- ^ Whether an expression is valid or its negation+  , evFuel     :: FuelCount++  -- REST parameters+  , explored   :: Maybe (ExploredTerms RuntimeTerm OCType IO)+  , restSolver :: Maybe SolverHandle+  , restOCA    :: RESTOrdering+  , evOCAlgebra :: OCAlgebra OCType RuntimeTerm IO+  }++data FuelCount = FC+  { fcMap :: M.HashMap Symbol Int+  , fcMax :: Maybe Int+  }+  deriving (Show)++defFuelCount :: Config -> FuelCount+defFuelCount cfg = FC mempty (fuel cfg)++type EvalST a = StateT EvalEnv IO a+--------------------------------------------------------------------------------++getAutoRws :: Knowledge -> ICtx -> [AutoRewrite]+getAutoRws γ ctx =+  Mb.fromMaybe [] $ do+    cid <- icSubcId ctx+    M.lookup cid $ knAutoRWs γ++-- | Discover the equalities in an expression.+--+-- The discovered equalities are in the environment of the monad,+-- and the list of produced expressions contains the result of unfolding+-- definitions. When REST is in effect, more than one expression might+-- be returned because expressions can then be rewritten in more than one+-- way.+evalOne :: Knowledge -> ICtx -> Int -> Expr -> EvalST [Expr]+evalOne γ ctx i e+  | i > 0 || null (getAutoRws γ ctx) = (:[]) . fst <$> eval γ ctx NoRW e+evalOne γ ctx _ e = do+    env <- get+    let oc :: OCAlgebra OCType RuntimeTerm IO+        oc = evOCAlgebra env+        rp = RP (contramap Rewrite.convert oc) [(e, PLE)] constraints+        constraints = OC.top oc+        emptyET = ExploredTerms.empty (EF (OC.union oc) (OC.notStrongerThan oc) (OC.refine oc)) ExploreWhenNeeded+    es <- evalREST γ ctx rp+    modify $ \st -> st { explored = Just emptyET }+    return es++-- The FuncNormal and RWNormal evaluation strategies are used for REST+-- For example, consider the following function:+--   add(x, y) = if x == 0 then y else add(x - 1, y + 1)+-- And a rewrite rule:+--   forall a, b . add(a,b) -> add(b, a)+-- Then the expression add(t, add(2, 1)) would evaluate under NoRW to:+--   if t == 0 then 3 else add(t - 1, 4)+-- However, under FuncNormal, it would evaluate to: add(t, 3)+-- Thus, FuncNormal could engage the rewrite rule add(t, 3) = add(3, t)+++data EvalType =+    NoRW       -- Normal PLE+  | FuncNormal -- REST: Expand function definitions only when the branch can be decided+  | RWNormal   -- REST: Fully Expand Defs in the context of rewriting (similar to NoRW)+  deriving (Eq)++-- Indicates whether or not the evaluation has expanded a function statement+-- into a conditional branch.+-- In this case, rewriting should stop+-- It's unclear whether or not rewriting in either branch makes sense,+-- since one branch could be an ill-formed expression.+newtype FinalExpand = FE Bool deriving (Show)++noExpand :: FinalExpand+noExpand = FE False++expand :: FinalExpand+expand = FE True++mapFE :: (Expr -> Expr) -> (Expr, FinalExpand) -> (Expr, FinalExpand)+mapFE f (e, fe) = (f e, fe)++feVal :: FinalExpand -> Bool+feVal (FE f) = f++feAny :: [FinalExpand] -> FinalExpand+feAny xs = FE $ any feVal xs++infixl 9 <|>+(<|>) :: FinalExpand -> FinalExpand -> FinalExpand+(<|>) (FE True) _ = expand+(<|>) _         f = f+++feSeq :: [(Expr, FinalExpand)] -> ([Expr], FinalExpand)+feSeq xs = (map fst xs, feAny (map snd xs))++-- | Unfolds function invocations in expressions.+--+-- Also reduces if-then-else when the boolean condition or the negation can be+-- proved valid. This is the actual implementation of guard-validation-before-unfolding+-- that is described in publications.+--+-- Also adds to the monad state all the unfolding equalities that have been+-- discovered as necessary.+--+eval :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand)+eval γ ctx et = go+  where+    go (ELam (x,s) e)   = evalELam γ ctx et (x, s) e+    go e@EIte{}         = evalIte γ ctx et e+    go (ECoerc s t e)   = mapFE (ECoerc s t)  <$> go e+    go e@(EApp _ _)     =+      case splitEAppThroughECst e of+       (f, es) | et == RWNormal ->+          -- Just evaluate the arguments first, to give rewriting a chance to step in+          -- if necessary+          do+            (es', fe) <- feSeq <$> mapM (eval γ ctx et) es+            if es /= es'+              then return (eApps f es', fe)+              else do+                (f', fe)  <- eval γ ctx et f+                (me', fe') <- evalApp γ ctx f' es et+                return (Mb.fromMaybe (eApps f' es') me', fe <|> fe')+       (f, es) ->+          do+            (f':es', fe) <- feSeq <$> mapM (eval γ ctx et) (f:es)+            (me', fe') <- evalApp γ ctx f' es' et+            return (Mb.fromMaybe (eApps f' es') me', fe <|> fe')++    go (PAtom r e1 e2) = binOp (PAtom r) e1 e2+    go (ENeg e)         = do (e', fe)  <- eval γ ctx et e+                             return (ENeg e', fe)+    go (EBin o e1 e2)   = do (e1', fe1) <- eval γ ctx et e1+                             (e2', fe2) <- eval γ ctx et e2+                             return (EBin o e1' e2', fe1 <|> fe2)+    go (ETApp e t)      = mapFE (`ETApp` t) <$> go e+    go (ETAbs e s)      = mapFE (`ETAbs` s) <$> go e+    go (PNot e')        = mapFE PNot <$> go e'+    go (PImp e1 e2)     = binOp PImp e1 e2+    go (PIff e1 e2)     = binOp PIff e1 e2+    go (PAnd es)        = efAll PAnd (go `traverse` es)+    go (POr es)         = efAll POr (go `traverse` es)+    go e | EVar _ <- dropECst e = do+      (me', fe) <- evalApp γ ctx e [] et+      return (Mb.fromMaybe e me', fe)+    go (ECst e t)       = do (e', fe) <- eval γ ctx et e+                             return (ECst e' t, fe)+    go e                = return (e, noExpand)++    binOp f e1 e2 = do+      (e1', fe1) <- go e1+      (e2', fe2) <- go e2+      return (f e1' e2', fe1 <|> fe2)++    efAll f mes = do+      xs <- mes+      let (xs', fe) = feSeq xs+      return (f xs', fe)++-- | 'evalELamb' produces equations that preserve the context of a rewrite+-- so equations include any necessary lambda bindings.+evalELam :: Knowledge -> ICtx -> EvalType -> (Symbol, Sort) -> Expr -> EvalST (Expr, FinalExpand)+evalELam γ ctx et (x, s) e = do+    oldPendingUnfoldings <- gets evPendingUnfoldings+    oldEqs <- gets evNewEqualities+    (e', fe) <- eval (γ { knLams = (x, s) : knLams γ }) ctx et e+    let e2' = simplify γ ctx e'+        elam = ELam (x, s) e+    -- Discard the old equalities which miss the lambda binding+    modify $ \st -> st+      { evPendingUnfoldings = oldPendingUnfoldings+      , evNewEqualities = S.insert (elam, ELam (x, s) e2') oldEqs+      }+    return (elam, fe)++data RESTParams oc = RP+  { oc   :: OCAlgebra oc Expr IO+  , path :: [(Expr, TermOrigin)]+  , c    :: oc+  }++-- Reverse the ANF transformation+deANF :: ICtx -> Expr -> Expr+deANF ctx = inlineInExpr (`HashMap.Lazy.lookup` undoANF id bindEnv)+  where+    bindEnv = HashMap.Lazy.unions $ map HashMap.Lazy.fromList $ icANFs ctx++-- |+-- Adds to the monad state all the subexpressions that have been rewritten+-- as pairs @(original_subexpression, rewritten_subexpression)@.+--+-- Also folds constants.+--+-- The main difference with 'eval' is that 'evalREST' takes into account+-- autorewrites.+--+evalREST :: Knowledge -> ICtx -> RESTParams OCType -> EvalST [Expr]+evalREST γ ctx rp = do+  env <- get+  cacheRef <- liftIO $ newIORef $ evSMTCache env+  evalRESTWithCache cacheRef γ ctx [] rp++evalRESTWithCache+  :: IORef (M.HashMap Expr Bool) -> Knowledge -> ICtx -> [Expr] -> RESTParams OCType -> EvalST [Expr]+evalRESTWithCache cacheRef _ ctx acc rp+  | pathExprs <- map fst (mytracepp "EVAL1: path" $ path rp)+  , e         <- last pathExprs+  , Just v    <- M.lookup e (icSimpl ctx)+  = do+    smtCache <- liftIO $ readIORef cacheRef+    when (v /= e) $ modify (\st -> st+      { evNewEqualities = S.insert (e, v) (evNewEqualities st)+      , evSMTCache = smtCache+      })+    return (v : acc)++evalRESTWithCache cacheRef γ ctx acc rp =+  do+    Just exploredTerms <- gets explored+    se <- liftIO (shouldExploreTerm exploredTerms e)+    if se then do+      possibleRWs <- getRWs+      rws <- notVisitedFirst exploredTerms <$> filterM (liftIO . allowed) possibleRWs+      oldEqualities <- gets evNewEqualities+      modify $ \st -> st { evNewEqualities = mempty }++      -- liftIO $ putStrLn $ (show $ length possibleRWs) ++ " rewrites allowed at path length " ++ (show $ (map snd $ path rp))+      (e', FE fe) <- do+        r@(ec, _) <- eval γ ctx FuncNormal e+        if ec /= e+          then return r+          else eval γ ctx RWNormal e++      let evalIsNewExpr = e' `L.notElem` pathExprs+      let exprsToAdd    = [e' | evalIsNewExpr]  ++ map (\(_, e, _) -> e) rws+          acc' = exprsToAdd ++ acc+          eqnToAdd = [ (e1, simplify γ ctx e2) | ((e1, e2), _, _) <- rws ]++      newEqualities <- gets evNewEqualities+      smtCache <- liftIO $ readIORef cacheRef+      modify (\st ->+             st { evNewEqualities  = foldr S.insert (S.union newEqualities oldEqualities) eqnToAdd+                , evSMTCache = smtCache+                , explored = Just $ ExploredTerms.insert+                  (Rewrite.convert e)+                  (c rp)+                  (S.insert (Rewrite.convert e') $ S.fromList (map (Rewrite.convert . (\(_, e, _) -> e)) possibleRWs))+                  (Mb.fromJust $ explored st)+                })++      acc'' <- if evalIsNewExpr+        then if fe && any isRW (path rp)+          then (:[]) . fst <$> eval γ (addConst (e, e')) NoRW e'+          else evalRESTWithCache cacheRef γ (addConst (e, e')) acc' (rpEval newEqualities e')+        else return acc'++      foldM (\r rw -> evalRESTWithCache cacheRef γ ctx r (rpRW rw)) acc'' rws+     else+      return acc+  where+    shouldExploreTerm exploredTerms e | Vis.isConc e =+      case rwTerminationOpts rwArgs of+        RWTerminationCheckDisabled ->+          return $ not $ ExploredTerms.visited (Rewrite.convert e) exploredTerms+        RWTerminationCheckEnabled  ->+          ExploredTerms.shouldExplore (Rewrite.convert e) (c rp) exploredTerms+    shouldExploreTerm _ _ = return False++    allowed (_, rwE, _) | rwE `elem` pathExprs = return False+    allowed (_, _, c)   = termCheck c+    termCheck c = Rewrite.passesTerminationCheck (oc rp) rwArgs c++    notVisitedFirst exploredTerms rws =+      let+        (v, nv) = L.partition (\(_, e, _) -> ExploredTerms.visited (Rewrite.convert e) exploredTerms) rws+      in+        nv ++ v++    rpEval newEqualities e' =+      let+        c' =+          if any isRW (path rp)+            then foldr (\(e1, e2) ctrs -> refine (oc rp) ctrs e1 e2) (c rp) (S.toList newEqualities)+            else c rp++      in+        rp{path = path rp ++ [(e', PLE)], c = c'}++    isRW (_, r) = r == RW++    rpRW (_, e', c') = rp{path = path rp ++ [(e', RW)], c = c' }++    pathExprs       = map fst (mytracepp "EVAL2: path" $ path rp)+    e               = last pathExprs+    autorws         = getAutoRws γ ctx++    rwArgs = RWArgs (isValid cacheRef γ) $ knRWTerminationOpts γ++    getRWs =+      do+        -- Optimization: If we got here via rewriting, then the current constraints+        -- are satisfiable; otherwise double-check that rewriting is still allowed+        ok <-+          if isRW $ last (path rp)+            then return True+            else liftIO $ termCheck (c rp)+        if ok+          then+            do+              let e'         = deANF ctx e+              let getRW e ar = Rewrite.getRewrite (oc rp) rwArgs (c rp) e ar+              let getRWs' s  = Mb.catMaybes <$> mapM (liftIO . runMaybeT . getRW s) autorws+              concat <$> mapM getRWs' (subExprs e')+          else return []++    addConst (e,e') = if isConstant (knDCs γ) e'+                      then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx++-- | @evalApp kn ctx e es@ unfolds expressions in @eApps e es@ using rewrites+-- and equations+evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Maybe Expr, FinalExpand)+evalApp γ ctx e0 es et+  | EVar f <- dropECst e0+  , Just eq <- Map.lookup f (knAms γ)+  , length (eqArgs eq) <= length es+  = do+       env  <- gets (seSort . evEnv)+       okFuel <- checkFuel f+       if okFuel && et /= FuncNormal+         then do+                let (es1,es2) = splitAt (length (eqArgs eq)) es+                    newE = substEq env eq es1+                (e', fe) <- evalIte γ ctx et newE -- TODO:FUEL this is where an "unfolding" happens, CHECK/BUMP counter+                let mPLEUnfold = startsWithPLEUnfold e'+                    e2' = Mb.fromMaybe e' mPLEUnfold+                    e3' = simplify γ ctx (eApps e2' es2) -- reduces a bit the equations+                    undecidedGuards = case e' of+                      EIte{} -> True+                      _ -> False++                if not undecidedGuards || Mb.isJust mPLEUnfold+                  then do+                    useFuel f+                    modify $ \st ->+                      st+                        { evNewEqualities = S.insert (eApps e0 es, e3') (evNewEqualities st)+                        , evPendingUnfoldings = M.delete (eApps e0 es) (evPendingUnfoldings st)+                        }+                    return (Just e2', fe)+                  else do+                    modify $ \st ->+                      st {+                        evPendingUnfoldings = M.insert (eApps e0 es) e3' (evPendingUnfoldings st)+                      }+                    -- Don't unfold the expression if there is an if-then-else+                    -- guarding it, just to preserve the size of further+                    -- rewrites.+                    return (Nothing, noExpand)+         else return (Nothing, noExpand)+  where+    -- At the time of writing, any function application wrapping an+    -- if-statement would have the effect of unfolding the invocation.+    -- However, using pleUnfold still has the advantage of not generating+    -- extra equations to unfold pleUnfold itself. Using pleUnfold also+    -- makes the intention of the user rather explicit.+    startsWithPLEUnfold e+      | (ef, [arg]) <- splitEAppThroughECst e+      , EVar f <- dropECst ef+      , f == "Language.Haskell.Liquid.ProofCombinators.pleUnfold"+      = Just arg+      | otherwise = Nothing++evalApp γ ctx e0 args@(e:es) _+  | EVar f <- dropECst e0+  , (d, as) <- splitEAppThroughECst e+  , EVar dc <- dropECst d+  , Just rws <- Map.lookup dc (knSims γ)+    -- User data measures aren't sent to the SMT solver because+    -- it knows already about selectors and constructor tests.+  , Just (rw, isUserDataSMeasure) <- L.find (\(rw, _) -> smName rw == f) rws+  , length as == length (smArgs rw)+  = do+    let newE = eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es+    when (isUserDataSMeasure == NoUserDataSMeasure) $+      modify $ \st ->+        st { evNewEqualities =+               S.insert (eApps e0 args, simplify γ ctx newE) (evNewEqualities st)+           }+    return (Just newE, noExpand)++evalApp γ ctx e0 es _et+  | eqs@(_:_) <- noUserDataMeasureEqs γ (eApps e0 es)+  = do+       let eqs' = map (second $ simplify γ ctx) eqs+       modify $ \st ->+         st { evNewEqualities = foldr S.insert (evNewEqualities st) eqs' }+       return (Nothing, noExpand)++evalApp _ _ _e _es _+  = return (Nothing, noExpand)++-- | Evaluates if-then-else statements until they can't be evaluated anymore+-- or some other expression is found.+evalIte :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand)+evalIte γ ctx et (EIte i e1 e2) = do+      (b, _) <- eval γ ctx et i+      b'  <- mytracepp ("evalEIt POS " ++ showpp (i, b)) <$> isValidCached γ b+      case b' of+        Just True -> evalIte γ ctx et e1+        Just False -> evalIte γ ctx et e2+        _ -> return (EIte b e1 e2, expand)+evalIte _ _ _ e' = return (e', noExpand)++-- | Creates equations that explain how to rewrite a given constructor+-- application with all measures that aren't user data measures+noUserDataMeasureEqs :: Knowledge -> Expr -> [(Expr,Expr)]+noUserDataMeasureEqs γ e =+  [ (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw))+  | (ef, es) <- [splitEAppThroughECst e]+  , EVar f <- [dropECst ef]+  , Just rws <- [Map.lookup f (knSims γ)]+  , (rw, NoUserDataSMeasure) <- rws+  , length es == length (smArgs rw)+  ]++--------------------------------------------------------------------------------+-- | 'substEq' unfolds or instantiates an equation at a particular list of+--   argument values. We must also substitute the sort-variables that appear+--   as coercions. See tests/proof/ple1.fq+--------------------------------------------------------------------------------+substEq :: SEnv Sort -> Equation -> [Expr] -> Expr+substEq env eq es = subst su (substEqCoerce env eq es)+  where su = mkSubst $ zip (eqArgNames eq) es++substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr+substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq+  where+    ts    = snd    <$> eqArgs eq+    sp    = panicSpan "mkCoSub"+    eTs   = sortExpr sp env <$> es+    coSub = mkCoSub env eTs ts++-- | @mkCoSub senv eTs xTs = su@ creates a substitution @su@ such that+-- @subst su xTs == eTs@.+--+-- The variables in the domain of the substitution are those that appear+-- as @FObj symbol@ in @xTs@.+mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub+mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ]+  where+    unite ts    = Mb.fromMaybe (uError ts) (unifyTo1 senv ts)+    senv        = mkSearchEnv env+    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts)+    xys         = Misc.sortNub $ concat $ zipWith matchSorts xTs eTs++matchSorts :: Sort -> Sort -> [(Symbol, Sort)]+matchSorts s1 s2 = go s1 s2+  where+    go (FObj x)      {-FObj-} y    = [(x, y)]+    go (FAbs _ t1)   (FAbs _ t2)   = go t1 t2+    go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2+    go (FApp s1 t1)  (FApp s2 t2)  = go s1 s2 ++ go t1 t2+    go _             _             = []++--------------------------------------------------------------------------------++eqArgNames :: Equation -> [Symbol]+eqArgNames = map fst . eqArgs++isValidCached :: Knowledge -> Expr -> EvalST (Maybe Bool)+isValidCached γ e = do+  env <- get+  case M.lookup e (evSMTCache env) of+    Nothing -> do+      let isFreeInE (s, _) = not (S.member s (exprSymbolsSet e))+      b <- liftIO $ knPreds γ (knContext γ) (knLams γ) e+      if b+        then do+          when (all isFreeInE (knLams γ)) $+            put (env { evSMTCache = M.insert e True (evSMTCache env) })+          return (Just True)+        else do+          b2 <- liftIO $ knPreds γ (knContext γ) (knLams γ) (PNot e)+          if b2+            then do+              when (all isFreeInE (knLams γ)) $+                put (env { evSMTCache = M.insert e False (evSMTCache env) })+              return (Just False)+            else+              return Nothing++    mb -> return mb++--------------------------------------------------------------------------------+-- | Knowledge (SMT Interaction)+--------------------------------------------------------------------------------+data Knowledge = KN+  { -- | Rewrites rules came from match definitions+    --+    -- They are grouped by the data constructor that they unfold, and are+    -- augmented with an attribute that say whether they originate from a+    -- user data declaration.+    knSims              :: Map Symbol [(Rewrite, IsUserDataSMeasure)]+  , knAms               :: Map Symbol Equation -- ^ All function definitions+  , knContext           :: SMT.Context+  , knPreds             :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool+  , knLams              :: ![(Symbol, Sort)]+  , knSummary           :: ![(Symbol, Int)]     -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity+  , knDCs               :: !(S.HashSet Symbol)  -- ^ data constructors drawn from Rewrite+  , knDataCtors         :: !(M.HashMap Symbol DataCtor) -- ^ data constructors by name+  , knSels              :: !SelectorMap+  , knConsts            :: !ConstDCMap+  , knAutoRWs           :: M.HashMap SubcId [AutoRewrite]+  , knRWTerminationOpts :: RWTerminationOpts+  }++-- | A type to express whether SMeasures originate from data definitions.+-- That is whether they are constructor tests, selectors, or something else.+data IsUserDataSMeasure = NoUserDataSMeasure | UserDataSMeasure+  deriving (Eq, Show)++isValid :: IORef (M.HashMap Expr Bool) -> Knowledge -> Expr -> IO Bool+isValid cacheRef γ e = do+    smtCache <- readIORef cacheRef+    case M.lookup e smtCache of+      Nothing -> do+        b <- knPreds γ (knContext γ) (knLams γ) e+        when b $+          writeIORef cacheRef (M.insert e True smtCache)+        return b+      mb -> return (mb == Just True)++knowledge :: Config -> SMT.Context -> SInfo a -> Knowledge+knowledge cfg ctx si = KN+  { knSims                     = Map.fromListWith (++) $+                                   [ (smDC rw, [(rw, NoUserDataSMeasure)]) | rw <- sims ] +++                                   [ (smDC rw, [(rw, UserDataSMeasure)]) | rw <- dataSims ]+  , knAms                      = Map.fromList [(eqName eq, eq) | eq <- aenvEqs aenv]+  , knContext                  = ctx+  , knPreds                    = askSMT  cfg+  , knLams                     = []+  , knSummary                  =    ((\s -> (smName s, 1)) <$> sims)+                                 ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv)+                                 ++ rwSyms+  , knDCs                      = S.fromList (smDC <$> sims)+  , knDataCtors                = M.fromList [ (val (dcName dc), dc) | dd <- ddecls si, dc <- ddCtors dd ]+  , knSels                     = Mb.mapMaybe makeSel  sims+  , knConsts                   = Mb.mapMaybe makeCons sims+  , knAutoRWs                  = aenvAutoRW aenv+  , knRWTerminationOpts        =+      if rwTerminationCheck cfg+      then RWTerminationCheckEnabled+      else RWTerminationCheckDisabled+  }+  where+    (simDCTests, sims0) =+      partitionUserDataConstructorTests (ddecls si) $ aenvSimpl aenv+    (simDCSelectors, sims) =+      partitionUserDataConstructorSelectors (ddecls si) sims0+    dataSims = simDCTests ++ simDCSelectors+    aenv = ae si++    inRewrites :: Symbol -> Bool+    inRewrites e =+      let+        syms = Mb.mapMaybe (lhsHead . arLHS) (concat $ M.elems $ aenvAutoRW aenv)+      in+        e `L.elem` syms++    lhsHead :: Expr -> Maybe Symbol+    lhsHead e | (ef, _) <- splitEAppThroughECst e, EVar f <- dropECst ef = Just f+    lhsHead _ = Nothing+++    rwSyms = filter (inRewrites . fst) $ map toSum (toListSEnv (gLits si))+      where+        toSum (sym, sort)      = (sym, getArity sort)++        getArity (FFunc _ rhs) = 1 + getArity rhs+        getArity _             = 0++++    makeCons rw+      | null (syms $ smBody rw)+      = Just (smName rw, (smDC rw, smBody rw))+      | otherwise+      = Nothing++    makeSel rw+      | EVar x <- smBody rw+      = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw)+      | otherwise+      = Nothing++-- | Partitions the input rewrites into constructor tests and others.+--+-- We don't need to deal in PLE with data constructor tests. That is,+-- functions of the form @isCons :: List a -> Bool@ or @isNil :: List a -> Bool@+-- when @List a@ is defined by the user.+--+-- The SMT solver knows about these functions when datatypes are declared to it,+-- so PLE doesn't need to unfold them.+--+-- Non-user defined datatypes like @[a]@ still need to have tests unfolded+-- because they are not declared as datatypes to the SMT solver.+--+-- Also, REST could need this functions unfolded since otherwise it may not+-- discover possible rewrites.+--+partitionUserDataConstructorTests :: [DataDecl] -> [Rewrite] -> ([Rewrite], [Rewrite])+partitionUserDataConstructorTests dds rws = L.partition isDataConstructorTest rws+  where+    isDataConstructorTest sm = isTestSymbol (smName sm) && S.member (smDC sm) userDefinedDcs+    userDefinedDcs =+      S.fromList [ symbol (dcName dc) | dd <- dds, dc <- ddCtors dd ]++-- | Like 'partitionUserDataConstructorTests' but for selectors.+partitionUserDataConstructorSelectors :: [DataDecl] -> [Rewrite] -> ([Rewrite], [Rewrite])+partitionUserDataConstructorSelectors dds rws = L.partition isSelector rws+  where+    isSelector sm = S.member (smName sm) userDefinedDcFieldsSelectors+    userDefinedDcFieldsSelectors =+      S.fromList [ symbol dcf | dd <- dds, dc <- ddCtors dd, dcf <- dcFields dc ]+++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++withCtx :: Config -> FilePath -> SymEnv -> (SMT.Context -> IO a) -> IO a+withCtx cfg file env k = do+  ctx <- SMT.makeContextWithSEnv cfg file env+  _   <- SMT.smtPush ctx+  res <- k ctx+  _   <- SMT.cleanupContext ctx+  return res+++-- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi,+-- i.e., sel_i selects the ith value for the data constructor D+type SelectorMap = [(Symbol, (Symbol, Int))]+type ConstDCMap = [(Symbol, (Symbol, Expr))]++-- ValueMap maps expressions to constants (including data constructors)+type ConstMap = M.HashMap Expr Expr+type LDataCon = Symbol              -- Data Constructors++isConstant :: S.HashSet LDataCon -> Expr -> Bool+isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs)++simplify :: Knowledge -> ICtx -> Expr -> Expr+simplify γ ictx e = mytracepp ("simplification of " ++ showpp e) $ fix (Vis.mapExprOnExpr tx) e+    where+      fix f e = if e == e' then e else fix f e' where e' = f e+      tx e+        | Just e' <- M.lookup e (icSimpl ictx)+        = e'++      tx (PAtom rel e1 e2) = applyBooleanFolding rel e1 e2+      tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2+      tx (ENeg e)         = applyConstantFolding Minus (ECon (I 0)) e+      tx (EApp e1 e2)+        | isSetPred e1    = applySetFolding e1 e2++      tx (EApp ef a)+        | EVar f <- dropECst ef+        , Just (dc, c)  <- L.lookup f (knConsts γ)+        , (ed, _) <- splitEAppThroughECst a+        , EVar dc' <- dropECst ed+        , dc == dc'+        = c+      tx (EIte b e1 e2)+        | isTautoPred b  = e1+        | isContraPred b = e2+      tx (ECoerc s t e)+        | s == t = e+      tx (EApp ef a)+        | EVar f <- dropECst ef+        , Just (dc, i)  <- L.lookup f (knSels γ)+        , (ed, es) <- splitEAppThroughECst a+        , EVar dc' <- dropECst ed+        , dc == dc'+        = es!!i+      tx e = e+++-------------------------------------------------------------------------------+-- | Normalization of Equation: make their arguments unique -------------------+-------------------------------------------------------------------------------++class Normalizable a where+  normalize :: a -> a++instance Normalizable (GInfo c a) where+  normalize si = si {ae = normalize $ ae si}++instance Normalizable AxiomEnv where+  normalize aenv = aenv { aenvEqs   = mytracepp "aenvEqs"  (normalize <$> aenvEqs   aenv)+                        , aenvSimpl = mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) }++instance Normalizable Rewrite where+  normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw }+    where+      su  = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'+      xs  = smArgs rw+      xs' = zipWith mkSymbol xs [0 :: Integer ..]+      mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i+++instance Normalizable Equation where+  normalize eq = eq {eqArgs = zip xs' ss, eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq }+    where+      su      = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'+      (xs,ss) = unzip (eqArgs eq)+      xs'     = zipWith mkSymbol xs [0 :: Integer ..]+      mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i++-- | Normalize the given named expression if it is recursive.+normalizeBody :: Symbol -> Expr -> Expr+normalizeBody f e | f `elem` syms e = go e+  where+    -- @go@ performs this simplification:+    --     (c => e1) /\ ((not c) => e2) --> if c then e1 else e2+    -- and then recurses into  e2.+    --+    -- The expressions originate from Haskell's reflect annotations, so we know+    -- that e1 is a conjunction of data constructor checkers and we do not need+    -- to recurse into e1.+    go (PAnd [PImp c e1, PImp (PNot c') e2]) | c == c' = EIte c e1 (go e2)+    go e                                               = e+normalizeBody _ e = e -- The expression is not recursive, return it unchanged.++-- -- TODO:FUEL Config+-- maxFuel :: Int+-- maxFuel = 11++-- | Increment the fuel count of the given symbol in the current evaluation+-- environment.+useFuel :: Symbol -> EvalST ()+useFuel f = do+  modify (\st -> st { evFuel = useFuelCount f (evFuel st) })++-- | Increment the fuel count.+useFuelCount :: Symbol -> FuelCount -> FuelCount+useFuelCount f fc = fc { fcMap = M.insert f (k + 1) m }+  where+    k             = M.lookupDefault 0 f m+    m             = fcMap fc++-- | Returns False if there is a fuel count in the evaluation environment and+-- the fuel count exceeds the maximum. Returns True otherwise.+checkFuel :: Symbol -> EvalST Bool+checkFuel f = do   fc <- gets evFuel   case (M.lookup f (fcMap fc), fcMax fc) of     (Just fk, Just n) -> pure (fk <= n)

src/Language/Fixpoint/Solver/Prettify.hs view

@@ -1,10 +1,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms            #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | Functions to make environments easier to read module Language.Fixpoint.Solver.Prettify (savePrettifiedQuery) where @@ -23,7 +23,7 @@   , inlineInSortedReft   , mergeDuplicatedBindings   , simplifyBooleanRefts-  , undoANF+  , undoANFAndVV   ) import           Language.Fixpoint.Types.Config (Config, queryFile) import           Language.Fixpoint.Types.Constraints@@ -41,9 +41,11 @@ import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Refinements   ( Expr(..)+  , pattern PFalse   , Reft   , SortedReft(..)   , conjuncts+  , expr   , reft   , reftBind   , reftPred@@ -69,31 +71,35 @@ prettyConstraints :: Fixpoint a => FInfo a -> Doc prettyConstraints fi =   vcat $-  map (prettyConstraint (bs fi)) $-  map snd $-  sortOn fst $-  HashMap.toList (cm fi)+  map+    (prettyConstraint (bs fi) . snd)+    (sortOn fst $ HashMap.toList (cm fi))  prettyConstraint   :: Fixpoint a-  => BindEnv+  => BindEnv a   -> SubC a   -> Doc prettyConstraint bindEnv c =-  let env = [ (s, ([bId], sr))+  let env = [ (s, ([(bId, a)], sr))             | bId <- elemsIBindEnv $ senv c-            , let (s, sr) = lookupBindEnv bId bindEnv+            , let (s, sr, a) = lookupBindEnv bId bindEnv             ]       mergedEnv = mergeDuplicatedBindings env-      undoANFEnv = HashMap.union (undoANF mergedEnv) mergedEnv-      boolSimplEnv = HashMap.union (simplifyBooleanRefts undoANFEnv) undoANFEnv+      undoANFEnv = undoANFAndVV mergedEnv+      boolSimplEnvDiff = simplifyBooleanRefts undoANFEnv+      boolSimplEnv = HashMap.map snd $ HashMap.union boolSimplEnvDiff undoANFEnv -      simplifiedLhs = inlineInSortedReft boolSimplEnv (slhs c)-      simplifiedRhs = inlineInSortedReft boolSimplEnv (srhs c)+      simplifiedLhs = simplify $ inlineInSortedReft (`HashMap.lookup` boolSimplEnv) (slhs c)+      simplifiedRhs = simplify $ inlineInSortedReft (`HashMap.lookup` boolSimplEnv) (srhs c)        prunedEnv =-        dropLikelyIrrelevantBindings (constraintSymbols simplifiedLhs simplifiedRhs) $-        HashMap.map snd boolSimplEnv+        if expr simplifiedRhs /= PFalse then+          dropLikelyIrrelevantBindings+            (constraintSymbols simplifiedLhs simplifiedRhs)+            boolSimplEnv+        else+          boolSimplEnv       (renamedEnv, c') =         shortenVarNames prunedEnv c { slhs = simplifiedLhs, srhs = simplifiedRhs }       prettyEnv =@@ -181,16 +187,16 @@     renameSortedReft       :: HashMap Symbol Symbol -> SortedReft -> SortedReft     renameSortedReft symMap (RR t r) =-      let sortSubst = FObj . (at symMap)+      let sortSubst = FObj . at symMap        in RR (substSort sortSubst t) (renameReft symMap r)      renameReft :: HashMap Symbol Symbol -> Reft -> Reft     renameReft symMap r =       let m = HashMap.insert (reftBind r) (prefixOfSym $ reftBind r) symMap-          sortSubst = FObj . (at symMap)+          sortSubst = FObj . at symMap        in reft (at m (reftBind r)) $             substSortInExpr sortSubst $-            (substf (EVar . (at m)) $ reftPred r)+            substf (EVar . at m) (reftPred r)      at :: HashMap Symbol Symbol -> Symbol -> Symbol     at m k = fromMaybe k $ HashMap.lookup k m@@ -220,7 +226,7 @@ -- -- > forall ss. -- > Set.fromList ss == Set.fromList $ concat [ xs | m <- elems (toPrefixSuffixMap ss), xs <- elems m ]--- +-- -- > forall ss. -- > and [ all (pfx `isPrefixOfSym`) xs && all (sfx `isSuffixOfSym`) xs -- >     | (pfx, m) <- toList (toPrefixSuffixMap ss)@@ -251,7 +257,7 @@      renameWithAppendages pfx (sfx, ss) = zip ss $ case ss of       [_s] -> [pfx `suffixIfNotNull` sfx]-      ss -> zipWith (rename pfx sfx) [1..] ss+      ss -> zipWith (rename pfx sfx) [1 :: Integer ..] ss      rename pfx sfx i _s =       pfx `suffixIfNotNull` sfx `suffixSymbol` symbol (show i)

src/Language/Fixpoint/Solver/Rewrite.hs view

@@ -1,11 +1,13 @@-{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE PatternGuards             #-} {-# LANGUAGE ScopedTypeVariables       #-} +{-# OPTIONS_GHC -Wno-name-shadowing    #-}+ module Language.Fixpoint.Solver.Rewrite   ( getRewrite-  -- , getRewrite'   , subExprs   , unify   , ordConstraints@@ -15,22 +17,32 @@   , RWTerminationOpts(..)   , SubExpr   , TermOrigin(..)+  , OCType+  , RESTOrdering(..)   ) where -import           Control.Monad.State+import           Control.Monad.State (guard) import           Control.Monad.Trans.Maybe+import           Data.Hashable import qualified Data.HashMap.Strict  as M import qualified Data.List            as L import qualified Data.Text as TX import           GHC.IO.Handle.Types (Handle)+import           GHC.Generics import           Text.PrettyPrint (text)+import           Language.Fixpoint.Types.Config (RESTOrdering(..)) import           Language.Fixpoint.Types hiding (simplify) import           Language.REST-import           Language.REST.AbstractOC-import qualified Language.REST.RuntimeTerm as RT+import           Language.REST.KBO (kbo)+import           Language.REST.LPO (lpo)+import           Language.REST.OCAlgebra as OC+import           Language.REST.OCToAbstract (lift) import           Language.REST.Op-import           Language.REST.OrderingConstraints.ADT (ConstraintsADT)+import           Language.REST.SMT (SMTExpr)+import           Language.REST.WQOConstraints.ADT (ConstraintsADT, adtOC)+import qualified Language.REST.RuntimeTerm as RT +-- | @(e, f)@ asserts that @e@ is a subexpression of @f e@ type SubExpr = (Expr, Expr -> Expr)  data TermOrigin = PLE | RW deriving (Show, Eq)@@ -48,13 +60,40 @@  , rwTerminationOpts  :: RWTerminationOpts  } -ordConstraints :: (Handle, Handle) -> AbstractOC (ConstraintsADT Op) Expr IO-ordConstraints solver = contramap convert (adtRPO solver)+-- Monomorphize ordering constraints so we don't litter PLE with type variables+-- Also helps since GHC doesn't support impredicate polymorphism (yet)+data OCType =+    RPO (ConstraintsADT Op)+  | LPO (ConstraintsADT Op)+  | KBO (SMTExpr Bool)+  | Fuel Int+  deriving (Eq, Show, Generic, Hashable) +ordConstraints :: RESTOrdering -> (Handle, Handle) -> OCAlgebra OCType RT.RuntimeTerm IO+ordConstraints RESTRPO      solver = bimapConstraints RPO asRPO (adtRPO solver)+  where+    asRPO (RPO t) = t+    asRPO _       = undefined +ordConstraints RESTKBO      solver = bimapConstraints KBO asKBO (kbo solver)+  where+    asKBO (KBO t) = t+    asKBO _       = undefined++ordConstraints RESTLPO      solver = bimapConstraints LPO asLPO (lift (adtOC solver) lpo)+  where+    asLPO (LPO t) = t+    asLPO _       = undefined++ordConstraints (RESTFuel n) _      = bimapConstraints Fuel asFuel $ fuelOC n+  where+    asFuel (Fuel n) = n+    asFuel _        = undefined++ convert :: Expr -> RT.RuntimeTerm convert (EIte i t e)   = RT.App "$ite" $ map convert [i,t,e]-convert e@(EApp{})     | (EVar fName, terms) <- splitEApp e+convert e@EApp{}       | (f, terms) <- splitEAppThroughECst e, EVar fName <- dropECst f                        = RT.App (Op (symbolText fName)) $ map convert terms convert (EVar s)       = RT.App (Op (symbolText s)) [] convert (PNot e)       = RT.App "$not" [ convert e ]@@ -65,35 +104,46 @@ convert (ECon c)       = RT.App (Op $ "$econ" `TX.append` (TX.pack . show) c) [] convert (ESym (SL tx)) = RT.App (Op tx) [] convert (ECst t _)     = convert t+convert (PIff e0 e1)   = convert (PAtom Eq e0 e1)+convert (PImp e0 e1)   = convert (POr [PNot e0, e1]) convert e              = error (show e) -passesTerminationCheck :: AbstractOC oc a IO -> RewriteArgs -> oc -> IO Bool+passesTerminationCheck :: OCAlgebra oc a IO -> RewriteArgs -> oc -> IO Bool passesTerminationCheck aoc rwArgs c =   case rwTerminationOpts rwArgs of     RWTerminationCheckEnabled  -> isSat aoc c     RWTerminationCheckDisabled -> return True +-- | Yields the result of rewriting an expression with an autorewrite equation.+--+-- Yields nothing if:+--+--  * The result of the rewrite is identical to the original expression+--  * Any of the arguments of the autorewrite has a refinement type which is+--    not satisfied in the current context.+-- getRewrite ::-     AbstractOC oc Expr IO+     OCAlgebra oc Expr IO   -> RewriteArgs   -> oc   -> SubExpr   -> AutoRewrite-  -> MaybeT IO (Expr, oc)+  -> MaybeT IO ((Expr, Expr), Expr, oc) getRewrite aoc rwArgs c (subE, toE) (AutoRewrite args lhs rhs) =   do     su <- MaybeT $ return $ unify freeVars lhs subE     let subE' = subst su rhs     guard $ subE /= subE'     let expr' = toE subE'+        eqn = (subst su lhs, subE')     mapM_ (checkSubst su) exprs     return $ case rwTerminationOpts rwArgs of       RWTerminationCheckEnabled ->         let           c' = refine aoc c subE subE'         in-          (expr', c')-      RWTerminationCheckDisabled -> (expr', c)+          (eqn, expr', c')+      RWTerminationCheckDisabled -> (eqn, expr', c)   where     check :: Expr -> MaybeT IO ()     check e = do@@ -105,7 +155,7 @@      checkSubst su (s, e) =       do-        let su' = (catSubst su $ mkSubst [("VV", subst su (EVar s))])+        let su' = catSubst su $ mkSubst [("VV", subst su (EVar s))]         -- liftIO $ printf "Substitute %s in %s\n" (show su') (show e)         check $ subst (catSubst su su') e @@ -127,7 +177,7 @@     lhs'' = map (\(e, f) -> (e, \e' -> EBin op (f e') rhs)) lhs'     rhs'' :: [SubExpr]     rhs'' = map (\(e, f) -> (e, \e' -> EBin op lhs (f e'))) rhs'-    + subExprs' (PImp lhs rhs) = lhs'' ++ rhs''   where     lhs' = subExprs lhs@@ -136,7 +186,16 @@     lhs'' = map (\(e, f) -> (e, \e' -> PImp (f e') rhs)) lhs'     rhs'' :: [SubExpr]     rhs'' = map (\(e, f) -> (e, \e' -> PImp lhs (f e'))) rhs'-    ++subExprs' (PIff lhs rhs) = lhs'' ++ rhs''+  where+    lhs' = subExprs lhs+    rhs' = subExprs rhs+    lhs'' :: [SubExpr]+    lhs'' = map (\(e, f) -> (e, \e' -> PIff (f e') rhs)) lhs'+    rhs'' :: [SubExpr]+    rhs'' = map (\(e, f) -> (e, \e' -> PIff lhs (f e'))) rhs'+ subExprs' (PAtom op lhs rhs) = lhs'' ++ rhs''   where     lhs' = subExprs lhs@@ -146,10 +205,10 @@     rhs'' :: [SubExpr]     rhs'' = map (\(e, f) -> (e, \e' -> PAtom op lhs (f e'))) rhs' -subExprs' e@(EApp{}) =-  if (f == EVar "Language.Haskell.Liquid.ProofCombinators.===" ||-      f == EVar "Language.Haskell.Liquid.ProofCombinators.==." ||-      f == EVar "Language.Haskell.Liquid.ProofCombinators.?")+subExprs' e@EApp{} =+  if f == EVar "Language.Haskell.Liquid.ProofCombinators.===" ||+     f == EVar "Language.Haskell.Liquid.ProofCombinators.==." ||+     f == EVar "Language.Haskell.Liquid.ProofCombinators.?"   then []   else concatMap replace indexedArgs     where@@ -157,10 +216,31 @@       indexedArgs      = zip [0..] es       replace (i, arg) = do         (subArg, toArg) <- subExprs arg-        return (subArg, \subArg' -> eApps f $ (take i es) ++ (toArg subArg'):(drop (i+1) es))+        return (subArg, \subArg' -> eApps f $ take i es ++ toArg subArg' : drop (i+1) es) +subExprs' (ECst e t) =+    [ (e', \subE -> ECst (toE subE) t) | (e', toE) <- subExprs' e ]++subExprs' (PAnd es) = [ (e, PAnd . f) | (e, f) <- subs es ]++subExprs' (POr es) = [ (e, POr . f) | (e, f) <- subs es ]+ subExprs' _ = [] +-- | Computes the subexpressions of a list of expressions.+-- Each subexpression comes with a function that rebuilds the+-- context in which the subexpression occurs.+--+-- > and [ es == f e | (e, f) <- subs es ]+--+subs :: [Expr] -> [(Expr, Expr -> [Expr])]+subs [] = []+subs [x] = [ (s, \e -> [f e]) | (s, f) <- subExprs x ]+subs (x:xs) = [ (s, \e -> f e : xs) | (s, f) <- subExprs x ]+              +++              [ (s, \e -> x : f e) | (s, f) <- subs xs ]++ unifyAll :: [Symbol] -> [Expr] -> [Expr] -> Maybe Subst unifyAll _ []     []               = Just (Su M.empty) unifyAll freeVars (template:xs) (seen:ys) =@@ -172,50 +252,60 @@     return $ Su (M.union s1 s2) unifyAll _ _ _ = undefined +-- | @unify vs template e = Just su@ yields a substitution @su@+-- such that subst su template == e+--+-- Moreover, @su@ is constraint to only substitute variables in @vs@.+--+-- Yields @Nothing@ if no substitution exists.+-- unify :: [Symbol] -> Expr -> Expr -> Maybe Subst unify _ template seenExpr | template == seenExpr = Just (Su M.empty)-unify freeVars template seenExpr = case (template, seenExpr) of+unify freeVars template seenExpr = case (dropECst template, seenExpr) of+  -- preserve seen casts if possible   (EVar rwVar, _) | rwVar `elem` freeVars ->     return $ Su (M.singleton rwVar seenExpr)-  (EVar lhs, EVar rhs) | removeModName lhs == removeModName rhs ->-                         Just (Su M.empty)-    where-      removeModName ts = go "" (symbolString ts) where-        go buf []         = buf-        go _   ('.':rest) = go [] rest-        go buf (x:xs)     = go (buf ++ [x]) xs-  (EApp templateF templateBody, EApp seenF seenBody) ->-    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-  (ENeg rw, ENeg seen) ->-    unify freeVars rw seen-  (EBin op rwLeft rwRight, EBin op' seenLeft seenRight) | op == op' ->-    unifyAll freeVars [rwLeft, rwRight] [seenLeft, seenRight]-  (EIte cond rwLeft rwRight, EIte seenCond seenLeft seenRight) ->-    unifyAll freeVars [cond, rwLeft, rwRight] [seenCond, seenLeft, seenRight]-  (ECst rw _, ECst seen _) ->-    unify freeVars rw seen-  (ETApp rw _, ETApp seen _) ->-    unify freeVars rw seen-  (ETAbs rw _, ETAbs seen _) ->-    unify freeVars rw seen-  (PAnd rw, PAnd seen ) ->-    unifyAll freeVars rw seen-  (POr rw, POr seen ) ->-    unifyAll freeVars rw seen-  (PNot rw, PNot seen) ->-    unify freeVars rw seen-  (PImp templateF templateBody, PImp seenF seenBody) ->-    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-  (PIff templateF templateBody, PIff seenF seenBody) ->-    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-  (PAtom rel templateF templateBody, PAtom rel' seenF seenBody) | rel == rel' ->-    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-  (PAll _ rw, PAll _ seen) ->-    unify freeVars rw seen-  (PExist _ rw, PExist _ seen) ->-    unify freeVars rw seen-  (PGrad _ _ _ rw, PGrad _ _ _ seen) ->-    unify freeVars rw seen-  (ECoerc _ _ rw, ECoerc _ _ seen) ->-    unify freeVars rw seen-  _ -> Nothing+  -- otherwise discard the seen casts+  (template', _) -> case (template', dropECst seenExpr) of+    (EVar lhs, EVar rhs) | removeModName lhs == removeModName rhs ->+                           Just (Su M.empty)+      where+        removeModName ts = go "" (symbolString ts) where+          go buf []         = buf+          go _   ('.':rest) = go [] rest+          go buf (x:xs)     = go (buf ++ [x]) xs+    (EApp templateF templateBody, EApp seenF seenBody) ->+      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+    (ENeg rw, ENeg seen) ->+      unify freeVars rw seen+    (EBin op rwLeft rwRight, EBin op' seenLeft seenRight) | op == op' ->+      unifyAll freeVars [rwLeft, rwRight] [seenLeft, seenRight]+    (EIte cond rwLeft rwRight, EIte seenCond seenLeft seenRight) ->+      unifyAll freeVars [cond, rwLeft, rwRight] [seenCond, seenLeft, seenRight]+    (ECst rw _, seen) ->+      unify freeVars rw seen+    (ETApp rw _, ETApp seen _) ->+      unify freeVars rw seen+    (ETAbs rw _, ETAbs seen _) ->+      unify freeVars rw seen+    (PAnd rw, PAnd seen ) ->+      unifyAll freeVars rw seen+    (POr rw, POr seen ) ->+      unifyAll freeVars rw seen+    (PNot rw, PNot seen) ->+      unify freeVars rw seen+    (PImp templateF templateBody, PImp seenF seenBody) ->+      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+    (PIff templateF templateBody, PIff seenF seenBody) ->+      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+    (PAtom rel templateF templateBody, PAtom rel' seenF seenBody) | rel == rel' ->+      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+    (PAll _ rw, PAll _ seen) ->+      unify freeVars rw seen+    (PExist _ rw, PExist _ seen) ->+      unify freeVars rw seen+    (PGrad _ _ _ rw, PGrad _ _ _ seen) ->+      unify freeVars rw seen+    (ECoerc _ _ rw, ECoerc _ _ seen) ->+      unify freeVars rw seen+    _ -> Nothing

src/Language/Fixpoint/Solver/Sanitize.hs view

@@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards     #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Solver.Sanitize   ( -- * Transform FInfo to enforce invariants     sanitize@@ -16,13 +18,13 @@   ) where  import           Language.Fixpoint.Types.PrettyPrint-import           Language.Fixpoint.Types.Visitor +import           Language.Fixpoint.Types.Visitor import           Language.Fixpoint.SortCheck     (elaborate, applySorts, isFirstOrder)--- import           Language.Fixpoint.Defunctionalize +-- import           Language.Fixpoint.Defunctionalize import qualified Language.Fixpoint.Misc                            as Misc import qualified Language.Fixpoint.Types                           as F import           Language.Fixpoint.Types.Config (Config)-import qualified Language.Fixpoint.Types.Config as Cfg +import qualified Language.Fixpoint.Types.Config as Cfg import qualified Language.Fixpoint.Types.Errors                    as E import qualified Language.Fixpoint.Smt.Theories                    as Thy import           Language.Fixpoint.Graph (kvEdges, CVertex (..))@@ -88,11 +90,11 @@  cancelCoercion :: F.SInfo a -> F.SInfo a cancelCoercion = mapExpr (trans (defaultVisitor { txExpr = go }) () ())-  where -    go _ (F.ECoerc t1 t2 (F.ECoerc t2' t1' e)) +  where+    go _ (F.ECoerc t1 t2 (F.ECoerc t2' t1' e))       | t1 == t1' && t2 == t2'-      = e -    go _ e = e +      = e+    go _ e = e  -------------------------------------------------------------------------------- -- | `eliminateEta` converts equations of the form f x = g x into f = g@@ -100,13 +102,13 @@ eliminateEta :: Config -> F.SInfo a -> F.SInfo a -------------------------------------------------------------------------------- eliminateEta cfg si-  | Cfg.etaElim cfg +  | Cfg.etaElim cfg   , Cfg.oldPLE  cfg   = si { F.ae = ae' }-  | Cfg.etaElim cfg +  | Cfg.etaElim cfg   = si { F.ae = (ae {F.aenvEqs = etaElimNEW `fmap` F.aenvEqs ae }) }-  | otherwise -  = si +  | otherwise+  = si   where     ae' = ae {F.aenvEqs = eqs}     ae = F.ae si@@ -153,12 +155,12 @@                      , F.eqBody = F.eApps f1 args1'}       where argsAndSorts = F.eqArgs eq             args  = fst <$> argsAndSorts-            args0 = reverse args +            args0 = reverse args             sort  = F.eqSort eq-            +     fapp :: F.Expr -> (F.Expr, [F.Symbol])     fapp ee = fromMaybe (ee, []) (fapp' ee)-    +     fapp' :: F.Expr -> Maybe (F.Expr, [F.Symbol])     fapp' (F.EApp e0 (F.EVar arg)) = do       (fvar, args) <- fapp' e0@@ -313,7 +315,7 @@ initEnv si w = F.fromListSEnv [ (bind i, i) | i <- is ]   where     is       = F.elemsIBindEnv $ F.wenv w-    bind i   = fst (F.lookupBindEnv i be)+    bind i   = Misc.fst3 (F.lookupBindEnv i be)     be       = F.bs si  --------------------------------------------------------------------------------@@ -337,9 +339,10 @@   where     be   = F.bs fi     ids  = F.elemsIBindEnv $ F.senv c-    cDom = [fst $ F.lookupBindEnv i be | i <- ids]-    cRng = concat [S.toList . F.reftFreeVars . F.sr_reft . snd $ F.lookupBindEnv i be | i <- ids]-    fv   = (`Misc.nubDiff` cDom) . filter (not . known) $ cRng +    cDom = [Misc.fst3 $ F.lookupBindEnv i be | i <- ids]+    cRng = concat [S.toList . F.reftFreeVars . F.sr_reft . Misc.snd3 $ F.lookupBindEnv i be | i <- ids]+        ++ F.syms (F.crhs c)+    fv   = (`Misc.nubDiff` cDom) . filter (not . known) $ cRng  badCs :: Misc.ListNE (F.SimpC a, [F.Symbol]) -> E.Error badCs = E.catErrors . map (E.errFreeVarInConstraint . Misc.mapFst F.subcId)@@ -350,7 +353,7 @@ banIrregularData :: F.SInfo a -> SanitizeM (F.SInfo a) banIrregularData fi = Misc.applyNonNull (Right fi) (Left . badDataDecl) bads   where-    bads = F.checkRegular (F.ddecls fi ) +    bads = F.checkRegular (F.ddecls fi )  badDataDecl :: Misc.ListNE F.DataDecl -> E.Error badDataDecl ds = E.catErrors [ E.errBadDataDecl d | d <- ds ]@@ -363,8 +366,8 @@ banQualifFreeVars fi = Misc.applyNonNull (Right fi) (Left . badQuals) bads   where     bads    = [ (q, xs) | q <- F.quals fi, let xs = free q, not (null xs) ]-    free q  = filter (not . isLit) (F.syms q) -    isLit x = F.memberSEnv x (F.gLits fi) +    free q  = filter (not . isLit) (F.syms q)+    isLit x = F.memberSEnv x (F.gLits fi)     -- lits    = fst <$> F.toListSEnv (F.gLits fi)     -- free q  = S.toList $ F.syms (F.qBody q) `nubDiff` (lits ++ F.prims ++ F.syms (F.qpSym <$> F.qParams q)) @@ -394,26 +397,26 @@ -- | symbol |-> sort for EVERY variable in the SInfo; 'symbolEnv' can ONLY be --   called with **sanitized** environments (post the uniqification etc.) or --   else you get duplicate sorts and other such errors.---   We do this peculiar dance with `env0` to extract the apply-sorts from the ---   function definitions inside the `AxiomEnv` which cannot be elaborated as +--   We do this peculiar dance with `env0` to extract the apply-sorts from the+--   function definitions inside the `AxiomEnv` which cannot be elaborated as --   it makes it hard to actually find the fundefs within (breaking PLE.) -------------------------------------------------------------------------------- symbolEnv :: Config -> F.SInfo a -> F.SymEnv symbolEnv cfg si = F.symEnv sEnv tEnv ds lits (ts ++ ts')   where-    ts'          = applySorts ae' +    ts'          = applySorts ae'     ae'          = elaborate (F.atLoc E.dummySpan "symbolEnv") env0 (F.ae si)     env0         = F.symEnv sEnv tEnv ds lits ts     tEnv         = Thy.theorySymbols ds     ds           = F.ddecls si     ts           = Misc.hashNub (applySorts si ++ [t | (_, t) <- F.toListSEnv sEnv])-    sEnv         = (F.tsSort <$> tEnv) `mappend` (F.fromListSEnv xts)+    sEnv         = (F.tsSort <$> tEnv) `mappend` F.fromListSEnv xts     xts          = symbolSorts cfg si ++ alits     lits         = F.dLits si `F.unionSEnv'` F.fromListSEnv alits     alits        = litsAEnv $ F.ae si  litsAEnv :: F.AxiomEnv -> [(F.Symbol, F.Sort)]-litsAEnv ae = zip (F.symbol <$> (symConsts ae)) (repeat $ F.strSort)+litsAEnv ae = zip (F.symbol <$> symConsts ae) (repeat F.strSort)  symbolSorts :: Config -> F.GInfo c a -> [(F.Symbol, F.Sort)] symbolSorts cfg fi = either E.die id $ symbolSorts' cfg fi@@ -424,17 +427,16 @@     normalize       = fmap (map (unShadow txFun dm))     dm              = M.fromList defs     defs            = F.toListSEnv . F.gLits $ fi-    txFun-      | True        = id+    txFun           = id  unShadow :: (F.Sort -> F.Sort) -> M.HashMap F.Symbol a -> (F.Symbol, F.Sort) -> (F.Symbol, F.Sort) unShadow tx dm (x, t)-  | M.member x dm  = (x, t)-  | otherwise      = (x, tx t)+  | M.member x dm = (x, t)+  | otherwise     = (x, tx t)  _defuncSort :: F.Sort -> F.Sort-_defuncSort (F.FFunc {}) = F.funcSort-_defuncSort t            = t+_defuncSort F.FFunc{} = F.funcSort+_defuncSort t         = t  compact :: [(F.Symbol, F.Sort)] -> Either E.Error [(F.Symbol, F.Sort)] compact xts@@ -466,7 +468,7 @@                                          , nest 4 (pprint y) ]  ---------------------------------------------------------------------------------symBinds  :: F.BindEnv -> [SymBinds]+symBinds  :: F.BindEnv a -> [SymBinds] -------------------------------------------------------------------------------- symBinds  = {- THIS KILLS ELEM: tracepp "symBinds" . -}             M.toList@@ -476,8 +478,8 @@  type SymBinds = (F.Symbol, [(F.Sort, [F.BindId])]) -binders :: F.BindEnv -> [(F.Symbol, (F.Sort, F.BindId))]-binders be = [(x, (F.sr_sort t, i)) | (i, x, t) <- F.bindEnvToList be]+binders :: F.BindEnv a -> [(F.Symbol, (F.Sort, F.BindId))]+binders be = [(x, (F.sr_sort t, i)) | (i, (x, t, _)) <- F.bindEnvToList be]   --------------------------------------------------------------------------------@@ -487,9 +489,10 @@ -------------------------------------------------------------------------------- dropFuncSortedShadowedBinders fi = dropBinders ok (const True) fi   where-    ok x t  = (M.member x defs) ==> (F.allowHO fi || isFirstOrder t)+    ok x t  = M.member x defs ==> (F.allowHO fi || isFirstOrder t)     defs    = M.fromList $ F.toListSEnv $ F.gLits fi +infixl 9 ==> (==>) :: Bool -> Bool -> Bool p ==> q = not p || q @@ -550,12 +553,13 @@ deleteWfCBinds :: [F.BindId] -> F.WfC a -> F.WfC a deleteWfCBinds bs wf = wf { F.wenv = foldr F.deleteIBindEnv (F.wenv wf) bs } -filterBindEnv :: KeepBindF -> F.BindEnv -> (F.BindEnv, [F.BindId])-filterBindEnv f be  = (F.bindEnvFromList keep, discard')+filterBindEnv :: KeepBindF -> F.BindEnv a -> (F.BindEnv a, [F.BindId])+filterBindEnv f be  = (keepBindEnv , discard')   where+    keepBindEnv     = F.bindEnvFromList [(i, (x, sr, a)) | (i, (x, sr, a)) <- keep]     (keep, discard) = L.partition f' $ F.bindEnvToList be-    discard'        = Misc.fst3     <$> discard-    f' (_, x, t)    = f x (F.sr_sort t)+    discard'        = fst <$> discard+    f' (_, (x, t, _)) = f x (F.sr_sort t)   ---------------------------------------------------------------------------

+ src/Language/Fixpoint/Solver/Simplify.hs view

@@ -0,0 +1,163 @@+--------------------------------------------------------------------------------+-- | This module contains common functions used in the implementations of+--     Simplifiable Expr in both Interpreter.hs and PLE.hs.+--------------------------------------------------------------------------------++{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ViewPatterns              #-}++{-# OPTIONS_GHC -Wno-name-shadowing    #-}++module Language.Fixpoint.Solver.Simplify (applyBooleanFolding, applyConstantFolding, applySetFolding, isSetPred) where++import           Language.Fixpoint.Types hiding (simplify)+import           Language.Fixpoint.Smt.Theories+import           Data.Hashable+import qualified Data.HashSet         as S+import qualified Data.Maybe           as Mb+++applyBooleanFolding :: Brel -> Expr -> Expr -> Expr+applyBooleanFolding brel e1 e2 =+  case (e1, e2) of+    (ECon (R left), ECon (R right)) ->+      Mb.fromMaybe e (bfR brel left right)+    (ECon (R left), ECon (I right)) ->+      Mb.fromMaybe e (bfR brel left (fromIntegral right))+    (ECon (I left), ECon (R right)) ->+      Mb.fromMaybe e (bfR brel (fromIntegral left) right)+    (ECon (I left), ECon (I right)) ->+      Mb.fromMaybe e (bfI brel left right)+    _ -> if isTautoPred e then PTrue else+           if isContraPred e then PFalse else e+  where+    e = PAtom brel e1 e2++    getOp :: Ord a => Brel -> (a -> a -> Bool)+    getOp Gt   =  (>)+    getOp Ge   =  (>=)+    getOp Lt   =  (<)+    getOp Le   =  (<=)+    getOp Eq   =  (==)+    getOp Ne   =  (/=)+    getOp Ueq  =  (==)+    getOp Une  =  (/=)++    bfR :: Brel -> Double -> Double -> Maybe Expr+    bfR brel left right = if getOp brel left right then Just PTrue else Just PFalse++    bfI :: Brel -> Integer -> Integer -> Maybe Expr+    bfI brel left right = if getOp brel left right then Just PTrue else Just PFalse+++-- | Replace constant integer and floating point expressions by constant values+-- where possible.+applyConstantFolding :: Bop -> Expr -> Expr -> Expr+applyConstantFolding bop e1 e2 =+  case (dropECst e1, dropECst e2) of+    (ECon (R left), ECon (R right)) ->+      Mb.fromMaybe e (cfR bop left right)+    (ECon (R left), ECon (I right)) ->+      Mb.fromMaybe e (cfR bop left (fromIntegral right))+    (ECon (I left), ECon (R right)) ->+      Mb.fromMaybe e (cfR bop (fromIntegral left) right)+    (ECon (I left), ECon (I right)) ->+      Mb.fromMaybe e (cfI bop left right)+    (EBin Mod  _   _              , _)  -> e+    (EBin bop1 e11 (dropECst -> ECon (R left)), ECon (R right))+      | bop == bop1 -> maybe e (EBin bop e11) (cfR (rop bop) left right)+      | otherwise   -> e+    (EBin bop1 e11 (dropECst -> ECon (R left)), ECon (I right))+      | bop == bop1 -> maybe e (EBin bop e11) (cfR (rop bop) left (fromIntegral right))+      | otherwise   -> e+    (EBin bop1 e11 (dropECst -> ECon (I left)), ECon (R right))+      | bop == bop1 -> maybe e (EBin bop e11) (cfR (rop bop) (fromIntegral left) right)+      | otherwise   -> e+    (EBin bop1 e11 (dropECst -> ECon (I left)), ECon (I right))+      | bop == bop1 -> maybe e (EBin bop e11) (cfI (rop bop) left right)+      | otherwise   -> e+    _ -> e+  where++    rop :: Bop -> Bop+    rop Plus   = Plus+    rop Minus  = Plus+    rop Times  = Times+    rop Div    = Times+    rop RTimes = RTimes+    rop RDiv   = RTimes+    rop Mod    = Mod++    e = EBin bop e1 e2++    getOp :: Num a => Bop -> Maybe (a -> a -> a)+    getOp Minus    = Just (-)+    getOp Plus     = Just (+)+    getOp Times    = Just (*)+    getOp RTimes   = Just (*)+    getOp _        = Nothing++    cfR :: Bop -> Double -> Double -> Maybe Expr+    cfR bop left right = fmap go (getOp' bop)+      where+        go f = ECon $ R $ f left right++        getOp' Div      = Just (/)+        getOp' RDiv     = Just (/)+        getOp' op       = getOp op++    cfI :: Bop -> Integer -> Integer -> Maybe Expr+    cfI bop left right = fmap go (getOp' bop)+      where+        go f = ECon $ I $ f left right++        getOp' Mod = Just mod+        getOp' op  = getOp op++isSetPred :: Expr -> Bool+isSetPred (EVar s) | s == setEmp          = True+isSetPred (EApp e1 _) = case e1 of+  (EVar s) | s == setMem || s == setSub  -> True+  _                                      -> False+isSetPred _                               = False++-- Note: this is currently limited to sets of integer constants+applySetFolding :: Expr -> Expr -> Expr+applySetFolding e1 e2   = case e1 of+    (EVar s) | s == setEmp+      -> maybe e (fromBool . S.null) (evalSetI e2)+    (EApp (EVar s) e1') | s == setMem+      -> maybe e fromBool (S.member <$> getInt e1' <*> evalSetI e2)+                        | s == setEmp+      -> maybe e (fromBool . S.null) (S.difference <$> evalSetI e1' <*> evalSetI e2)+                        | otherwise+      -> e+    _                   -> e+  where+    e = EApp e1 e2++    fromBool True  = PTrue+    fromBool False = PFalse++    getInt :: Expr -> Maybe Integer+    getInt (ECon (I n)) = Just n+    getInt _            = Nothing++    getOp :: (Eq a, Hashable a) => Symbol -> Maybe (S.HashSet a -> S.HashSet a -> S.HashSet a)+    getOp s | s == setCup = Just S.union+            | s == setCap = Just S.intersection+            | s == setDif = Just S.difference+            | otherwise   = Nothing++    evalSetI :: Expr -> Maybe (S.HashSet Integer)+    evalSetI (EApp e1 e2) = case e1 of+      (EVar s) | s == setEmpty -> Just S.empty+               | s == setSng   -> case e2 of+        (ECon (I n))             -> Just $ S.singleton n+        _                        -> Nothing+      (EApp (EVar f) e1')  -> getOp f <*> evalSetI e1' <*> evalSetI e2+      _                    -> Nothing+    evalSetI _            = Nothing+

src/Language/Fixpoint/Solver/Solution.hs view

@@ -1,9 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP               #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections     #-} {-# LANGUAGE PatternGuards     #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Solver.Solution   ( -- * Create Initial Solution     init@@ -19,14 +20,12 @@  import           Control.Parallel.Strategies import           Control.Arrow (second, (***))+import           Control.Monad (void) import qualified Data.HashSet                   as S import qualified Data.HashMap.Strict            as M import qualified Data.List                      as L import           Data.Maybe                     (fromMaybe, maybeToList, isNothing)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup                 (Semigroup (..))-#endif-+import qualified Data.Bifunctor                 as Bifunctor (second) import           Language.Fixpoint.Types.PrettyPrint () import           Language.Fixpoint.Types.Visitor      as V import qualified Language.Fixpoint.SortCheck          as So@@ -52,7 +51,7 @@ init cfg si ks_ = Sol.fromList senv mempty keqs [] mempty ebs xEnv   where     keqs       = map (refine si qcs genv) ws `using` parList rdeepseq-    qcs        = {- trace ("init-qs-size " ++ show (length ws, length qs_, M.keys qcs_)) $ -} qcs_ +    qcs        = {- trace ("init-qs-size " ++ show (length ws, length qs_, M.keys qcs_)) $ -} qcs_     qcs_       = mkQCluster qs_     qs_        = F.quals si     ws         = [ w | (k, w) <- M.toList (F.ws si), not (isGWfc w), k `S.member` ks ]@@ -60,11 +59,11 @@     genv       = instConstants si     senv       = symbolEnv cfg si     ebs        = ebindInfo si-    xEnv       = F.fromListSEnv [ (x, (i, F.sr_sort sr)) | (i,x,sr) <- F.bindEnvToList (F.bs si)]+    xEnv       = F.fromListSEnv [ (x, (i, F.sr_sort sr)) | (i,(x,sr,_)) <- F.bindEnvToList (F.bs si)]  -------------------------------------------------------------------------------- -- | [NOTE:qual-cluster] It is wasteful to perform instantiation *individually*---   on each qualifier, as many qualifiers have "equivalent" parameters, and +--   on each qualifier, as many qualifiers have "equivalent" parameters, and --   so have the "same" instances in an environment. To exploit this structure, -- --   1. Group the [Qualifier] into a QCluster@@ -79,7 +78,7 @@ mkQCluster = Misc.groupMap qualSig  qualSig :: Qualifier -> QCSig-qualSig q = [ p { F.qpSym = F.dummyName }  | p <- F.qParams q ] +qualSig q = [ p { F.qpSym = F.dummyName }  | p <- F.qParams q ]  -------------------------------------------------------------------------------- @@ -107,13 +106,13 @@       -> F.SEnv F.Sort       -> F.Symbol       -> F.Sort-      -> QCluster +      -> QCluster       -> Sol.QBind ---------------------------------------------------------------------------------instK ho env v t qc = Sol.qb . unique $ -  [ Sol.eQual q xs +instK ho env v t qc = Sol.qb . unique $+  [ Sol.eQual q xs       | (sig, qs) <- M.toList qc-      , xs        <- instKSig ho env v t sig +      , xs        <- instKSig ho env v t sig       , q         <- qs   ] @@ -124,27 +123,27 @@          -> F.SEnv F.Sort          -> F.Symbol          -> F.Sort-         -> QCSig +         -> QCSig          -> [[F.Symbol]]-instKSig ho env v t qsig = do +instKSig _  _   _ _ [] = error "Empty qsig in Solution.instKSig"+instKSig ho env v t (qp:qps) = do   (su0, i0, qs0) <- candidatesP senv [(0, t, [v])] qp-  ixs       <- matchP senv tyss [(i0, qs0)] (applyQPP su0 <$> qps) +  ixs       <- matchP senv tyss [(i0, qs0)] (applyQPP su0 <$> qps)   -- return     $ F.notracepp msg (reverse ixs)-  ys        <- instSymbol tyss (tail $ reverse ixs) +  ys        <- instSymbol tyss (tail $ reverse ixs)   return (v:ys)   where     -- msg        = "instKSig " ++ F.showpp qsig-    qp : qps   = qsig     tyss       = zipWith (\i (t, ys) -> (i, t, ys)) [1..] (instCands ho env)     senv       = (`F.lookupSEnvWithDistance` env)  instSymbol :: [(SortIdx, a, [F.Symbol])] -> [(SortIdx, QualPattern)] -> [[F.Symbol]]-instSymbol tyss = go +instSymbol tyss = go   where     m = M.fromList [(i, ys) | (i,_,ys) <- tyss]-    go [] = +    go [] =       return []-    go ((i,qp):is) = do +    go ((i,qp):is) = do       y   <- M.lookupDefault [] i m       qsu <- maybeToList (matchSym qp y)       ys  <- go [ (i', applyQPSubst qsu  qp') | (i', qp') <- is]@@ -156,9 +155,9 @@ --        -> F.Sort --        -> F.Qualifier --        -> [Sol.EQual]--- instKQ ho env v t q = do +-- instKQ ho env v t q = do --   (su0, qsu0, v0) <- candidates senv [(t, [v])] qp---   xs              <- match senv tyss [v0] (applyQP su0 qsu0 <$> qps) +--   xs              <- match senv tyss [v0] (applyQP su0 qsu0 <$> qps) --   return           $ Sol.eQual q (F.notracepp msg (reverse xs)) --   where --     msg        = "instKQ " ++ F.showpp (F.qName q) ++ F.showpp (F.qParams q)@@ -176,18 +175,18 @@  type SortIdx = Int -matchP :: So.Env -> [(SortIdx, F.Sort, a)] -> [(SortIdx, QualPattern)] -> [F.QualParam] -> +matchP :: So.Env -> [(SortIdx, F.Sort, a)] -> [(SortIdx, QualPattern)] -> [F.QualParam] ->           [[(SortIdx, QualPattern)]] matchP env tyss = go-  where +  where     go' !i !p !is !qps  = go ((i, p):is) qps     go is (qp : qps) = do (su, i, pat) <- candidatesP env tyss qp                           go' i pat is (applyQPP su <$> qps)     go is []         = return is  applyQPP :: So.TVSubst -> F.QualParam -> F.QualParam-applyQPP su qp = qp -  { qpSort = So.apply     su  (qpSort qp) +applyQPP su qp = qp+  { qpSort = So.apply     su  (qpSort qp)   }  -- match :: So.Env -> [(F.Sort, [F.Symbol])] -> [F.Symbol] -> [F.QualParam] -> [[F.Symbol]]@@ -198,17 +197,17 @@ --   = return xs  -- applyQP :: So.TVSubst -> QPSubst -> F.QualParam -> F.QualParam--- applyQP su qsu qp = qp ---   { qpSort = So.apply     su  (qpSort qp) ---   , qpPat  = applyQPSubst qsu (qpPat qp) +-- applyQP su qsu qp = qp+--   { qpSort = So.apply     su  (qpSort qp)+--   , qpPat  = applyQPSubst qsu (qpPat qp) --   }  ---------------------------------------------------------------------------------candidatesP :: So.Env -> [(SortIdx, F.Sort, a)] -> F.QualParam -> +candidatesP :: So.Env -> [(SortIdx, F.Sort, a)] -> F.QualParam ->                [(So.TVSubst, SortIdx, QualPattern)] -------------------------------------------------------------------------------- candidatesP env tyss x =-    [(su, idx, qPat) +    [(su, idx, qPat)         | (idx, t,_)  <- tyss         , su          <- maybeToList (So.unifyFast mono env xt t)     ]@@ -216,42 +215,42 @@     xt   = F.qpSort x     qPat = F.qpPat  x     mono = So.isMono xt-      + -- ----------------------------------------------------------------------------------- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.QualParam +-- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.QualParam --            -> [(So.TVSubst, QPSubst, F.Symbol)] -- -------------------------------------------------------------------------------- -- candidates env tyss x = -- traceShow _msg --     [(su, qsu, y) | (t, ys)  <- tyss --                   , su       <- maybeToList (So.unifyFast mono env xt t) --                   , y        <- ys---                   , qsu      <- maybeToList (matchSym x y)                                     +--                   , qsu      <- maybeToList (matchSym x y) --     ] --   where --     xt   = F.qpSort x --     mono = So.isMono xt --     _msg = "candidates tyss :=" ++ F.showpp tyss ++ "tx := " ++ F.showpp xt -matchSym :: F.QualPattern -> F.Symbol -> Maybe QPSubst +matchSym :: F.QualPattern -> F.Symbol -> Maybe QPSubst matchSym qp y' = case qp of-  F.PatPrefix s i -> JustSub i <$> F.stripPrefix s y -  F.PatSuffix i s -> JustSub i <$> F.stripSuffix s y -  F.PatNone       -> Just NoSub -  F.PatExact s    -> if s == y then Just NoSub else Nothing -  where +  F.PatPrefix s i -> JustSub i <$> F.stripPrefix s y+  F.PatSuffix i s -> JustSub i <$> F.stripSuffix s y+  F.PatNone       -> Just NoSub+  F.PatExact s    -> if s == y then Just NoSub else Nothing+  where     y             =  F.tidySymbol y' -data QPSubst = NoSub | JustSub Int F.Symbol  +data QPSubst = NoSub | JustSub Int F.Symbol -applyQPSubst :: QPSubst -> F.QualPattern -> F.QualPattern -applyQPSubst (JustSub i x) (F.PatPrefix s j) -  | i == j = F.PatExact (F.mappendSym s x) -applyQPSubst (JustSub i x) (F.PatSuffix j s) -  | i == j = F.PatExact (F.mappendSym x s) -applyQPSubst _ p -  = p +applyQPSubst :: QPSubst -> F.QualPattern -> F.QualPattern+applyQPSubst (JustSub i x) (F.PatPrefix s j)+  | i == j = F.PatExact (F.mappendSym s x)+applyQPSubst (JustSub i x) (F.PatSuffix j s)+  | i == j = F.PatExact (F.mappendSym x s)+applyQPSubst _ p+  = p  -------------------------------------------------------------------------------- okInst :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> Sol.EQual -> Bool@@ -260,7 +259,7 @@   where     sr            = F.RR t (F.Reft (v, p))     p             = Sol.eqPred eq-    tc            = So.checkSorted (F.srcSpan eq) env sr +    tc            = So.checkSorted (F.srcSpan eq) env sr     -- _msg          = printf "okInst: t = %s, eq = %s, env = %s" (F.showpp t) (F.showpp eq) (F.showpp env)  @@ -271,7 +270,7 @@ lhsPred   :: (F.Loc a)   => F.IBindEnv-  -> F.BindEnv+  -> F.BindEnv a   -> Sol.Solution   -> F.SimpC a   -> F.Expr@@ -282,10 +281,10 @@     ci         = sid c     _msg       = "LhsPred for id = " ++ show (sid c) ++ " with SOLUTION = " ++ F.showpp s -data CombinedEnv = CEnv +data CombinedEnv a = CEnv   { ceCid  :: !Cid-  , ceBEnv :: !F.BindEnv-  , ceIEnv :: !F.IBindEnv +  , ceBEnv :: !(F.BindEnv a)+  , ceIEnv :: !F.IBindEnv   , ceSpan :: !F.SrcSpan     -- | These are the bindings that the smt solver knows about and can be     -- referred as @EVar (bindSymbol <bindId>)@ instead of serializing them@@ -293,13 +292,13 @@   , ceBindingsInSmt :: !F.IBindEnv   } -instance F.Loc CombinedEnv where +instance F.Loc (CombinedEnv a) where   srcSpan = ceSpan  type Cid         = Maybe Integer type ExprInfo    = (F.Expr, KInfo) -apply :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ExprInfo+apply :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ExprInfo apply g s bs      = (F.conj (pks:ps), kI)   -- see [NOTE: pAnd-SLOW]   where     -- Clear the "known" bindings for applyKVars, since it depends on@@ -309,23 +308,23 @@     (ps,  ks, _)  = envConcKVars g s bs  -envConcKVars :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ([F.Expr], [F.KVSub], [F.KVSub])+envConcKVars :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ([F.Expr], [F.KVSub], [F.KVSub]) envConcKVars g s bs = (concat pss, concat kss, L.nubBy (\x y -> F.ksuKVar x == F.ksuKVar y) $ concat gss)   where     (pss, kss, gss) = unzip3 [ F.notracepp ("sortedReftConcKVars" ++ F.showpp sr) $ F.sortedReftConcKVars x sr | (x, sr) <- xrs ]     xrs             = lookupBindEnvExt g s <$> is     is              = F.elemsIBindEnv bs -lookupBindEnvExt :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.BindId -> (F.Symbol, F.SortedReft)+lookupBindEnvExt :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.BindId -> (F.Symbol, F.SortedReft) lookupBindEnvExt g s i   | Just p <- ebSol g {ceBindingsInSmt = F.emptyIBindEnv} s i = (x, sr { F.sr_reft = F.Reft (x, p) })   | F.memberIBindEnv i (ceBindingsInSmt g) =       (x, sr { F.sr_reft = F.Reft (x, F.EVar (F.bindSymbol (fromIntegral i)))})   | otherwise             = (x, sr)-   where -      (x, sr)              = F.lookupBindEnv i (ceBEnv g) +   where+      (x, sr, _)              = F.lookupBindEnv i (ceBEnv g) -ebSol :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.BindId -> Maybe F.Expr+ebSol :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.BindId -> Maybe F.Expr ebSol g s i = case  M.lookup i sebds of   Just (Sol.EbSol p)    -> Just p   Just (Sol.EbDef cs _) -> Just $ F.PAnd (cSol <$> cs)@@ -334,16 +333,16 @@     sebds = Sol.sEbd s      ebReft s (i,c) = exElim (Sol.sxEnv s) (senv c) i (ebindReft g s c)-    cSol c = if sid c == ceCid g +    cSol c = if sid c == ceCid g                 then F.PFalse                 else ebReft s' (i, c)      s' = s { Sol.sEbd = M.insert i Sol.EbIncr sebds } -ebindReft :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.SimpC () -> F.Pred+ebindReft :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.SimpC () -> F.Pred ebindReft g s c = F.pAnd [ fst $ apply g' s bs, F.crhs c ]   where-    g'          = g { ceCid = sid c, ceIEnv = bs } +    g'          = g { ceCid = sid c, ceIEnv = bs }     bs          = F.senv c  exElim :: F.SEnv (F.BindId, F.Sort) -> F.IBindEnv -> F.BindId -> F.Pred -> F.Pred@@ -355,17 +354,17 @@                             , xi < yi                             , yi `F.memberIBindEnv` ienv                  ] -applyKVars :: CombinedEnv -> Sol.Sol a Sol.QBind -> [F.KVSub] -> ExprInfo+applyKVars :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> [F.KVSub] -> ExprInfo applyKVars g s = mrExprInfos (applyKVar g s) F.pAndNoDedup mconcat -applyKVar :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> ExprInfo+applyKVar :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> ExprInfo applyKVar g s ksu = case Sol.lookup s (F.ksuKVar ksu) of   Left cs   -> hypPred g s ksu cs   Right eqs -> (F.pAndNoDedup $ fst <$> Sol.qbPreds msg s (F.ksuSubst ksu) eqs, mempty) -- TODO: don't initialize kvars that have a hyp solution   where     msg     = "applyKVar: " ++ show (ceCid g) -nonCutsResult :: F.BindEnv -> Sol.Sol a Sol.QBind -> M.HashMap F.KVar F.Expr+nonCutsResult :: F.BindEnv ann -> Sol.Sol a Sol.QBind -> M.HashMap F.KVar F.Expr nonCutsResult be s =   let g = CEnv Nothing be F.emptyIBindEnv F.dummySpan F.emptyIBindEnv    in M.mapWithKey (mkNonCutsExpr g) $ Sol.sHyp s@@ -389,7 +388,7 @@ --    particular use of the KVar. Thus @cubePred@ produces a different --    expression for every use site of the kvar, while here we produce one --    expression for all the uses.-bareCubePred :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVar -> Sol.Cube -> F.Expr+bareCubePred :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVar -> Sol.Cube -> F.Expr bareCubePred g s k c =   let bs = Sol.cuBinds c       su = Sol.cuSubst c@@ -401,7 +400,7 @@       (p, _kI) = apply g' s bs'    in F.pExist (xts ++ yts) (psu &.& p) -hypPred :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Hyp  -> ExprInfo+hypPred :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Hyp  -> ExprInfo hypPred g s ksu hyp = F.pOr *** mconcatPlus $ unzip $ cubePred g s ksu <$> hyp  {- | `cubePred g s k su c` returns the predicate for@@ -426,7 +425,7 @@     elab        = So.elaborate (F.atLoc sp "elabExist") env     env         = Sol.sEnv s -cubePred :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> ExprInfo+cubePred :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> ExprInfo cubePred g s ksu c    = (F.notracepp "cubePred" $ elabExist sp s xts (psu &.& p), kI)   where     sp                = F.srcSpan g@@ -441,7 +440,7 @@ --   The output is a tuple, `(xts, psu, p, kI)` such that the actual predicate --   we want is `Exists xts. (psu /\ p)`. -cubePredExc :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> F.IBindEnv+cubePredExc :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> F.IBindEnv             -> ((Binders, F.Pred, F.Pred), KInfo)  cubePredExc g s ksu c bs' = (cubeP, extendKInfo kI (Sol.cuTag c))@@ -485,7 +484,7 @@      2. are binders corresponding to sorts (e.g. `a : num`, currently used         to hack typeclasses current.)  -}-substElim :: F.SymEnv -> F.SEnv F.Sort -> CombinedEnv -> F.KVar -> F.Subst -> ([(F.Symbol, F.Sort)], F.Pred)+substElim :: F.SymEnv -> F.SEnv F.Sort -> CombinedEnv a -> F.KVar -> F.Subst -> ([(F.Symbol, F.Sort)], F.Pred) substElim syEnv sEnv g _ (F.Su m) = (xts, p)   where     p      = F.pAnd [ mkSubst sp syEnv x (substSort sEnv frees x t) e t | (x, e, t) <- xets  ]@@ -507,7 +506,7 @@ mkSubst :: F.SrcSpan -> F.SymEnv -> F.Symbol -> F.Sort -> F.Expr -> F.Sort -> F.Expr mkSubst sp env x tx ey ty   | tx == ty    = F.EEq ex ey-  | otherwise   = {- F.tracepp _msg -} (F.EEq ex' ey')+  | otherwise   = {- F.tracepp _msg -} F.EEq ex' ey'   where     _msg         = "mkSubst-DIFF:" ++ F.showpp (tx, ty) ++ F.showpp (ex', ey')     ex          = F.expr x@@ -522,28 +521,14 @@ isClass F.FFrac = True isClass _       = False ---badExpr :: CombinedEnv -> F.KVar -> F.Expr -> a---badExpr g@(i,_,_) k e-  -- = errorstar $ "substSorts has a badExpr: "-              -- ++ show e-              -- ++ " in cid = "-              -- ++ show i-              -- ++ " for kvar " ++ show k-              -- ++ " in env \n"-              -- ++ show (combinedSEnv g)---- substPred :: F.Subst -> F.Pred--- substPred (F.Su m) = F.pAnd [ F.PAtom F.Eq (F.eVar x) e | (x, e) <- M.toList m]--combinedSEnv :: CombinedEnv -> F.SEnv F.Sort+combinedSEnv :: CombinedEnv a -> F.SEnv F.Sort combinedSEnv g = F.sr_sort <$> F.fromListSEnv (F.envCs be bs)-  where -    be         = ceBEnv g -    bs         = ceIEnv g +  where+    be         = ceBEnv g+    bs         = ceIEnv g -addCEnv :: CombinedEnv -> F.IBindEnv -> CombinedEnv+addCEnv :: CombinedEnv a -> F.IBindEnv -> CombinedEnv a addCEnv g bs' = g { ceIEnv = F.unionIBindEnv (ceIEnv g) bs' }--- addCEnv (x, be, bs) bs' = (x, be, F.unionIBindEnv bs bs')   delCEnv :: Sol.Sol a Sol.QBind -> F.KVar -> F.IBindEnv -> F.IBindEnv@@ -551,7 +536,7 @@   where     _kbs       = Misc.safeLookup "delCEnv" k (Sol.sScp s) -symSorts :: CombinedEnv -> F.IBindEnv -> [(F.Symbol, F.Sort)]+symSorts :: CombinedEnv a -> F.IBindEnv -> [(F.Symbol, F.Sort)] symSorts g bs = second F.sr_sort <$> F.envCs (ceBEnv g) bs  _noKvars :: F.Expr -> Bool@@ -596,43 +581,41 @@     (es, is)              = unzip $ map mF xs  ----------------------------------------------------------------------------------- | `ebindInfo` constructs the information about the "ebind-definitions". +-- | `ebindInfo` constructs the information about the "ebind-definitions". -------------------------------------------------------------------------------- ebindInfo :: F.SInfo a -> [(F.BindId, Sol.EbindSol)] ebindInfo si = group [((bid, x), cons cid) | (bid, cid, x) <- ebindDefs si]-  where cons cid = const () <$> Misc.safeLookup "ebindInfo" cid cs+  where cons cid = void (Misc.safeLookup "ebindInfo" cid cs)         cs = F.cm si         cmpByFst x y = fst ( fst x ) == fst ( fst y )-        group xs = (\ys -> ( (fst $ fst $ head ys)-                           , Sol.EbDef (snd <$> ys) (snd $ fst $ head ys)))+        group xs = (\ys -> Bifunctor.second (Sol.EbDef (snd <$> ys)) (fst $ head ys))                     <$> L.groupBy cmpByFst xs  ebindDefs :: F.SInfo a -> [(F.BindId, F.SubcId, F.Symbol)] ebindDefs si = [ (bid, cid, x) | (cid, x) <- cDefs                                , bid      <- maybeToList (M.lookup x ebSyms)]-  where -    ebSyms   = ebindSyms si -    cDefs    = cstrDefs  si +  where+    ebSyms   = ebindSyms si+    cDefs    = cstrDefs  si  ebindSyms :: F.SInfo a -> M.HashMap F.Symbol F.BindId ebindSyms si = M.fromList [ (xi, bi) | bi        <- ebinds si-                                     , let (xi,_) = F.lookupBindEnv bi be ] +                                     , let (xi,_,_) = F.lookupBindEnv bi be ]   where-    be       = F.bs si - +    be       = F.bs si+ cstrDefs :: F.SInfo a -> [(F.SubcId, F.Symbol)] cstrDefs si = [(cid, x) | (cid, c) <- M.toList (cm si)                         , x <- maybeToList (cstrDef be c) ]-  where +  where     be      = F.bs si -cstrDef :: F.BindEnv -> F.SimpC a -> Maybe F.Symbol -cstrDef be c -  | Just (F.EVar x) <- e = Just x -  | otherwise            = Nothing -  where -    (v,_)              = F.lookupBindEnv (cbind c) be -    e                  = F.notracepp _msg $ F.isSingletonExpr v rhs -    _msg                = "cstrDef: " ++ show (stag c) ++ " crhs = " ++ F.showpp rhs -    rhs                = V.stripCasts (crhs c)-+cstrDef :: F.BindEnv a -> F.SimpC a -> Maybe F.Symbol+cstrDef be c+  | Just (F.EVar x) <- e = Just x+  | otherwise            = Nothing+  where+    (v,_,_)              = F.lookupBindEnv (cbind c) be+    e                    = F.notracepp _msg $ F.isSingletonExpr v rhs+    _msg                 = "cstrDef: " ++ show (stag c) ++ " crhs = " ++ F.showpp rhs+    rhs                  = V.stripCasts (crhs c)

src/Language/Fixpoint/Solver/Solve.hs view

@@ -1,9 +1,10 @@ {-# LANGUAGE PatternGuards     #-}-{-# LANGUAGE TupleSections     #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -------------------------------------------------------------------------------- -- | Solve a system of horn-clause constraints --------------------------------- --------------------------------------------------------------------------------@@ -30,12 +31,17 @@ import           Control.DeepSeq import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S--- import qualified Data.Maybe          as Mb +-- import qualified Data.Maybe          as Mb import qualified Data.List           as L import Language.Fixpoint.Types (resStatus, FixResult(Unsafe)) import qualified Language.Fixpoint.Types.Config as C+import Language.Fixpoint.Solver.Interpreter (instInterpreter) import Language.Fixpoint.Solver.Instantiate (instantiate)+--import Debug.Trace                      (trace) +mytrace :: String -> a -> a+mytrace _ x = {- trace -} x+ -------------------------------------------------------------------------------- solve :: (NFData a, F.Fixpoint a, Show a, F.Loc a) => Config -> F.SInfo a -> IO (F.Result (Integer, a)) --------------------------------------------------------------------------------@@ -43,7 +49,7 @@ solve cfg fi = do     whenLoud $ donePhase Misc.Loud "Worklist Initialize"     vb <- getVerbosity-    (res, stat) <- (if (Quiet == vb || gradual cfg) then id else withProgressFI sI) $ runSolverM cfg sI act+    (res, stat) <- (if Quiet == vb || gradual cfg then id else withProgressFI sI) $ runSolverM cfg sI act     when (solverStats cfg) $ printStats fi wkl stat     -- print (numIter stat)     return res@@ -59,7 +65,7 @@ -- | Progress Bar -------------------------------------------------------------------------------- withProgressFI :: SolverInfo a b -> IO b -> IO b-withProgressFI = withProgress . (+ 1) . fromIntegral . cNumScc . siDeps  +withProgressFI = withProgress . (+ 1) . fromIntegral . cNumScc . siDeps --------------------------------------------------------------------------------  printStats :: F.SInfo a ->  W.Worklist a -> Stats -> IO ()@@ -79,9 +85,19 @@ siKvars :: F.SInfo a -> S.HashSet F.KVar siKvars = S.fromList . M.keys . F.ws +doInterpret :: (F.Loc a) =>  Config -> F.SInfo a -> [F.SubcId] -> SolveM a (F.SInfo a)+doInterpret cfg fi0 subcIds = do+  fi <- liftIO $ instInterpreter cfg fi0 (Just subcIds)+  modify $ update' fi+  return fi+  where+    update' fi ss = ss{ssBinds = F.bs fi'}+      where+        fi' = (siQuery sI) {F.hoInfo = F.HOI (C.allowHO cfg) (C.allowHOqs cfg)}+        sI  = solverInfo cfg fi  {-# SCC doPLE #-}-doPLE :: (F.Loc a) =>  Config -> F.SInfo a -> [F.SubcId] -> SolveM ()+doPLE :: (F.Loc a) =>  Config -> F.SInfo a -> [F.SubcId] -> SolveM a () doPLE cfg fi0 subcIds = do   fi <- liftIO $ instantiate cfg fi0 (Just subcIds)   modify $ update' fi@@ -99,27 +115,40 @@        -> Sol.Solution        -> S.HashSet F.KVar        -> W.Worklist a-       -> SolveM (F.Result (Integer, a), Stats)+       -> SolveM a (F.Result (Integer, a), Stats) -------------------------------------------------------------------------------- solve_ cfg fi s0 ks wkl = do   let s1   = {-# SCC "sol-init" #-} S.init cfg fi ks   let s2   = mappend s0 s1   (s3, res0) <- sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do     -- let s3   = solveEbinds fi s2-    s3       <- {- SCC "sol-refine" #-} refine bindingsInSmt s2 wkl-    res0     <- {- SCC "sol-result" #-} result bindingsInSmt cfg wkl s3+    s3       <- {- SCC "sol-refine" -} refine bindingsInSmt s2 wkl+    res0     <- {- SCC "sol-result" -} result bindingsInSmt cfg wkl s3     return (s3, res0)-  res <- case resStatus res0 of-    Unsafe _ bads | not (noLazyPLE cfg) && rewriteAxioms cfg -> do-      doPLE cfg fi (map fst bads)++  (fi1, s4, res1) <- case resStatus res0 of  {- first run the interpreter -}+    Unsafe _ bads | not (noLazyPLE cfg) && rewriteAxioms cfg && interpreter cfg -> do+      fi1 <- doInterpret cfg fi (map fst $ mytrace ("before the Interpreter " ++ show (length bads) ++ " constraints remain") bads)+      (s4, res1) <-  sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do+        s4    <- {- SCC "sol-refine" -} refine bindingsInSmt s3 wkl+        res1  <- {- SCC "sol-result" -} result bindingsInSmt cfg wkl s4+        return (s4, res1)+      return (fi1, s4, res1)+    _ -> return  (fi, s3, mytrace "all checked before interpreter" res0)++  res2  <- case resStatus res1 of  {- then run normal PLE on remaining unsolved constraints -}+    Unsafe _ bads2 | not (noLazyPLE cfg) && rewriteAxioms cfg -> do+      doPLE cfg fi1 (map fst $ mytrace ("before z3 PLE " ++ show (length bads2) ++ " constraints remain") bads2)       sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do-        s4 <- {- SCC "sol-refine" #-} refine bindingsInSmt s3 wkl-        result bindingsInSmt cfg wkl s4-    _ -> return res0+        s5    <- {- SCC "sol-refine" -} refine bindingsInSmt s4 wkl+        result bindingsInSmt cfg wkl s5+    _ -> return $ mytrace "all checked with interpreter" res1+   st      <- stats-  let res' = {- SCC "sol-tidy"   #-} tidyResult res-  return $!! (res', st)+  let res3 = {- SCC "sol-tidy" -} tidyResult res2+  return $!! (res3, st) + -------------------------------------------------------------------------------- -- | tidyResult ensures we replace the temporary kVarArg names introduced to --   ensure uniqueness with the original names in the given WF constraints.@@ -143,7 +172,7 @@   => F.IBindEnv   -> Sol.Solution   -> W.Worklist a-  -> SolveM Sol.Solution+  -> SolveM a Sol.Solution -------------------------------------------------------------------------------- refine bindingsInSmt s w   | Just (c, w', newScc, rnk) <- W.pop w = do@@ -168,7 +197,7 @@   -> Int   -> Sol.Solution   -> F.SimpC a-  -> SolveM (Bool, Sol.Solution)+  -> SolveM a (Bool, Sol.Solution) --------------------------------------------------------------------------- refineC bindingsInSmt _i s c   | null rhs  = return (False, s)@@ -207,7 +236,7 @@   -> Config   -> W.Worklist a   -> Sol.Solution-  -> SolveM (F.Result (Integer, a))+  -> SolveM a (F.Result (Integer, a)) -------------------------------------------------------------------------------- result bindingsInSmt cfg wkl s =   sendConcreteBindingsToSMT bindingsInSmt $ \bindingsInSmt2 -> do@@ -219,10 +248,10 @@   where     ci c = (F.subcId c, F.sinfo c) -solResult :: Config -> Sol.Solution -> SolveM (M.HashMap F.KVar F.Expr)+solResult :: Config -> Sol.Solution -> SolveM ann (M.HashMap F.KVar F.Expr) solResult cfg = minimizeResult cfg . Sol.result -solNonCutsResult :: Sol.Solution -> SolveM (M.HashMap F.KVar F.Expr)+solNonCutsResult :: Sol.Solution -> SolveM ann (M.HashMap F.KVar F.Expr) solNonCutsResult s = do   be <- getBinds   return $ S.nonCutsResult be s@@ -233,7 +262,7 @@   -> Config   -> W.Worklist a   -> Sol.Solution-  -> SolveM (F.FixResult (F.SimpC a))+  -> SolveM a (F.FixResult (F.SimpC a)) result_ bindingsInSmt cfg w s = do   filtered <- filterM (isUnsat bindingsInSmt s) cs   sts      <- stats@@ -244,9 +273,9 @@     res sts cs' = F.Unsafe sts cs'  isChecked :: Config -> [F.SimpC a] -> [F.SimpC a]-isChecked cfg cs = case checkCstr cfg of -  []   -> cs -  ids  -> let s = S.fromList ids in +isChecked cfg cs = case checkCstr cfg of+  []   -> cs+  ids  -> let s = S.fromList ids in           [c | c <- cs, S.member (F.subcId c) s ]  --------------------------------------------------------------------------------@@ -260,13 +289,13 @@ --   see: tests/pos/min00.fq for an example. -------------------------------------------------------------------------------- minimizeResult :: Config -> M.HashMap F.KVar F.Expr-               -> SolveM (M.HashMap F.KVar F.Expr)+               -> SolveM ann (M.HashMap F.KVar F.Expr) -------------------------------------------------------------------------------- minimizeResult cfg s   | minimalSol cfg = mapM minimizeConjuncts s   | otherwise      = return s -minimizeConjuncts :: F.Expr -> SolveM F.Expr+minimizeConjuncts :: F.Expr -> SolveM ann F.Expr minimizeConjuncts p = F.pAnd <$> go (F.conjuncts p) []   where     go []     acc   = return acc@@ -276,7 +305,7 @@  -------------------------------------------------------------------------------- isUnsat-  :: (F.Loc a, NFData a) => F.IBindEnv -> Sol.Solution -> F.SimpC a -> SolveM Bool+  :: (F.Loc a, NFData a) => F.IBindEnv -> Sol.Solution -> F.SimpC a -> SolveM a Bool -------------------------------------------------------------------------------- isUnsat bindingsInSmt s c = do   -- lift   $ printf "isUnsat %s" (show (F.subcId c))@@ -304,9 +333,9 @@   | otherwise  = errorstar $ "rhsPred on non-target: " ++ show (F.sid c)  ---------------------------------------------------------------------------------isValid :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM Bool+isValid :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM ann Bool ---------------------------------------------------------------------------------isValid sp p q = (not . null) <$> filterValid sp p [(q, ())]+isValid sp p q = not . null <$> filterValid sp p [(q, ())]  cstrSpan :: (F.Loc a) => F.SimpC a -> F.SrcSpan cstrSpan = F.srcSpan . F.sinfo@@ -355,7 +384,7 @@   = zip [1..] ((takei i `mappend` (takei j){F.bs = mempty}):rest)   where     takei i = snd (fis L.!! (i - 1))-    rest = snd <$> filter (\(k,_) -> (k /= i && k /= j)) fis+    rest = snd <$> filter (\(k,_) -> k /= i && k /= j) fis  partitionInfo :: (Int, F.SInfo a) -> String partitionInfo (i, fi)

src/Language/Fixpoint/Solver/Stats.hs view

@@ -14,11 +14,7 @@ import qualified Language.Fixpoint.Types.PrettyPrint as F import Data.Aeson -#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif--data Stats = Stats +data Stats = Stats   { numCstr      :: !Int -- ^ # Horn Constraints   , numIter      :: !Int -- ^ # Refine Iterations   , numBrkt      :: !Int -- ^ # smtBracket    calls (push/pop)@@ -39,7 +35,7 @@                         ]  instance Semigroup Stats where-  s1 <> s2 = +  s1 <> s2 =     Stats { numCstr      = numCstr s1      + numCstr s2           , numIter      = numIter s1      + numIter s2           , numBrkt      = numBrkt s1      + numBrkt s2

src/Language/Fixpoint/Solver/TrivialSort.hs view

@@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Solver.TrivialSort (nontrivsorts) where  import           GHC.Generics        (Generic)@@ -84,10 +86,10 @@ updTISubC :: SubC a -> TrivInfo -> TrivInfo updTISubC c = updTI Lhs (slhs c) . updTI Rhs (srhs c) -updTIBinds :: BindEnv -> TrivInfo -> TrivInfo+updTIBinds :: BindEnv a -> TrivInfo -> TrivInfo updTIBinds be ti = foldl' (flip (updTI Lhs)) ti ts   where-    ts           = [t | (_,_,t) <- bindEnvToList be]+    ts           = [t | (_, (_,t,_)) <- bindEnvToList be]  -------------------------------------------------------------------- updTI :: Polarity -> SortedReft -> TrivInfo -> TrivInfo@@ -122,8 +124,8 @@     trivOrSingP p         = trivP p || singP v p  trivP :: Expr -> Bool-trivP (PKVar {}) = True-trivP p          = isTautoPred p+trivP PKVar {} = True+trivP p        = isTautoPred p  singP :: Symbol -> Expr -> Bool singP v (PAtom Eq (EVar x) _)@@ -141,8 +143,8 @@    , bs   = simplifyBindEnv tm $ bs fi } -simplifyBindEnv :: NonTrivSorts -> BindEnv -> BindEnv-simplifyBindEnv tm = mapBindEnv (\_ (x, sr) -> (x, simplifySortedReft tm sr))+simplifyBindEnv :: NonTrivSorts -> BindEnv a -> BindEnv a+simplifyBindEnv tm = mapBindEnv (\_ (x, sr, a) -> (x, simplifySortedReft tm sr, a))  simplifyWfCs :: NonTrivSorts -> M.HashMap KVar (WfC a) -> M.HashMap KVar (WfC a) simplifyWfCs tm = M.filter (isNonTrivialSort tm . snd3 . wrft)

src/Language/Fixpoint/Solver/UniqifyBinds.hs view

@@ -1,36 +1,37 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- This module makes it so no binds with different sorts have the same name.  module Language.Fixpoint.Solver.UniqifyBinds (renameAll) where  import           Language.Fixpoint.Types import           Language.Fixpoint.Solver.Sanitize (dropDeadSubsts)-import           Language.Fixpoint.Misc          (fst3, mlookup)+import           Language.Fixpoint.Misc          (fst3, mlookup, snd3)  import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S import qualified Data.List           as L import           Data.Foldable       (foldl')-import           Data.Maybe          (catMaybes, fromJust, isJust)+import           Data.Maybe          (catMaybes, mapMaybe, fromJust, isJust) import           Data.Hashable       (Hashable) import           GHC.Generics        (Generic)-import           Control.Arrow       (second) import           Control.DeepSeq     (NFData, ($!!)) -- import Debug.Trace (trace)  ---------------------------------------------------------------------------------renameAll    :: SInfo a -> SInfo a+renameAll    :: (NFData a) => SInfo a -> SInfo a -------------------------------------------------------------------------------- renameAll fi2 = fi6   where-    fi6       = {- SCC "dropDead"    #-} dropDeadSubsts  fi5-    fi5       = {- SCC "dropUnused"  #-} dropUnusedBinds fi4-    fi4       = {- SCC "renameBinds" #-} renameBinds fi3 $!! rnm-    fi3       = {- SCC "renameVars"  #-} renameVars fi2 rnm $!! idm-    rnm       = {- SCC "mkRenameMap" #-} mkRenameMap $!! bs fi2-    idm       = {- SCC "mkIdMap"     #-} mkIdMap fi2+    fi6       = {- SCC "dropDead"    -} dropDeadSubsts  fi5+    fi5       = {- SCC "dropUnused"  -} dropUnusedBinds fi4+    fi4       = {- SCC "renameBinds" -} renameBinds fi3 $!! rnm+    fi3       = {- SCC "renameVars"  -} renameVars fi2 rnm $!! idm+    rnm       = {- SCC "mkRenameMap" -} mkRenameMap $!! bs fi2+    idm       = {- SCC "mkIdMap"     -} mkIdMap fi2   --------------------------------------------------------------------------------@@ -71,19 +72,19 @@ -------------------------------------------------------------------------------- mkIdMap fi = M.foldlWithKey' (updateIdMap $ bs fi) M.empty $ cm fi -updateIdMap :: BindEnv -> IdMap -> Integer -> SimpC a -> IdMap+updateIdMap :: BindEnv a -> IdMap -> Integer -> SimpC a -> IdMap updateIdMap be m scId s = M.insertWith S.union (RI scId) refSet m'   where     ids                 = elemsIBindEnv (senv s)-    nameMap             = M.fromList [(fst $ lookupBindEnv i be, i) | i <- ids]+    nameMap             = M.fromList [(fst3 $ lookupBindEnv i be, i) | i <- ids]     m'                  = foldl' (insertIdIdLinks be nameMap) m ids     symSet              = S.fromList $ syms $ crhs s     refSet              = namesToIds symSet nameMap -insertIdIdLinks :: BindEnv -> M.HashMap Symbol BindId -> IdMap -> BindId -> IdMap+insertIdIdLinks :: BindEnv a -> M.HashMap Symbol BindId -> IdMap -> BindId -> IdMap insertIdIdLinks be nameMap m i = M.insertWith S.union (RB i) refSet m   where-    sr     = snd $ lookupBindEnv i be+    sr     = snd3 $ lookupBindEnv i be     symSet = reftFreeVars $ sr_reft sr     refSet = namesToIds symSet nameMap @@ -91,18 +92,19 @@ namesToIds xs m = S.fromList $ catMaybes [M.lookup x m | x <- S.toList xs] --TODO why any Nothings?  ---------------------------------------------------------------------------------mkRenameMap :: BindEnv -> RenameMap+mkRenameMap :: BindEnv a -> RenameMap -------------------------------------------------------------------------------- mkRenameMap be = foldl' (addId be) M.empty ids   where-    ids = fst3 <$> bindEnvToList be+    ids = fst <$> bindEnvToList be -addId :: BindEnv -> RenameMap -> BindId -> RenameMap+addId :: BindEnv a -> RenameMap -> BindId -> RenameMap addId be m i   | M.member sym m = addDupId m sym t i   | otherwise      = M.insert sym [(t, Nothing)] m   where-    (sym, t)       = second sr_sort $ lookupBindEnv i be+    t              = sr_sort sr+    (sym, sr, _)   = lookupBindEnv i be  addDupId :: RenameMap -> Symbol -> Sort -> BindId -> RenameMap addDupId m sym t i@@ -122,8 +124,9 @@ updateRef :: RenameMap -> SInfo a -> Ref -> S.HashSet BindId -> SInfo a updateRef rnMap fi rf bset = applySub (mkSubst subs) fi rf   where-    symTList = [second sr_sort $ lookupBindEnv i $ bs fi | i <- S.toList bset]-    subs     = catMaybes $ mkSubUsing rnMap <$> symTList+    symTList = [ (sym, sr_sort sr) | i <- S.toList bset, let (sym, sr, _) = lookupBindEnv i bEnv]+    bEnv     = bs fi+    subs     = mapMaybe (mkSubUsing rnMap) symTList  mkSubUsing :: RenameMap -> (Symbol, Sort) -> Maybe (Symbol, Expr) mkSubUsing m (sym, t) = do@@ -144,12 +147,12 @@ -------------------------------------------------------------------------------- renameBinds fi m = fi { bs = bindEnvFromList $ renameBind m <$> beList }   where-    beList       = bindEnvToList $ bs fi+    beList       = bindEnvToList (bs fi) -renameBind :: RenameMap -> (BindId, Symbol, SortedReft) -> (BindId, Symbol, SortedReft)-renameBind m (i, sym, sr)-  | Just newSym <- mnewSym = (i, newSym, sr)-  | otherwise              = (i, sym,    sr)+renameBind :: RenameMap -> (BindId, (Symbol, SortedReft, a)) -> (BindId, (Symbol, SortedReft, a))+renameBind m (i, (sym, sr, ann))+  | Just newSym <- mnewSym = (i, (newSym, sr, ann))+  | otherwise              = (i, (sym,    sr, ann))   where     t                      = sr_sort sr     mnewSym                = fromJust $ L.lookup t $ mlookup m sym

src/Language/Fixpoint/Solver/UniqifyKVars.hs view

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ {- | This module creates new bindings for each argument of each kvar.      It also makes sure that all arguments to each kvar are explicit. @@ -75,31 +77,32 @@   where     w'            = updateWfCExpr (subst su) w''     w''           = w { wenv = insertsIBindEnv newIds mempty, wrft = (v', t, k) }-    (_, fi'')     = newTopBind v' (trueSortedReft t) fi'-    (fi', newIds) = foldl' (accumBindsIfValid k) (fi, []) (elemsIBindEnv $ wenv w)+    (_, fi'')     = newTopBind v' (trueSortedReft t) a fi'+    (fi', newIds) = foldl' (accumBindsIfValid k a) (fi, []) (elemsIBindEnv $ wenv w)     (v, t, k)     = wrft w     v'            = kArgSymbol v (kv k)     su            = mkSubst ((v, EVar v'):[(x, eVar $ kArgSymbol x (kv k)) | x <- kvarDomain fi k])+    a             = winfo w -accumBindsIfValid :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])-accumBindsIfValid k (fi, ids) i = if renamable then accumBinds k (fi, ids) i else (fi, i : ids)+accumBindsIfValid :: KVar -> a -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])+accumBindsIfValid k a (fi, ids) i = if renamable then accumBinds k a (fi, ids) i else (fi, i : ids)   where-    (_, sr)                     = lookupBindEnv i      (bs fi)+    (_, sr, _)                    = lookupBindEnv i      (bs fi)     renamable                   = isValidInRefinements (sr_sort sr) -accumBinds :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])-accumBinds k (fi, ids) i = (fi', i' : ids)+accumBinds :: KVar -> a -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])+accumBinds k a (fi, ids) i = (fi', i' : ids)   where-    (oldSym, sr) = lookupBindEnv i (bs fi)+    (oldSym, sr,_) = lookupBindEnv i (bs fi)     newSym       = {- tracepp "kArgSymbol" $ -}  kArgSymbol oldSym (kv k)-    (i', fi')    = newTopBind newSym sr fi+    (i', fi')    = newTopBind newSym sr a fi  -- | `newTopBind` ignores the actual refinements as they are not relevant --   in the kvar parameters (as suggested by BLC.)-newTopBind :: Symbol -> SortedReft -> SInfo a -> (BindId, SInfo a)-newTopBind x sr fi = (i', fi {bs = be'})+newTopBind :: Symbol -> SortedReft -> a -> SInfo a -> (BindId, SInfo a)+newTopBind x sr a fi = (i', fi {bs = be'})   where-    (i', be')   = insertBindEnv x (top sr) (bs fi)+    (i', be')        = insertBindEnv x (top sr) a (bs fi)  --------------------------------------------------------------

src/Language/Fixpoint/Solver/Worklist.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE TupleSections         #-}  module Language.Fixpoint.Solver.Worklist        ( -- * Worklist type is opaque

src/Language/Fixpoint/SortCheck.hs view

@@ -1,8 +1,6 @@ {-# LANGUAGE CPP                   #-} {-# LANGUAGE Strict                #-}-{-# LANGUAGE StrictData            #-} {-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections         #-}@@ -11,6 +9,8 @@ {-# LANGUAGE BangPatterns          #-} {-# LANGUAGE RankNTypes            #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | This module has the functions that perform sort-checking, and related -- operations on Fixpoint expressions and predicates. @@ -31,7 +31,7 @@   , sortExpr   , checkSortExpr   , exprSort-  , exprSort_maybe+  , exprSortMaybe    -- * Unify   , unifyFast@@ -50,7 +50,14 @@   -- * Sort-Directed Transformations   , Elaborate (..)   , applySorts-  , unElab, unElabSortedReft, unApplyAt+  , elabApply+  , elabExpr+  , elabNumeric+  , unApply+  , unElab+  , unElabSortedReft+  , unApplySortedReft+  , unApplyAt   , toInt    -- * Predicates on Sorts@@ -70,14 +77,10 @@ import           Data.IORef import qualified Data.List                 as L import           Data.Maybe                (mapMaybe, fromMaybe, catMaybes, isJust)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif - import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types hiding   (subst)+import           Language.Fixpoint.Types hiding   (subst, GInfo(..), senv) import qualified Language.Fixpoint.Types.Visitor  as Vis import qualified Language.Fixpoint.Smt.Theories   as Thy import           Text.PrettyPrint.HughesPJ.Compat@@ -124,11 +127,12 @@  instance (Loc a) => Elaborate (SInfo a) where   elaborate x senv si = si-    { cm      = elaborate x senv <$> cm      si-    , bs      = elaborate x senv  $  bs      si-    , asserts = elaborate x senv <$> asserts si+    { F.cm      = elaborate x senv <$> F.cm      si+    , F.bs      = elaborate x senv  $  F.bs      si+    , F.asserts = elaborate x senv <$> F.asserts si     } + instance (Elaborate e) => (Elaborate (Triggered e)) where   elaborate x env t = fmap (elaborate x env) t @@ -148,27 +152,27 @@  instance Elaborate AxiomEnv where   elaborate msg env ae = ae-    { aenvEqs   = elaborate msg env (aenvEqs ae) -    -- MISSING SORTS OOPS, aenvSimpl = elaborate msg env (aenvSimpl ae) +    { aenvEqs   = elaborate msg env (aenvEqs ae)+    -- MISSING SORTS OOPS, aenvSimpl = elaborate msg env (aenvSimpl ae)     } -instance Elaborate Rewrite where -  elaborate msg env rw = rw { smBody = skipElabExpr msg env' (smBody rw) } -    where +instance Elaborate Rewrite where+  elaborate msg env rw = rw { smBody = skipElabExpr msg env' (smBody rw) }+    where       env' = insertsSymEnv env undefined -instance Elaborate Equation where -  elaborate msg env eq = eq { eqBody = skipElabExpr msg env' (eqBody eq) } +instance Elaborate Equation where+  elaborate msg env eq = eq { eqBody = skipElabExpr msg env' (eqBody eq) }     where-      env' = insertsSymEnv env (eqArgs eq) +      env' = insertsSymEnv env (eqArgs eq)  instance Elaborate Expr where   elaborate msg env = elabNumeric . elabApply env . elabExpr msg env  -skipElabExpr :: Located String -> SymEnv -> Expr -> Expr -skipElabExpr msg env e = case elabExprE msg env e of -  Left _   -> e +skipElabExpr :: Located String -> SymEnv -> Expr -> Expr+skipElabExpr msg env e = case elabExprE msg env e of+  Left _   -> e   Right e' ->  elabNumeric . elabApply env $ e'  instance Elaborate (Symbol, Sort) where@@ -197,11 +201,10 @@       e'   = elaborate x env' e       env' = insertSymEnv v s env -instance Elaborate BindEnv where-  elaborate z env = mapBindEnv (\i (x, sr) -> (x, elaborate (z' i x sr) env sr))+instance (Loc a) => Elaborate (BindEnv a) where+  elaborate msg env = mapBindEnv (\i (x, sr, l) -> (x, elaborate (msg' l i x sr) env sr, l))     where-      z' i  x sr  = z { val = (val z) ++ msg i x sr }-      msg i x sr  = unwords [" elabBE",  show i, show x, show sr]+      msg' l i x sr = atLoc l (val msg ++ unwords [" elabBE",  show i, show x, show sr])  instance (Loc a) => Elaborate (SimpC a) where   elaborate msg env c = c {_crhs = elaborate msg' env (_crhs c) }@@ -210,20 +213,20 @@ -- | 'elabExpr' adds "casts" to decorate polymorphic instantiation sites. -------------------------------------------------------------------------------- elabExpr :: Located String -> SymEnv -> Expr -> Expr-elabExpr msg env e = case elabExprE msg env e of -  Left ex  -> die ex -  Right e' -> F.notracepp ("elabExp " ++ showpp e) e' +elabExpr msg env e = case elabExprE msg env e of+  Left ex  -> die ex+  Right e' -> F.notracepp ("elabExp " ++ showpp e) e'  elabExprE :: Located String -> SymEnv -> Expr -> Either Error Expr-elabExprE msg env e = -  case runCM0 (srcSpan msg) (elab (env, f) e) of-    Left (ChError f) ->-      let e = f ()-       in Left $ err (srcSpan e) (d (val e))+elabExprE msg env e =+  case runCM0 (srcSpan msg) (elab (env, envLookup) e) of+    Left (ChError f') ->+      let e' = f' ()+       in Left $ err (srcSpan e') (d (val e'))     Right s  -> Right (fst s)   where     sEnv = seSort env-    f    = (`lookupSEnvWithDistance` sEnv)+    envLookup = (`lookupSEnvWithDistance` sEnv)     d m  = vcat [ "elaborate" <+> text (val msg) <+> "failed on:"                 , nest 4 (pprint e)                 , "with error"@@ -259,10 +262,10 @@     step (ELam b e)       = ELam b       (go e)     step (ECoerc a t e)   = ECoerc a t   (go e)     step (PGrad k su i e) = PGrad k su i (go e)-    step e@(PKVar {})     = e-    step e@(ESym {})      = e-    step e@(ECon {})      = e-    step e@(EVar {})      = e+    step e@PKVar{}        = e+    step e@ESym{}         = e+    step e@ECon{}         = e+    step e@EVar{}         = e     -- ETApp, ETAbs, PAll, PExist     step e                = error $ "TODO elabApply: " ++ showpp e @@ -271,7 +274,7 @@ -------------------------------------------------------------------------------- sortExpr :: SrcSpan -> SEnv Sort -> Expr -> Sort sortExpr l γ e = case runCM0 l (checkExpr f e) of-    Left (ChError f) -> die $ err l (d (val (f ())))+    Left (ChError f') -> die $ err l (d (val (f' ())))     Right s -> s   where     f   = (`lookupSEnvWithDistance` γ)@@ -293,7 +296,7 @@             Nothing -> Alts []  subEnv :: (Subable e) => SEnv a -> e -> SEnv a-subEnv g e = intersectWithSEnv (\t _ -> t) g g'+subEnv g e = intersectWithSEnv const g g'   where     g' = fromListSEnv $ (, ()) <$> syms e @@ -321,9 +324,9 @@   ---------------------------------------------------------------------------------mkSearchEnv :: SEnv a -> Symbol -> SESearch a +mkSearchEnv :: SEnv a -> Symbol -> SESearch a ---------------------------------------------------------------------------------mkSearchEnv env x = lookupSEnvWithDistance x env  +mkSearchEnv env x = lookupSEnvWithDistance x env  -- withError :: CheckM a -> ChError -> CheckM a -- act `withError` e' = act `catchError` (\e -> throwError (atLoc e (val e ++ "\n  because\n" ++ val e')))@@ -335,21 +338,26 @@     (\(ChError f) ->       throwIO $ ChError $ \_ ->         let e = f ()-         in (atLoc e (val e ++ "\n  because\n" ++ msg))+         in atLoc e (val e ++ "\n  because\n" ++ msg)     ) +-- XXX: Why start at 42?+{-# NOINLINE varCounterRef #-}+varCounterRef :: IORef Int+varCounterRef = unsafePerformIO $ newIORef 42++-- XXX: Since 'varCounterRef' was made global, this+-- function is not referentially transparent.+-- Each evaluation of the function starts with a different+-- value of counter. runCM0 :: SrcSpan -> CheckM a -> Either ChError a runCM0 sp act = unsafePerformIO $ do-  rn <- newIORef 42-  try (runReaderT act (ChS rn sp))+  try (runReaderT act (ChS varCounterRef sp))  fresh :: CheckM Int fresh = do   rn <- asks chCount-  liftIO $ do-    n <- readIORef rn-    writeIORef rn (n + 1)-    return n+  liftIO $ atomicModifyIORef' rn $ \n -> (n+1, n)  -------------------------------------------------------------------------------- -- | Checking Refinements ------------------------------------------------------@@ -362,7 +370,7 @@     Reft (v,_)            = sr_reft sr  checkSortedReftFull :: Checkable a => SrcSpan -> SEnv SortedReft -> a -> Maybe Doc-checkSortedReftFull sp γ t = +checkSortedReftFull sp γ t =   case runCM0 sp (check γ' t) of     Left (ChError f)  -> Just (text (val (f ())))     Right _ -> Nothing@@ -370,7 +378,7 @@     γ' = sr_sort <$> γ  checkSortFull :: Checkable a => SrcSpan -> SEnv SortedReft -> Sort -> a -> Maybe Doc-checkSortFull sp γ s t = +checkSortFull sp γ s t =   case runCM0 sp (checkSort γ' s t) of     Left (ChError f)  -> Just (text (val (f ())))     Right _ -> Nothing@@ -378,25 +386,25 @@       γ' = sr_sort <$> γ  checkSorted :: Checkable a => SrcSpan -> SEnv Sort -> a -> Maybe Doc-checkSorted sp γ t = +checkSorted sp γ t =   case runCM0 sp (check γ t) of     Left (ChError f)  -> Just (text (val (f ())))     Right _  -> Nothing  pruneUnsortedReft :: SEnv Sort -> Templates -> SortedReft -> SortedReft-pruneUnsortedReft _ t r -  | isEmptyTemplates t -  = r +pruneUnsortedReft _ t r+  | isEmptyTemplates t+  = r pruneUnsortedReft γ t (RR s (Reft (v, p)))-  | isAnyTemplates t -  -- this is the old code that checks everything +  | isAnyTemplates t+  -- this is the old code that checks everything   = RR s (Reft (v, tx filterAny p))   | otherwise   = RR s (Reft (v, tx (filter filterWithTemplate) p))   where     filterAny = mapMaybe (checkPred' f)     filterWithTemplate e =  not (matchesTemplates t e) || isJust (checkPred' f e)-    tx f = pAnd . f . conjuncts+    tx f' = pAnd . f' . conjuncts     f    = (`lookupSEnvWithDistance` γ')     γ'   = insertSEnv v s γ     -- wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t@@ -447,13 +455,13 @@ checkExpr f (PAnd ps)      = mapM_ (checkPred f) ps >> return boolSort checkExpr f (POr ps)       = mapM_ (checkPred f) ps >> return boolSort checkExpr f (PAtom r e e') = checkRel f r e e' >> return boolSort-checkExpr _ (PKVar {})     = return boolSort+checkExpr _ PKVar{}        = return boolSort checkExpr f (PGrad _ _ _ e)  = checkPred f e >> return boolSort  checkExpr f (PAll  bs e )  = checkExpr (addEnv f bs) e checkExpr f (PExist bs e)  = checkExpr (addEnv f bs) e checkExpr f (ELam (x,t) e) = FFunc t <$> checkExpr (addEnv f [(x,t)]) e-checkExpr f (ECoerc s t e) = checkExpr f (ECst e s) >> return t +checkExpr f (ECoerc s t e) = checkExpr f (ECst e s) >> return t checkExpr _ (ETApp _ _)    = error "SortCheck.checkExpr: TODO: implement ETApp" checkExpr _ (ETAbs _ _)    = error "SortCheck.checkExpr: TODO: implement ETAbs" @@ -473,17 +481,17 @@   (e1', s1) <- elab f e1   (e2', s2) <- elab f e2   s <- checkOpTy g e s1 s2-  return (EBin o (ECst e1' s1) (ECst e2' s2), s)+  return (EBin o (eCst e1' s1) (eCst e2' s2), s)  elab f (EApp e1@(EApp _ _) e2) = do   (e1', _, e2', s2, s) <- notracepp "ELAB-EAPP" <$> elabEApp f e1 e2-  let e = eAppC s e1' (ECst e2' s2)+  let e = eAppC s e1' (eCst e2' s2)   let θ = unifyExpr (snd f) e   return (applyExpr θ e, maybe s (`apply` s) θ)  elab f (EApp e1 e2) = do   (e1', s1, e2', s2, s) <- elabEApp f e1 e2-  let e = eAppC s (ECst e1' s1) (ECst e2' s2)+  let e = eAppC s (eCst e1' s1) (eCst e2' s2)   let θ = unifyExpr (snd f) e   return (applyExpr θ e, maybe s (`apply` s) θ) @@ -503,7 +511,7 @@   return (e, boolSort)  elab f (PGrad k su i e) =-  ((, boolSort) . PGrad k su i . fst) <$> elab f e+  (, boolSort) . PGrad k su i . fst <$> elab f e  elab (_, f) e@(EVar x) =   (e,) <$> checkSym f x@@ -514,22 +522,22 @@  elab f@(_,g) (ECst (EIte p e1 e2) t) = do   (p', _)   <- elab f p-  (e1', s1) <- elab f (ECst e1 t)-  (e2', s2) <- elab f (ECst e2 t)+  (e1', s1) <- elab f (eCst e1 t)+  (e2', s2) <- elab f (eCst e2 t)   s         <- checkIteTy g p e1' e2' s1 s2-  return (EIte p' (cast e1' s) (cast e2' s), t)+  return (EIte p' (eCst e1' s) (eCst e2' s), t)  elab f@(_,g) (EIte p e1 e2) = do-  t <- getIte g e1 e2 +  t <- getIte g e1 e2   (p', _)   <- elab f p-  (e1', s1) <- elab f (ECst e1 t)-  (e2', s2) <- elab f (ECst e2 t)+  (e1', s1) <- elab f (eCst e1 t)+  (e2', s2) <- elab f (eCst e2 t)   s         <- checkIteTy g p e1' e2' s1 s2-  return (EIte p' (cast e1' s) (cast e2' s), s)+  return (EIte p' (eCst e1' s) (eCst e2' s), s)  elab f (ECst e t) = do   (e', _) <- elab f e-  return (ECst e' t, t)+  return (eCst e' t, t)  elab f (PNot p) = do   (e', _) <- elab f p@@ -556,7 +564,7 @@ elab f@(_,g) e@(PAtom eq e1 e2) | eq == Eq || eq == Ne = do   t1        <- checkExpr g e1   t2        <- checkExpr g e2-  (t1',t2') <- unite g e  t1 t2 `withError` (errElabExpr e)+  (t1',t2') <- unite g e  t1 t2 `withError` errElabExpr e   e1'       <- elabAs f t1' e1   e2'       <- elabAs f t2' e2   e1''      <- eCstAtom f e1' t1'@@ -587,7 +595,7 @@ elab f (ELam (x,t) e) = do   (e', s) <- elab (elabAddEnv f [(x, t)]) e   let t' = elaborate "ELam Arg" mempty t-  return (ELam (x, t') (ECst e' s), FFunc t s)+  return (ELam (x, t') (eCst e' s), FFunc t s)  elab f (ECoerc s t e) = do   (e', _) <- elab f e@@ -601,14 +609,14 @@  -- | 'eCstAtom' is to support tests like `tests/pos/undef00.fq` eCstAtom :: ElabEnv -> Expr -> Sort -> CheckM Expr-eCstAtom f@(sym,g) (EVar x) t +eCstAtom f@(sym,g) (EVar x) t   | Found s <- g x-  , isUndef s +  , isUndef s   , not (isInt sym t) = (`ECst` t) <$> elabAs f t (EApp (eVar tyCastName) (eVar x)) eCstAtom _ e t = return (ECst e t)  isUndef :: Sort -> Bool-isUndef s = case bkAbs s of +isUndef s = case bkAbs s of   (is, FVar j) -> j `elem` is   _            -> False @@ -616,16 +624,12 @@ elabAddEnv :: Eq a => (t, a -> SESearch b) -> [(a, b)] -> (t, a -> SESearch b) elabAddEnv (g, f) bs = (g, addEnv f bs) -cast :: Expr -> Sort -> Expr-cast (ECst e _) t = ECst e t-cast e          t = ECst e t- elabAs :: ElabEnv -> Sort -> Expr -> CheckM Expr elabAs f t e = notracepp _msg <$>  go e   where     _msg  = "elabAs: t = " ++ showpp t ++ " e = " ++ showpp e     go (EApp e1 e2)   = elabAppAs f t e1 e2-    go e              = fst    <$> elab f e+    go e'              = fst    <$> elab f e'  -- DUPLICATION with `checkApp'` elabAppAs :: ElabEnv -> Sort -> Expr -> Expr -> CheckM Expr@@ -653,20 +657,21 @@   let e            = Just (EApp e1 e2)   (sIn, sOut, su) <- checkFunSort s1   su'             <- unify1 f e su sIn s2-  return           $ (applyExpr (Just su') e1, applyExpr (Just su') e2, apply su' s1, apply su' s2, apply su' sOut)+  return (applyExpr (Just su') e1, applyExpr (Just su') e2, apply su' s1, apply su' s2, apply su' sOut)   -------------------------------------------------------------------------------- -- | defuncEApp monomorphizes function applications. -------------------------------------------------------------------------------- defuncEApp :: SymEnv -> Expr -> [(Expr, Sort)] -> Expr-defuncEApp env e es = L.foldl' makeApplication e' es'+defuncEApp _env e [] = e+defuncEApp env e es = eCst (L.foldl' makeApplication e' es') (snd $ last es)   where     (e', es')       = takeArgs (seTheory env) e es  takeArgs :: SEnv TheorySymbol -> Expr -> [(Expr, a)] -> (Expr, [(Expr, a)]) takeArgs env e es =-  case Thy.isSmt2App env (Vis.stripCasts e) of+  case Thy.isSmt2App env e of     Just n  -> let (es1, es2) = splitAt n es                in (eApps e (fst <$> es1), es2)     Nothing -> (e, es)@@ -709,21 +714,24 @@ unElabSortedReft :: SortedReft -> SortedReft unElabSortedReft sr = sr { sr_reft = mapPredReft unElab (sr_reft sr) } +unApplySortedReft :: SortedReft -> SortedReft+unApplySortedReft sr = sr { sr_reft = mapPredReft unApply (sr_reft sr) }+ unApply :: Expr -> Expr-unApply = Vis.trans (Vis.defaultVisitor { Vis.txExpr = const go }) () ()+unApply = Vis.mapExprOnExpr go   where     go (ECst (EApp (EApp f e1) e2) _)       | Just _ <- unApplyAt f = EApp e1 e2-    go (ELam (x,s) e)         = ELam (x, Vis.mapSort go' s) e +    go (ELam (x,s) e)         = ELam (x, Vis.mapSort go' s) e     go e                      = e -    go' (FApp (FApp fs t1) t2) | fs == funcSort -          = FFunc t1 t2 -    go' t = t +    go' (FApp (FApp fs t1) t2) | fs == funcSort+          = FFunc t1 t2+    go' t = t   unApplyAt :: Expr -> Maybe Sort-unApplyAt (ECst (EVar f) t@(FFunc {}))+unApplyAt (ECst (EVar f) t@FFunc{})   | f == applyName = Just t unApplyAt _        = Nothing @@ -773,20 +781,20 @@ proj :: Field a -> a -> a proj fld x = case fld of                FInt  -> 1 + x-               FBool -> not b  +               FBool -> not b ```  ## The Problem  The problem is you cannot encode the body of `proj` as a well-sorted refinement:- + ```haskell     if is$FInt fld         then (1 + (coerce (a ~ Int)  x))         else (not (coerce (a ~ Bool) x)) ``` -The catch is that `x` is being used BOTH as `Int` and as `Bool` +The catch is that `x` is being used BOTH as `Int` and as `Bool` which is not supported in SMTLIB.  ## Approach: Uninterpreted Functions@@ -799,7 +807,7 @@         else (not (coerce@(a -> bool) x)) ``` -where we define, extra constants in the style of `apply` +where we define, extra constants in the style of `apply`  ```haskell    constant coerce@(a -> int ) :: a -> int@@ -853,19 +861,19 @@            | f == applyName            = [t]     go _ (ECoerc t1 t2 _)             -- get types needed for [NOTE:coerce-apply]-           = [FFunc t1 t2] +           = [FFunc t1 t2]     go _ _ = []  -------------------------------------------------------------------------------- -- | Expressions sort  --------------------------------------------------------- -------------------------------------------------------------------------------- exprSort :: String -> Expr -> Sort-exprSort msg e = fromMaybe (panic err) (exprSort_maybe e)+exprSort msg e = fromMaybe (panic err') (exprSortMaybe e)   where-    err        = printf "exprSort [%s] on unexpected expression %s" msg (show e)+    err'        = printf "exprSort [%s] on unexpected expression %s" msg (show e) -exprSort_maybe :: Expr -> Maybe Sort-exprSort_maybe = go+exprSortMaybe :: Expr -> Maybe Sort+exprSortMaybe = go   where     go (ECst _ s) = Just s     go (ELam (_, sx) e) = FFunc sx <$> go e@@ -883,11 +891,11 @@   su <- unifys f (Just e) [t1] [t2]   return (apply su t1, apply su t2) -throwErrorAt :: String -> CheckM a -throwErrorAt ~err = do -- Lazy pattern needed because we use LANGUAGE Strict in this module+throwErrorAt :: String -> CheckM a+throwErrorAt ~err' = do -- Lazy pattern needed because we use LANGUAGE Strict in this module                        -- See Note [Lazy error messages]   sp <- asks chSpan-  liftIO $ throwIO (ChError (\_ -> atLoc sp err))+  liftIO $ throwIO (ChError (\_ -> atLoc sp err'))  -- Note [Lazy error messages] --@@ -909,15 +917,15 @@   t2 <- checkExpr f e2   checkIteTy f p e1 e2 t1 t2 -getIte :: Env -> Expr -> Expr -> CheckM Sort -getIte f e1 e2 = do -  t1 <- checkExpr f e1 -  t2 <- checkExpr f e2 +getIte :: Env -> Expr -> Expr -> CheckM Sort+getIte f e1 e2 = do+  t1 <- checkExpr f e1+  t2 <- checkExpr f e2   (`apply` t1) <$> unifys f Nothing [t1] [t2]  checkIteTy :: Env -> Expr -> Expr -> Expr -> Sort -> Sort -> CheckM Sort checkIteTy f p e1 e2 t1 t2-  = ((`apply` t1) <$> unifys f e' [t1] [t2]) `withError` (errIte e1 e2 t1 t2)+  = ((`apply` t1) <$> unifys f e' [t1] [t2]) `withError` errIte e1 e2 t1 t2   where     e' = Just (EIte p e1 e2) @@ -927,7 +935,7 @@   = checkApp f (Just t) g e checkCst f t e   = do t' <- checkExpr f e-       ((`apply` t) <$> unifys f (Just e) [t] [t']) `withError` (errCast e t' t)+       ((`apply` t) <$> unifys f (Just e) [t] [t']) `withError` errCast e t' t  checkApp :: Env -> Maybe Sort -> Expr -> Expr -> CheckM Sort checkApp f to g es@@ -1010,13 +1018,13 @@ checkNumeric _ s   = unless (isNumeric s) (throwErrorAt $ errNonNumeric s) -checkEqConstr :: Env -> Maybe Expr -> TVSubst -> Symbol -> Sort -> CheckM TVSubst +checkEqConstr :: Env -> Maybe Expr -> TVSubst -> Symbol -> Sort -> CheckM TVSubst checkEqConstr _ _  θ a (FObj b)   | a == b   = return θ-checkEqConstr f e θ a t = do+checkEqConstr f e θ a t =   case f a of-    Found tA -> unify1 f e θ tA t +    Found tA -> unify1 f e θ tA t     _        -> throwErrorAt $ errUnifyMsg (Just "ceq2") e (FObj a) t  --------------------------------------------------------------------------------@@ -1035,7 +1043,7 @@ checkRel f Eq e1 e2 = do   t1 <- checkExpr f e1   t2 <- checkExpr f e2-  su <- (unifys f (Just e) [t1] [t2]) `withError` (errRel e t1 t2)+  su <- unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2   _  <- checkExprAs f (apply su t1) e1   _  <- checkExprAs f (apply su t2) e2   checkRelTy f e Eq t1 t2@@ -1050,23 +1058,23 @@  checkRelTy :: Env -> Expr -> Brel -> Sort -> Sort -> CheckM () checkRelTy _ e Ueq s1 s2     = checkURel e s1 s2-checkRelTy _ e Une s1 s2     = checkURel e s1 s2 +checkRelTy _ e Une s1 s2     = checkURel e s1 s2 checkRelTy f _ _ s1@(FObj l) s2@(FObj l') | l /= l'-                             = (checkNumeric f s1 >> checkNumeric f s2) `withError` (errNonNumerics l l')+                             = (checkNumeric f s1 >> checkNumeric f s2) `withError` errNonNumerics l l' checkRelTy _ _ _ FReal FReal = return () checkRelTy _ _ _ FInt  FReal = return () checkRelTy _ _ _ FReal FInt  = return ()-checkRelTy f _ _ FInt  s2    = checkNumeric    f s2 `withError` (errNonNumeric s2)-checkRelTy f _ _ s1    FInt  = checkNumeric    f s1 `withError` (errNonNumeric s1)-checkRelTy f _ _ FReal s2    = checkFractional f s2 `withError` (errNonFractional s2)-checkRelTy f _ _ s1    FReal = checkFractional f s1 `withError` (errNonFractional s1)-checkRelTy f e Eq t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` (errRel e t1 t2))-checkRelTy f e Ne t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` (errRel e t1 t2))+checkRelTy f _ _ FInt  s2    = checkNumeric    f s2 `withError` errNonNumeric s2+checkRelTy f _ _ s1    FInt  = checkNumeric    f s1 `withError` errNonNumeric s1+checkRelTy f _ _ FReal s2    = checkFractional f s2 `withError` errNonFractional s2+checkRelTy f _ _ s1    FReal = checkFractional f s1 `withError` errNonFractional s1+checkRelTy f e Eq t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2)+checkRelTy f e Ne t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2) checkRelTy _ e _  t1 t2      = unless (t1 == t2) (throwErrorAt $ errRel e t1 t2)  checkURel :: Expr -> Sort -> Sort -> CheckM () checkURel e s1 s2 = unless (b1 == b2) (throwErrorAt $ errRel e s1 s2)-  where +  where     b1            = s1 == boolSort     b2            = s2 == boolSort @@ -1088,8 +1096,8 @@  unifyExprApp :: Env -> Expr -> Expr -> Maybe TVSubst unifyExprApp f e1 e2 = do-  t1 <- getArg $ exprSort_maybe e1-  t2 <- exprSort_maybe e2+  t1 <- getArg $ exprSortMaybe e1+  t2 <- exprSortMaybe e2   unify f (Just $ EApp e1 e2) t1 t2   where     getArg (Just (FFunc t1 _)) = Just t1@@ -1110,21 +1118,21 @@ -------------------------------------------------------------------------------- unifyTo1 :: Env -> [Sort] -> Maybe Sort ---------------------------------------------------------------------------------unifyTo1 f ts  +unifyTo1 f ts   = case runCM0 dummySpan (unifyTo1M f ts) of       Left _  -> Nothing-      Right t -> Just t +      Right t -> Just t   ---------------------------------------------------------------------------------unifyTo1M :: Env -> [Sort] -> CheckM Sort +unifyTo1M :: Env -> [Sort] -> CheckM Sort -------------------------------------------------------------------------------- unifyTo1M _ []     = panic "unifyTo1: empty list" unifyTo1M f (t0:ts) = snd <$> foldM step (emptySubst, t0) ts-  where +  where     step :: (TVSubst, Sort) -> Sort -> CheckM (TVSubst, Sort)-    step (su, t) t' = do -      su' <- unify1 f Nothing su t t' +    step (su, t) t' = do+      su' <- unify1 f Nothing su t t'       return (su', apply su' t)  @@ -1133,7 +1141,7 @@ -------------------------------------------------------------------------------- unifySorts   = unifyFast False emptyEnv   where-    emptyEnv = const $ die $ err dummySpan "SortChecl: lookup in Empty Env "+    emptyEnv x = die $ err dummySpan $ "SortCheck: lookup in Empty Env: " <> pprint x   --------------------------------------------------------------------------------@@ -1148,20 +1156,20 @@  {- eqFast :: Sort -> Sort -> Bool-eqFast = go -  where +eqFast = go+  where     go FAbs {} _       = False-    go (FFunc s1 s2) t = case t of +    go (FFunc s1 s2) t = case t of                           FFunc t1 t2 -> go s1 t1 && go s2 t2                           _ -> False-    go (FApp s1 s2)  t = case t of +    go (FApp s1 s2)  t = case t of                           FApp t1 t2 ->  go s1 t1 && go s2 t2                           _ -> False -    go (FTC s1) t      = case t of +    go (FTC s1) t      = case t of                             FTC t1 -> s1 == t1                             _ -> False-    +     go FInt FInt           = True     go FReal FReal         = True     go FNum FNum           = True@@ -1169,7 +1177,7 @@     go (FVar i1) (FVar i2) = i1 == i2     go _ _                 = False - -} + -} -------------------------------------------------------------------------------- unifys :: HasCallStack => Env -> Maybe Expr -> [Sort] -> [Sort] -> CheckM TVSubst --------------------------------------------------------------------------------@@ -1190,7 +1198,7 @@ unify1 _ _ !θ (FTC !l1) (FTC !l2)   | isListTC l1 && isListTC l2   = return θ-unify1 f e !θ !t1@(FAbs _ _) !t2 = do+unify1 f e !θ t1@(FAbs _ _) !t2 = do   !t1' <- instantiate t1   unifyMany f e θ [t1'] [t2] unify1 f e !θ !t1 t2@(FAbs _ _) = do@@ -1199,19 +1207,19 @@ unify1 _ _ !θ !s1 !s2   | isString s1, isString s2   = return θ-unify1 _ _ !θ !FInt  !FReal = return θ+unify1 _ _ !θ FInt  FReal = return θ -unify1 _ _ !θ !FReal !FInt  = return θ+unify1 _ _ !θ FReal FInt  = return θ  unify1 f e !θ !t FInt = do-  checkNumeric f t `withError` (errUnify e t FInt)+  checkNumeric f t `withError` errUnify e t FInt   return θ -unify1 f e !θ !FInt !t = do-  checkNumeric f t `withError` (errUnify e FInt t)+unify1 f e !θ FInt !t = do+  checkNumeric f t `withError` errUnify e FInt t   return θ -unify1 f e !θ (FFunc !t1 !t2) (FFunc !t1' !t2') = do+unify1 f e !θ (FFunc !t1 !t2) (FFunc !t1' !t2') =   unifyMany f e θ [t1, t2] [t1', t2']  unify1 f e θ (FObj a) !t =@@ -1227,7 +1235,7 @@   = throwErrorAt (errUnify e t1 t2)  subst :: Int -> Sort -> Sort -> Sort-subst !j !tj !t@(FVar !i)+subst !j !tj t@(FVar !i)   | i == j                  = tj   | otherwise               = t @@ -1255,15 +1263,15 @@ -------------------------------------------------------------------------------- instantiate !t = go t   where-    go (FAbs !i !t) = do-      !t'    <- instantiate t+    go (FAbs !i !t') = do+      !t''    <- instantiate t'       !v     <- fresh-      return  $ subst i (FVar v) t'-    go !t =-      return t+      return  $ subst i (FVar v) t''+    go !t' =+      return t'  unifyVar :: Env -> Maybe Expr -> TVSubst -> Int -> Sort -> CheckM TVSubst-unifyVar _ _ θ !i !t@(FVar !j)+unifyVar _ _ θ !i t@(FVar !j)   = case lookupVar i θ of       Just !t'      -> if t == t' then return θ else return (updateVar j t' θ)       Nothing       -> return (updateVar i t θ)@@ -1288,8 +1296,8 @@ applyExpr Nothing e  = e applyExpr (Just θ) e = Vis.mapExprOnExpr f e   where-    f (ECst e s) = ECst e (apply θ s)-    f e          = e+    f (ECst e' s) = ECst e' (apply θ s)+    f e'          = e'  -------------------------------------------------------------------------------- _applyCoercion :: Symbol -> Sort -> Sort -> Sort@@ -1343,14 +1351,14 @@ errElabExpr e = printf "Elaborate fails on %s" (showpp e)  errUnifyMsg :: Maybe String -> Maybe Expr -> Sort -> Sort -> String-errUnifyMsg msgMb eo t1 t2 +errUnifyMsg msgMb eo t1 t2   = printf "Cannot unify %s with %s %s %s"       (showpp t1) {- (show t1) -} (showpp t2) {-(show t2)-} (errUnifyExpr eo) msgStr-    where -      msgStr = case msgMb of { Nothing -> ""; Just s -> "<< " ++ s ++ " >>"} +    where+      msgStr = case msgMb of { Nothing -> ""; Just s -> "<< " ++ s ++ " >>"}  errUnify :: Maybe Expr -> Sort -> Sort -> String-errUnify = errUnifyMsg Nothing +errUnify = errUnifyMsg Nothing  errUnifyExpr :: Maybe Expr -> String errUnifyExpr Nothing  = ""

− src/Language/Fixpoint/Types/Binary.hs

@@ -1,8 +0,0 @@--- | We need Binary instances as they are used to serialize specs in LH... ----module Language.Fixpoint.Types.Binary where--import qualified Data.Binary as B--import Language.Fixpoint.Types as F-

src/Language/Fixpoint/Types/Config.hs view

@@ -14,6 +14,10 @@   -- * SMT Solver options   , SMTSolver (..) +  -- REST Options+  , RESTOrdering (..)+  , restOC+   -- * Eliminate options   , Eliminate (..)   , useElim@@ -26,8 +30,11 @@   , queryFile ) where +import qualified Data.Store as S+import qualified Data.List as L import Data.Serialize                (Serialize (..)) import Control.Monad+import Control.DeepSeq import GHC.Generics import System.Console.CmdArgs import System.Console.CmdArgs.Explicit@@ -80,25 +87,28 @@   , minimizeQs  :: Bool                -- ^ min .fq by delta debug (sat with min qualifiers)   , minimizeKs  :: Bool                -- ^ min .fq by delta debug (sat with min kvars)   , minimalSol  :: Bool                -- ^ shrink final solution by pruning redundant qualfiers from fixpoint-  , etaElim     :: Bool                -- ^ eta eliminate function definitions +  , etaElim     :: Bool                -- ^ eta eliminate function definitions   , gradual     :: Bool                -- ^ solve "gradual" constraints   , ginteractive :: Bool                -- ^ interactive gradual solving   , autoKuts         :: Bool           -- ^ ignore given kut variables   , nonLinCuts       :: Bool           -- ^ Treat non-linear vars as cuts   , noslice          :: Bool           -- ^ Disable non-concrete KVar slicing   , rewriteAxioms    :: Bool           -- ^ Allow axiom instantiation via rewriting+  , pleWithUndecidedGuards :: Bool     -- ^ Unfold invocations with undecided guards in PLE+  , interpreter      :: Bool           -- ^ Do not use the interpreter to assist PLE   , oldPLE           :: Bool           -- ^ Use old version of PLE   , noIncrPle        :: Bool           -- ^ Use incremental PLE   , noEnvironmentReduction :: Bool     -- ^ Don't use environment reduction   , inlineANFBindings :: Bool          -- ^ Inline ANF bindings.                                        -- Sometimes improves performance and sometimes worsens it.-  , checkCstr        :: [Integer]      -- ^ Only check these specific constraints +  , checkCstr        :: [Integer]      -- ^ Only check these specific constraints   , extensionality   :: Bool           -- ^ Enable extensional interpretation of function equality   , rwTerminationCheck  :: Bool        -- ^ Enable termination checking for rewriting-  , stdin               :: Bool        -- ^ Read input query from stdin  +  , stdin               :: Bool        -- ^ Read input query from stdin   , json                :: Bool        -- ^ Render output in JSON format   , noLazyPLE           :: Bool   , fuel                :: Maybe Int   -- ^ Maximum PLE "fuel" (unfold depth) (default=infinite)+  , restOrdering        :: String      -- ^ Term ordering for use in REST   } deriving (Eq,Data,Typeable,Show,Generic)  instance Default Config where@@ -106,6 +116,29 @@  --------------------------------------------------------------------------------------- +data RESTOrdering = RESTKBO | RESTLPO | RESTRPO | RESTFuel Int+                 deriving (Eq, Data, Typeable, Generic)++instance Default RESTOrdering where+  def = RESTRPO++instance Show RESTOrdering where+  show RESTKBO      = "kbo"+  show RESTLPO      = "lpo"+  show RESTRPO      = "rpo"+  show (RESTFuel n) = "fuel" ++ show n++instance Read RESTOrdering where+  readsPrec _ s | "kbo" `L.isPrefixOf` s = [(RESTKBO, drop 3 s)]+  readsPrec _ s | "lbo" `L.isPrefixOf` s = [(RESTLPO, drop 3 s)]+  readsPrec _ s | "rpo" `L.isPrefixOf` s = [(RESTRPO, drop 3 s)]+  readsPrec n s | "fuel" `L.isPrefixOf` s = do+                        (fuel', rest) <- readsPrec n (drop 4 s)+                        return (RESTFuel fuel', rest)+  readsPrec _ _ = []++---------------------------------------------------------------------------------------+ data SMTSolver = Z3 | Cvc4 | Mathsat                  deriving (Eq, Data, Typeable, Generic) @@ -117,6 +150,8 @@   show Cvc4    = "cvc4"   show Mathsat = "mathsat" +instance S.Store SMTSolver+ --------------------------------------------------------------------------------------- -- | Eliminate describes the number of KVars to eliminate: --   None = use PA/Quals for ALL k-vars, i.e. no eliminate@@ -134,6 +169,9 @@   deriving (Eq, Data, Typeable, Generic)  instance Serialize Eliminate+instance S.Store Eliminate+instance NFData SMTSolver+instance NFData Eliminate  instance Default Eliminate where   def = None@@ -182,7 +220,16 @@   , autoKuts                 = False &= help "Ignore given Kut vars, compute from scratch"   , nonLinCuts               = False &= help "Treat non-linear kvars as cuts"   , noslice                  = False &= help "Disable non-concrete KVar slicing"-  , rewriteAxioms            = False &= help "allow axiom instantiation via rewriting"+  , rewriteAxioms            = False &= help "allow axiom instantiation via rewriting (PLE)"+  , pleWithUndecidedGuards   =+      False+        &= name "ple-with-undecided-guards"+        &= help "Unfold invocations with undecided guards in PLE"+        &= explicit+  , interpreter              =+      False+        &= name "interpreter"+        &= help "Use the interpreter to assist PLE"   , oldPLE                   = False &= help "Use old version of PLE"   , noIncrPle                = False &= help "Don't use incremental PLE"   , noEnvironmentReduction   =@@ -197,13 +244,16 @@           , "Sometimes improves performance and sometimes worsens it."           , "Disabled by --no-environment-reduction"           ])-  , checkCstr                = []    &= help "Only check these specific constraint-ids" +  , checkCstr                = []    &= help "Only check these specific constraint-ids"   , extensionality           = False &= help "Allow extensional interpretation of extensionality"-  , rwTerminationCheck       = False   &= help "Disable rewrite divergence checker"+  , rwTerminationCheck       = False   &= help "Enable rewrite divergence checker"   , stdin                    = False   &= help "Read input query from stdin"   , json                     = False   &= help "Render result in JSON"   , noLazyPLE                = False   &= help "Don't use lazy PLE"   , fuel                     = Nothing &= help "Maximum fuel (per-function unfoldings) for PLE"+  , restOrdering             = "rpo"+        &= name "rest-ordering"+        &= help "Ordering Constraint Algebra to use for REST"   }   &= verbosity   &= program "fixpoint"@@ -219,7 +269,7 @@ config = cmdArgsMode defConfig  getOpts :: IO Config-getOpts = do +getOpts = do   md <- cmdArgs defConfig   whenNormal (putStrLn banner)   return md@@ -227,6 +277,9 @@ banner :: String banner =  "\n\nLiquid-Fixpoint Copyright 2013-21 Regents of the University of California.\n"        ++ "All Rights Reserved.\n"++restOC :: Config -> RESTOrdering+restOC cfg = read (restOrdering cfg)  multicore :: Config -> Bool multicore cfg = cores cfg /= Just 1

src/Language/Fixpoint/Types/Constraints.hs view

@@ -12,6 +12,8 @@ {-# LANGUAGE GADTs                      #-} {-# LANGUAGE PatternGuards              #-} +{-# OPTIONS_GHC -Wno-name-shadowing     #-}+ -- | This module contains the top-level QUERY data types and elements, --   including (Horn) implication & well-formedness constraints and sets. module Language.Fixpoint.Types.Constraints (@@ -55,7 +57,7 @@   , qualifier   , mkQual   , remakeQual-  , mkQ +  , mkQ   , qualBinds    -- * Results@@ -90,10 +92,6 @@ import qualified Data.Store as S import           Data.Generics             (Data) import           Data.Aeson                hiding (Result)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif- import qualified Data.Set                  as Set import           Data.Typeable             (Typeable) import           Data.Hashable@@ -156,12 +154,12 @@   = errorstar "gwInfo"  updateWfCExpr :: (Expr -> Expr) -> WfC a -> WfC a-updateWfCExpr _ w@(WfC {})  = w-updateWfCExpr f w@(GWfC {}) = w{wexpr = f (wexpr w)}+updateWfCExpr _ w@WfC{}  = w+updateWfCExpr f w@GWfC{} = w{wexpr = f (wexpr w)}  isGWfc :: WfC a -> Bool-isGWfc (GWfC {}) = True-isGWfc (WfC  {}) = False+isGWfc GWfC{} = True+isGWfc WfC{}  = False  instance HasGradual (WfC a) where   isGradual = isGWfc@@ -188,7 +186,7 @@   }   deriving (Generic, Functor) -instance Loc a => Loc (SimpC a) where +instance Loc a => Loc (SimpC a) where   srcSpan = srcSpan . _cinfo  strengthenHyp :: SInfo a -> [(Integer, Expr)] -> SInfo a@@ -207,9 +205,9 @@ strengthenBinds :: SInfo a -> M.HashMap BindId Expr -> SInfo a strengthenBinds si m = si { bs = mapBindEnv f (bs si) }   where-    f i (x, sr)      = case M.lookup i m of-                         Nothing -> (x, sr)-                         Just e  -> (x, strengthenSortedReft sr e)+    f i (x, sr, l)   = case M.lookup i m of+                         Nothing -> (x, sr, l)+                         Just e  -> (x, strengthenSortedReft sr e, l)  strengthenSortedReft :: SortedReft -> Expr -> SortedReft strengthenSortedReft (RR s (Reft (v, r))) e = RR s (Reft (v, pAnd [r, e]))@@ -231,7 +229,7 @@   sid   :: c a -> Maybe Integer   stag  :: c a -> Tag   sinfo :: c a -> a-  clhs  :: BindEnv -> c a -> [(Symbol, SortedReft)]+  clhs  :: BindEnv a -> c a -> [(Symbol, SortedReft)]   crhs  :: c a -> Expr  instance TaggedC SimpC a where@@ -275,11 +273,11 @@ toGFixSol = GSol  -data Result a = Result +data Result a = Result   { resStatus    :: !(FixResult a)   , resSolution  :: !FixSolution   , resNonCutsSolution :: !FixSolution-  , gresSolution :: !GFixSolution +  , gresSolution :: !GFixSolution   }   deriving (Generic, Show, Functor) @@ -291,10 +289,10 @@ instance Semigroup (Result a) where   r1 <> r2  = Result stat soln nonCutsSoln gsoln     where-      stat  = (resStatus r1)    <> (resStatus r2)-      soln  = (resSolution r1)  <> (resSolution r2)+      stat  = resStatus r1    <> resStatus r2+      soln  = resSolution r1  <> resSolution r2       nonCutsSoln = resNonCutsSolution r1 <> resNonCutsSolution r2-      gsoln = (gresSolution r1) <> (gresSolution r2)+      gsoln = gresSolution r1 <> gresSolution r2  instance Monoid (Result a) where   mempty        = Result mempty mempty mempty mempty@@ -315,9 +313,9 @@ isUnsafe _ = False  instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a)) where-  toFix (Safe stats)     = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)" +  toFix (Safe stats)     = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)"   -- toFix (UnknownError d) = text $ "Unknown Error: " ++ d-  toFix (Crash xs msg)   = vcat $ [ text "Crash!" ] ++  pprSinfos "CRASH: " xs ++ [parens (text msg)]+  toFix (Crash xs msg)   = vcat $ [ text "Crash!" ] ++  pprSinfos "CRASH: " (fst <$> xs) ++ [parens (text msg)]   toFix (Unsafe _ xs)    = vcat $ text "Unsafe:" : pprSinfos "WARNING: " xs  pprSinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc]@@ -362,7 +360,7 @@               -- NOTE: this next line is printed this way for compatability with the OCAML solver               $+$ text "reft" <+> toFix (RR t (Reft (v, PKVar k mempty)))               $+$ toFixMeta (text "wf") (toFix (winfo w))-              $+$ if (isGWfc w) then (toFixMeta (text "expr") (toFix (wexpr w))) else mempty+              $+$ if isGWfc w then toFixMeta (text "expr") (toFix (wexpr w)) else mempty           (v, t, k) = wrft w  toFixMeta :: Doc -> Doc -> Doc@@ -390,8 +388,8 @@   show = showpp  -----------------------------------------------------------------instance S.Store QualPattern -instance S.Store QualParam +instance S.Store QualPattern+instance S.Store QualParam instance S.Store Qualifier instance S.Store Kuts instance S.Store HOInfo@@ -402,8 +400,8 @@ instance (S.Store a) => S.Store (SimpC a) instance (S.Store (c a), S.Store a) => S.Store (GInfo c a) -instance NFData QualPattern -instance NFData QualParam +instance NFData QualPattern+instance NFData QualParam instance NFData Qualifier instance NFData Kuts instance NFData HOInfo@@ -473,7 +471,7 @@  addIds :: [SubC a] -> [(Integer, SubC a)] addIds = zipWith (\i c -> (i, shiftId i $ c {_sid = Just i})) [1..]-  where +  where     -- Adding shiftId to have distinct VV for SMT conversion     shiftId i c = c { slhs = shiftSR i $ slhs c }                     { srhs = shiftSR i $ srhs c }@@ -483,7 +481,7 @@ -------------------------------------------------------------------------------- -- | Qualifiers ---------------------------------------------------------------- ---------------------------------------------------------------------------------data Qualifier = Q +data Qualifier = Q   { qName   :: !Symbol     -- ^ Name   , qParams :: [QualParam] -- ^ Parameters   , qBody   :: !Expr       -- ^ Predicate@@ -491,15 +489,15 @@   }   deriving (Eq, Ord, Show, Data, Typeable, Generic) -data QualParam = QP +data QualParam = QP   { qpSym  :: !Symbol-  , qpPat  :: !QualPattern +  , qpPat  :: !QualPattern   , qpSort :: !Sort-  } +  }   deriving (Eq, Ord, Show, Data, Typeable, Generic) -data QualPattern -  = PatNone                 -- ^ match everything +data QualPattern+  = PatNone                 -- ^ match everything   | PatPrefix !Symbol !Int  -- ^ str . $i  i.e. match prefix 'str' with suffix bound to $i   | PatSuffix !Int !Symbol  -- ^ $i . str  i.e. match suffix 'str' with prefix bound to $i   | PatExact  !Symbol       -- ^ str       i.e. exactly match 'str'@@ -513,31 +511,31 @@     where       l     = qPos q -instance Subable Qualifier where -  syms   = qualFreeSymbols +instance Subable Qualifier where+  syms   = qualFreeSymbols   subst  = mapQualBody . subst   substf = mapQualBody . substf   substa = mapQualBody . substa  mapQualBody :: (Expr -> Expr) -> Qualifier -> Qualifier mapQualBody f q = q { qBody = f (qBody q) }-  + qualFreeSymbols :: Qualifier -> [Symbol]-qualFreeSymbols q = filter (not . isPrim) xs +qualFreeSymbols q = filter (not . isPrim) xs   where-    xs            = syms (qBody q) L.\\ syms (qpSym <$> qParams q) +    xs            = syms (qBody q) L.\\ syms (qpSym <$> qParams q) -instance Fixpoint QualParam where -  toFix (QP x _ t) = toFix (x, t) +instance Fixpoint QualParam where+  toFix (QP x _ t) = toFix (x, t) -instance PPrint QualParam where -  pprintTidy k (QP x pat t) = pprintTidy k x <+> pprintTidy k pat <+> colon <+> pprintTidy k t +instance PPrint QualParam where+  pprintTidy k (QP x pat t) = pprintTidy k x <+> pprintTidy k pat <+> colon <+> pprintTidy k t -instance PPrint QualPattern where -  pprintTidy _ PatNone         = "" +instance PPrint QualPattern where+  pprintTidy _ PatNone         = ""   pprintTidy k (PatPrefix s i) = "as" <+> pprintTidy k s <+> ("$" <-> pprint i)-  pprintTidy k (PatSuffix s i) = "as" <+> ("$" <-> pprint i) <+> pprintTidy k s -  pprintTidy k (PatExact  s  ) = "~"  <+> pprintTidy k s +  pprintTidy k (PatSuffix s i) = "as" <+> ("$" <-> pprint i) <+> pprintTidy k s+  pprintTidy k (PatExact  s  ) = "~"  <+> pprintTidy k s  instance Fixpoint Qualifier where   toFix = pprQual@@ -556,7 +554,7 @@     xs  = L.delete v $ L.nub $ syms p     xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..] -mkQ :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier +mkQ :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier mkQ n = Q n . qualParams  qualParams :: [(Symbol, Sort)] -> [QualParam]@@ -579,13 +577,13 @@  -- | constructing qualifiers mkQual :: Symbol -> [QualParam] -> Expr -> SourcePos -> Qualifier-mkQual n qps p = Q n qps' p +mkQual n qps p = Q n qps' p   where     qps'       = zipWith (\qp t' -> qp { qpSort = t'}) qps ts'-    ts'        = gSorts (qpSort <$> qps) +    ts'        = gSorts (qpSort <$> qps)  gSorts :: [Sort] -> [Sort]-gSorts ts = substVars su <$> ts +gSorts ts = substVars su <$> ts   where     su    = (`zip` [0..]) . sortNub . concatMap sortVars $ ts @@ -631,7 +629,7 @@                deriving (Eq, Show, Generic)  instance Fixpoint Kuts where-  toFix (KS s) = vcat $ (("cut " <->) . toFix) <$> L.sort (S.toList s)+  toFix (KS s) = vcat $ ("cut " <->) . toFix <$> L.sort (S.toList s)  ksMember :: KVar -> Kuts -> Bool ksMember k (KS s) = S.member k s@@ -648,7 +646,7 @@ ------------------------------------------------------------------------ fi :: [SubC a]    -> [WfC a]-   -> BindEnv+   -> BindEnv a    -> SEnv Sort    -> SEnv Sort    -> Kuts@@ -659,7 +657,7 @@    -> [Triggered Expr]    -> AxiomEnv    -> [DataDecl]-   -> [BindId] +   -> [BindId]    -> GInfo SubC a fi cs ws binds ls ds ks qs bi aHO aHOq es axe adts ebs   = FI { cm       = M.fromList $ addIds cs@@ -674,7 +672,7 @@        , asserts  = es        , ae       = axe        , ddecls   = adts-       , ebinds   = ebs +       , ebinds   = ebs        }   where     --TODO handle duplicates gracefully instead (merge envs by intersect?)@@ -685,7 +683,7 @@ -- | Top-level Queries ------------------------------------------------------------------------ -data FInfoWithOpts a = FIO +data FInfoWithOpts a = FIO   { fioFI   :: FInfo a   , fioOpts :: [String]   }@@ -693,7 +691,7 @@ type FInfo a   = GInfo SubC a type SInfo a   = GInfo SimpC a -data HOInfo = HOI +data HOInfo = HOI   { hoBinds :: Bool          -- ^ Allow higher order binds in the environemnt   , hoQuals :: Bool          -- ^ Allow higher order quals   }@@ -703,10 +701,10 @@ allowHO      = hoBinds . hoInfo allowHOquals = hoQuals . hoInfo -data GInfo c a = FI +data GInfo c a = FI   { cm       :: !(M.HashMap SubcId (c a))  -- ^ cst id |-> Horn Constraint   , ws       :: !(M.HashMap KVar (WfC a))  -- ^ Kvar  |-> WfC defining its scope/args-  , bs       :: !BindEnv                   -- ^ Bind  |-> (Symbol, SortedReft)+  , bs       :: !(BindEnv a)               -- ^ Bind  |-> (Symbol, SortedReft)   , ebinds   :: ![BindId]                  -- ^ Subset of existential binders   , gLits    :: !(SEnv Sort)               -- ^ Global Constant symbols   , dLits    :: !(SEnv Sort)               -- ^ Distinct Constant symbols@@ -732,37 +730,37 @@   mempty        = HOI False False  instance Semigroup (GInfo c a) where-  i1 <> i2 = FI { cm       = (cm i1)       <> (cm i2)-                , ws       = (ws i1)       <> (ws i2)-                , bs       = (bs i1)       <> (bs i2)-                , ebinds   = (ebinds i1)   <> (ebinds i2)-                , gLits    = (gLits i1)    <> (gLits i2)-                , dLits    = (dLits i1)    <> (dLits i2)-                , kuts     = (kuts i1)     <> (kuts i2)-                , quals    = (quals i1)    <> (quals i2)-                , bindInfo = (bindInfo i1) <> (bindInfo i2)-                , ddecls   = (ddecls i1)   <> (ddecls i2)-                , hoInfo   = (hoInfo i1)   <> (hoInfo i2)-                , asserts  = (asserts i1)  <> (asserts i2)-                , ae       = (ae i1)       <> (ae i2)+  i1 <> i2 = FI { cm       = cm i1       <> cm i2+                , ws       = ws i1       <> ws i2+                , bs       = bs i1       <> bs i2+                , ebinds   = ebinds i1   <> ebinds i2+                , gLits    = gLits i1    <> gLits i2+                , dLits    = dLits i1    <> dLits i2+                , kuts     = kuts i1     <> kuts i2+                , quals    = quals i1    <> quals i2+                , bindInfo = bindInfo i1 <> bindInfo i2+                , ddecls   = ddecls i1   <> ddecls i2+                , hoInfo   = hoInfo i1   <> hoInfo i2+                , asserts  = asserts i1  <> asserts i2+                , ae       = ae i1       <> ae i2                 }   instance Monoid (GInfo c a) where   mempty        = FI { cm       = M.empty-                     , ws       = mempty -                     , bs       = mempty -                     , ebinds   = mempty -                     , gLits    = mempty -                     , dLits    = mempty -                     , kuts     = mempty -                     , quals    = mempty -                     , bindInfo = mempty -                     , ddecls   = mempty -                     , hoInfo   = mempty -                     , asserts  = mempty +                     , ws       = mempty+                     , bs       = mempty+                     , ebinds   = mempty+                     , gLits    = mempty+                     , dLits    = mempty+                     , kuts     = mempty+                     , quals    = mempty+                     , bindInfo = mempty+                     , ddecls   = mempty+                     , hoInfo   = mempty+                     , asserts  = mempty                      , ae       = mempty-                     } +                     }  instance PTable (SInfo a) where   ptable z = DocTable [ (text "# Sub Constraints", pprint $ length $ cm z)@@ -807,6 +805,7 @@       | mdata     = vcat     . map metaDoc . M.toList . bindInfo       | otherwise = \_ -> text "\n" +infixl 9 $++$ ($++$) :: Doc -> Doc -> Doc x $++$ y = x $+$ text "\n" $+$ y @@ -842,7 +841,7 @@   where     fi'           = fi { bs = be', cm = cm' }     m'            = M.insert i bId m-    (bId, be')    = insertBindEnv x sr $ bs fi+    (bId, be')    = insertBindEnv x sr (sinfo c) (bs fi)     cm'           = M.insert i c' $ cm fi     c'            = c { _senv = insertsIBindEnv [bId] $ senv c }     sr            = slhs c@@ -861,7 +860,7 @@  -- Assumes the sort and the bind of the lhs is the same as the sort -- and the bind of the rhs-simpcToSubc :: BindEnv -> SimpC a -> SubC a+simpcToSubc :: BindEnv a -> SimpC a -> SubC a simpcToSubc env s = SubC   { _senv  = deleteIBindEnv (cbind s) (senv s)   , slhs   = sr@@ -871,7 +870,7 @@   , _sinfo = sinfo s   }   where-    (b, sr) = lookupBindEnv (cbind s) env+    (b, sr, _) = lookupBindEnv (cbind s) env  --------------------------------------------------------------------------- -- | Top level Solvers ----------------------------------------------------@@ -879,7 +878,7 @@ type Solver a = Config -> FInfo a -> IO (Result (Integer, a))  ---------------------------------------------------------------------------------saveQuery :: Fixpoint a => Config -> FInfo a -> IO ()+saveQuery :: (Fixpoint a) => Config -> FInfo a -> IO () -------------------------------------------------------------------------------- saveQuery cfg fi = {- when (save cfg) $ -} do   let fi'  = void fi@@ -915,14 +914,10 @@ instance S.Store AxiomEnv instance S.Store Rewrite instance S.Store Equation-instance S.Store SMTSolver-instance S.Store Eliminate instance NFData AutoRewrite instance NFData AxiomEnv instance NFData Rewrite instance NFData Equation-instance NFData SMTSolver-instance NFData Eliminate  dedupAutoRewrites :: M.HashMap SubcId [AutoRewrite] -> [AutoRewrite] dedupAutoRewrites = Set.toList . Set.unions . map Set.fromList . M.elems@@ -930,10 +925,10 @@ instance Semigroup AxiomEnv where   a1 <> a2        = AEnv aenvEqs' aenvSimpl' aenvExpand' aenvAutoRW'     where-      aenvEqs'    = (aenvEqs a1)    <> (aenvEqs a2)-      aenvSimpl'  = (aenvSimpl a1)  <> (aenvSimpl a2)-      aenvExpand' = (aenvExpand a1) <> (aenvExpand a2)-      aenvAutoRW' = (aenvAutoRW a1) <> (aenvAutoRW a2)+      aenvEqs'    = aenvEqs a1    <> aenvEqs a2+      aenvSimpl'  = aenvSimpl a1  <> aenvSimpl a2+      aenvExpand' = aenvExpand a1 <> aenvExpand a2+      aenvAutoRW' = aenvAutoRW a1 <> aenvAutoRW a2  instance Monoid AxiomEnv where   mempty          = AEnv [] [] (M.fromList []) (M.fromList [])@@ -976,7 +971,6 @@   , arRHS  :: Expr } deriving (Eq, Ord, Show, Generic) -instance Hashable SortedReft instance Hashable AutoRewrite  @@ -991,6 +985,7 @@       fixRW rw@(AutoRewrite args lhs rhs) =           text ("autorewrite " ++ show (hash rw))           <+> hsep (map toFix args)+          <+> text "="           <+> text "{"           <+> toFix lhs           <+> text "="@@ -1022,9 +1017,6 @@       pairdoc (x,y) = text $ show x ++ " : " ++ show y       renderExpand [] = empty       renderExpand xs = text "expand" <+> toFix xs--instance Fixpoint Doc where-  toFix = id  instance Fixpoint Equation where   toFix (Equ f xs e s _) = "define" <+> toFix f <+> ppArgs xs <+> ":" <+> toFix s <+> text "=" <+> braces (parens (toFix e))

src/Language/Fixpoint/Types/Environments.hs view

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-}@@ -16,7 +14,8 @@ module Language.Fixpoint.Types.Environments (    -- * Environments-    SEnv, SESearch(..)+    SEnv(..)+  , SESearch(..)   , emptySEnv, toListSEnv, fromListSEnv, fromMapSEnv   , mapSEnvWithKey, mapSEnv, mapMSEnv   , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv, unionSEnv, unionSEnv'@@ -63,10 +62,6 @@ import qualified Data.Store as S import qualified Data.List   as L import           Data.Generics             (Data)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif- import           Data.Typeable             (Typeable) import           GHC.Generics              (Generic) import qualified Data.HashMap.Strict       as M@@ -101,15 +96,15 @@   pprintTidy k (BE _ m) = pprintTidy k m  -- Invariant: All BindIds in the map are less than beSize-type BindEnv       = SizedEnv (Symbol, SortedReft)-newtype EBindEnv   = EB BindEnv+type BindEnv a     = SizedEnv (Symbol, SortedReft, a)+newtype EBindEnv a = EB (BindEnv a) -splitByQuantifiers :: BindEnv -> [BindId] -> (BindEnv, EBindEnv)-splitByQuantifiers (BE i bs) ebs = ( BE i $ M.filterWithKey (\k _ -> not (elem k ebs)) bs+splitByQuantifiers :: BindEnv a -> [BindId] -> (BindEnv a, EBindEnv a)+splitByQuantifiers (BE i bs) ebs = ( BE i $ M.filterWithKey (\k _ -> notElem k ebs) bs                                    , EB $ BE i $ M.filterWithKey (\k _ -> elem k ebs) bs                                    ) --- data SolEnv        = SolEnv { soeBinds :: !BindEnv } +-- data SolEnv        = SolEnv { soeBinds :: !BindEnv } --                     deriving (Eq, Show, Generic)  instance PPrint a => PPrint (SEnv a) where@@ -173,7 +168,7 @@      Nothing -> Alts $ symbol <$> alts   where     alts       = takeMin $ zip (editDistance x' <$> ss) ss-    ss         = symbolString <$> fst <$> M.toList env+    ss         = symbolString . fst <$> M.toList env     x'         = symbolString x     takeMin xs = [z | (d, z) <- xs, d == getMin xs]     getMin     = minimum . (fst <$>)@@ -209,41 +204,46 @@ fromListIBindEnv = FB . S.fromList  -- | Functions for Global Binder Environment-insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv)-insertBindEnv x r (BE n m) = (n, BE (n + 1) (M.insert n (x, r) m))+insertBindEnv :: Symbol -> SortedReft -> a -> BindEnv a -> (BindId, BindEnv a)+insertBindEnv x r a (BE n m) = (n, BE (n + 1) (M.insert n (x, r, a) m)) -fromListBindEnv :: [(BindId, (Symbol, SortedReft))] -> BindEnv+fromListBindEnv :: [(BindId, (Symbol, SortedReft, a))] -> BindEnv a fromListBindEnv xs = BE (length xs) (M.fromList xs) -emptyBindEnv :: BindEnv+emptyBindEnv :: BindEnv a emptyBindEnv = BE 0 M.empty -filterBindEnv   :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv -> BindEnv-filterBindEnv f (BE n be) = BE n (M.filterWithKey (\ n (x, r) -> f n x r) be)+filterBindEnv   :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv a -> BindEnv a+filterBindEnv f (BE n be) = BE n (M.filterWithKey (\ n' (x, r, _) -> f n' x r) be) -bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv+bindEnvFromList :: [(BindId, (Symbol, SortedReft, a))] -> BindEnv a bindEnvFromList [] = emptyBindEnv bindEnvFromList bs = BE (1 + maxId) be   where-    maxId          = maximum $ fst3 <$> bs-    be             = M.fromList [(n, (x, r)) | (n, x, r) <- bs]+    maxId          = maximum [ n | (n,(_,_,_)) <- bs ]+    be             = M.fromList bs -elemsBindEnv :: BindEnv -> [BindId]-elemsBindEnv be = fst3 <$> bindEnvToList be+elemsBindEnv :: BindEnv a -> [BindId]+elemsBindEnv be = fst <$> bindEnvToList be -bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)]-bindEnvToList (BE _ be) = [(n, x, r) | (n, (x, r)) <- M.toList be]+bindEnvToList :: BindEnv a -> [(BindId, (Symbol, SortedReft, a))]+bindEnvToList (BE _ be) = M.toList be -mapBindEnv :: (BindId -> (Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv-mapBindEnv f (BE n m) = BE n $ M.mapWithKey f m+mapBindEnv :: (BindId -> (Symbol, SortedReft, a) -> (Symbol, SortedReft, a)) -> BindEnv a -> BindEnv a+mapBindEnv f (BE n m) = BE n (M.mapWithKey f m)+  -- where+    -- f' k (x, y, a) = let (x', y') = f k (x, y) in (x', y', a)+ -- (\i z -> tracepp (msg i z) $ f z) m --  where --    msg i z = "beMap " ++ show i ++ " " ++ show z -mapWithKeyMBindEnv :: (Monad m) => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv -> m BindEnv-mapWithKeyMBindEnv f (BE n m) = (BE n . M.fromList) <$> mapM f (M.toList m)+mapWithKeyMBindEnv :: (Monad m) => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv a -> m (BindEnv a)+mapWithKeyMBindEnv f (BE n m) = BE n . M.fromList <$> mapM f' (M.toList m)+  where+    f' (k, (x, y, a)) = do { (k', (x', y')) <- f (k, (x, y)) ; return (k', (x', y', a)) } -lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft)+lookupBindEnv :: BindId -> BindEnv a -> (Symbol, SortedReft, a) lookupBindEnv k (BE _ m) = fromMaybe err (M.lookup k m)   where     err                  = errorstar $ "lookupBindEnv: cannot find binder" ++ show k@@ -266,24 +266,27 @@ diffIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv diffIBindEnv (FB m1) (FB m2) = FB $ m1 `S.difference` m2 -adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv-adjustBindEnv f i (BE n m) = BE n $ M.adjust f i m+adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv a -> BindEnv a+adjustBindEnv f i (BE n m) = BE n (M.adjust f' i m)+  where+    f'  (x, y, a) = let (x', y') = f (x, y) in (x', y', a) -deleteBindEnv :: BindId -> BindEnv -> BindEnv++deleteBindEnv :: BindId -> BindEnv a -> BindEnv a deleteBindEnv i (BE n m) = BE n $ M.delete i m  instance Functor SEnv where   fmap = mapSEnv -instance Fixpoint EBindEnv where+instance Fixpoint (EBindEnv a) where   toFix (EB (BE _ m)) = vcat $ map toFixBind $ hashMapToAscList m     where-      toFixBind (i, (x, r)) = "ebind" <+> toFix i <+> toFix x <+> ": { " <+> toFix (sr_sort r) <+> " }"+      toFixBind (i, (x, r, _)) = "ebind" <+> toFix i <+> toFix x <+> ": { " <+> toFix (sr_sort r) <+> " }" -instance Fixpoint BindEnv where+instance Fixpoint (BindEnv a) where   toFix (BE _ m) = vcat $ map toFixBind $ hashMapToAscList m     where-      toFixBind (i, (x, r)) = "bind" <+> toFix i <+> toFix x <+> ":" <+> toFix r+      toFixBind (i, (x, r, _)) = "bind" <+> toFix i <+> toFix x <+> ":" <+> toFix r  instance (Fixpoint a) => Fixpoint (SEnv a) where    toFix (SE m)   = toFix (hashMapToAscList m)@@ -297,31 +300,31 @@ instance Monoid (SEnv a) where   mempty        = SE M.empty -instance Semigroup BindEnv where+instance Semigroup (BindEnv a) where   (BE 0 _) <> b        = b   b        <> (BE 0 _) = b   _        <> _        = errorstar "mappend on non-trivial BindEnvs" -instance Monoid BindEnv where+instance Monoid (BindEnv a) where   mempty  = BE 0 M.empty   mappend = (<>) -envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)]-envCs be env = [lookupBindEnv i be | i <- elemsIBindEnv env]+envCs :: BindEnv a -> IBindEnv -> [(Symbol, SortedReft)]+envCs be env = [(x, y) | i <- elemsIBindEnv env, let (x, y, _) = lookupBindEnv i be] -instance Fixpoint (IBindEnv) where+instance Fixpoint IBindEnv where   toFix (FB ids) = text "env" <+> toFix ids  --------------------------------------------------------------------------------  instance NFData Packs instance NFData IBindEnv-instance NFData BindEnv+instance NFData a => NFData (BindEnv a) instance (NFData a) => NFData (SEnv a)  instance S.Store Packs instance S.Store IBindEnv-instance S.Store BindEnv+instance (S.Store a) => S.Store (BindEnv a) instance (S.Store a) => S.Store (SEnv a) -- instance (Hashable a, Eq a, S.Store a) => S.Store (S.HashSet a) where --   put = B.put . S.toList@@ -335,7 +338,7 @@                deriving (Eq, Show, Generic)  instance Fixpoint Packs where-  toFix (Packs m) = vcat $ (("pack" <+>) . toFix) <$> kIs+  toFix (Packs m) = vcat $ ("pack" <+>) . toFix <$> kIs     where       kIs = L.sortBy (compare `on` snd) . M.toList $ m

src/Language/Fixpoint/Types/Errors.hs view

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP                       #-} {-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE DeriveGeneric             #-}-{-# LANGUAGE DeriveFoldable            #-} {-# LANGUAGE DeriveTraversable         #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -10,7 +9,7 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE ViewPatterns              #-} -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Language.Fixpoint.Types.Errors (   -- * Concrete Location Type@@ -59,10 +58,6 @@ import           Data.Aeson                    hiding (Error, Result) import           Data.Generics                 (Data) import           Data.Typeable-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup                (Semigroup (..))-#endif- import           Control.DeepSeq -- import           Data.Hashable import qualified Data.Store                   as S@@ -102,7 +97,7 @@   errs :: Error -> [Error1]-errs (Error es) = es +errs (Error es) = es  data Error1 = Error1   { errLoc :: SrcSpan@@ -123,7 +118,7 @@   toFix = pprint  instance Exception Error-instance Exception (FixResult Error)+-- instance Exception (FixResult Error)   ---------------------------------------------------------------------@@ -172,19 +167,20 @@ -- | Result --------------------------------------------------------- --------------------------------------------------------------------- -data FixResult a = Crash [a] String-                 | Safe Solver.Stats+data FixResult a+  = Crash [(a, Maybe String)] String+  | Unsafe Solver.Stats ![a]+  | Safe Solver.Stats                  -- ^ The 'Solver' statistics, which include also the constraints /actually/                  -- checked. A program will be \"trivially safe\" in case this                  -- number is 0.-                 | Unsafe Solver.Stats ![a]-                   deriving (Data, Typeable, Foldable, Traversable, Show, Generic)+  deriving (Data, Typeable, Foldable, Functor, Traversable, Show, Generic)  instance (NFData a) => NFData (FixResult a)  instance Eq a => Eq (FixResult a) where   Crash xs _   == Crash ys _         = xs == ys-  Unsafe s1 xs == Unsafe s2 ys       = xs == ys && s1 == s2 +  Unsafe s1 xs == Unsafe s2 ys       = xs == ys && s1 == s2   Safe s1      == Safe s2            = s1 == s2   _            == _                  = False @@ -192,38 +188,27 @@   Safe s1        <> Safe s2        = Safe (s1 <> s2)   Safe _         <> x              = x   x              <> Safe _         = x-  _              <> c@(Crash{})    = c-  c@(Crash{})    <> _              = c+  _              <> c@Crash{}      = c+  c@Crash{}      <> _              = c   (Unsafe s1 xs) <> (Unsafe s2 ys) = Unsafe (s1 <> s2) (xs ++ ys)  instance Monoid (FixResult a) where   mempty  = Safe mempty   mappend = (<>) -instance Functor FixResult where-  fmap f (Crash xs msg)   = Crash (f <$> xs) msg-  fmap f (Unsafe s xs)    = Unsafe s (f <$> xs)-  fmap _ (Safe stats)     = Safe stats---- instance (ToJSON a) => ToJSON (FixResult a) where---   toJSON (Safe _ )      = object [ "result"  .= String "safe"   ]----   toJSON (Unsafe _ ts)  = object [ "result"  .= String "unsafe" ---                                  , "tags"    .= toJSON ts---                                  ]---   toJSON (Crash ts msg) = object [ "result"  .= String "crash"---                                  , "message" .= msg ---                                  , "tags"    .= toJSON ts---                                  ]+-- instance Functor FixResult where+--   fmap f (Crash xs msg)   = Crash (f <$> xs) msg+--   fmap f (Unsafe s xs)    = Unsafe s (f <$> xs)+--   fmap _ (Safe stats)     = Safe stats  instance (ToJSON a) => ToJSON (FixResult a) where   toJSON = genericToJSON defaultOptions   toEncoding = genericToEncoding defaultOptions  resultDoc :: (Fixpoint a) => FixResult a -> Doc-resultDoc (Safe stats)     = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)" -resultDoc (Crash xs msg)   = vcat $ text ("Crash!: " ++ msg) : ((("CRASH:" <+>) . toFix) <$> xs)-resultDoc (Unsafe _ xs)    = vcat $ text "Unsafe:"           : ((("WARNING:" <+>) . toFix) <$> xs)+resultDoc (Safe stats)     = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)"+resultDoc (Crash xs msg)   = vcat $ text ("Crash!: " ++ msg) : (("CRASH:" <+>) . toFix . fst <$> xs)+resultDoc (Unsafe _ xs)    = vcat $ text "Unsafe:"           : (("WARNING:" <+>) . toFix <$> xs)  instance (Fixpoint a) => PPrint (FixResult a) where   pprintTidy _ = resultDoc

src/Language/Fixpoint/Types/Graduals.hs view

@@ -5,13 +5,11 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeOperators              #-} {-# LANGUAGE GADTs                      #-}-{-# LANGUAGE PatternGuards              #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE TupleSections              #-} +{-# OPTIONS_GHC -Wno-name-shadowing     #-}+ -- | This module contains the top-level SOLUTION data types, --   including various indices used for solving. @@ -44,10 +42,6 @@  import Control.Monad.State.Lazy import Data.Maybe (fromMaybe)-#if !MIN_VERSION_base(4,14,0)-import Data.Semigroup (Semigroup (..))-#endif- import qualified Language.Fixpoint.SortCheck       as So import Language.Fixpoint.Solver.Sanitize (symbolEnv) @@ -84,7 +78,7 @@ ------------------------------------------------------------------------------- -- |  Make each gradual appearence unique ------------------------------------- --------------------------------------------------------------------------------uniquify :: (NFData a, Fixpoint a, Loc a) => SInfo a -> (SInfo a)+uniquify :: (NFData a, Fixpoint a, Loc a) => SInfo a -> SInfo a  uniquify fi = fi{cm = cm', ws = ws', bs = bs'}   where@@ -92,54 +86,52 @@   ws'            = expandWF km (ws fi)  uniquifyCS :: (NFData a, Fixpoint a, Loc a)-           => BindEnv+           => BindEnv a            -> M.HashMap SubcId (SimpC a)-           -> (M.HashMap SubcId (SimpC a), M.HashMap KVar [(KVar, Maybe SrcSpan)], BindEnv)+           -> (M.HashMap SubcId (SimpC a), M.HashMap KVar [(KVar, Maybe SrcSpan)], BindEnv a) uniquifyCS bs cs   = (x, km, benv st)---   = (x, km, mapBindEnv (\i (x,r) -> if i `elem` ubs st then (x, ungrad r) else (x, r)) $ benv st)   where     (x, st) = runState (uniq cs) (initUniqueST bs)     km      = kmap st-    -- gs      = [x | xs <- M.elems km, (x,_) <- xs]  -class Unique a where-   uniq :: a -> UniqueM a+class Unique ann a where+   uniq :: a -> UniqueM ann a -instance Unique a => Unique (M.HashMap SubcId a) where+instance Unique ann a => Unique ann (M.HashMap SubcId a) where   uniq m = M.fromList <$> mapM (\(i,x) -> (i,) <$> uniq x) (M.toList m) -instance Loc a => Unique (SimpC a) where+instance Loc a => Unique a (SimpC a) where   uniq cs = do     updateLoc $ srcSpan $ _cinfo cs     rhs <- uniq (_crhs cs)     env <- uniq (_cenv cs)     return cs{_crhs = rhs, _cenv = env} -instance Unique IBindEnv where+instance Unique ann IBindEnv where   uniq env = withCache (fromListIBindEnv <$> mapM uniq (elemsIBindEnv env)) -instance Unique BindId where+instance Unique ann BindId where   uniq i = do     bs <- benv <$> get-    let (x, t) = lookupBindEnv i bs+    let (x, t, ann) = lookupBindEnv i bs     resetChange     t' <- uniq t     hasChanged <- change <$> get     if hasChanged-      then do let (i', bs') = insertBindEnv x t' bs+      then do let (i', bs') = insertBindEnv x t' ann bs               updateBEnv i bs'               return i'       else return i -instance Unique SortedReft where+instance Unique ann SortedReft where   uniq (RR s r) = RR s <$> uniq r -instance Unique Reft where-  uniq (Reft (x,e)) = (Reft . (x,)) <$> uniq e+instance Unique ann Reft where+  uniq (Reft (x,e)) = Reft . (x,) <$> uniq e -instance Unique Expr where+instance Unique ann Expr where   uniq = mapMExpr go    where     go (PGrad k su i e) = do@@ -152,46 +144,46 @@ -- | The Unique Monad --------------------------------------------------------- ------------------------------------------------------------------------------- -type UniqueM = State UniqueST-data UniqueST+type UniqueM ann = State (UniqueST ann)+data UniqueST a   = UniqueST { freshId :: Integer              , kmap    :: M.HashMap KVar [(KVar, Maybe SrcSpan)]              , change  :: Bool              , cache   :: M.HashMap KVar KVar              , uloc    :: Maybe SrcSpan              , ubs     :: [BindId]-             , benv    :: BindEnv+             , benv    :: BindEnv a              } -updateLoc :: SrcSpan -> UniqueM ()+updateLoc :: SrcSpan -> UniqueM ann () updateLoc x = modify $ \s -> s{uloc = Just x} -withCache :: UniqueM a -> UniqueM a+withCache :: UniqueM ann a -> UniqueM ann a withCache act = do   emptyCache   a <- act   emptyCache   return a -emptyCache :: UniqueM ()+emptyCache :: UniqueM ann () emptyCache = modify $ \s -> s{cache = mempty} -addCache :: KVar -> KVar -> UniqueM ()+addCache :: KVar -> KVar -> UniqueM ann () addCache k k' = modify $ \s -> s{cache = M.insert k k' (cache s)} -updateBEnv :: BindId -> BindEnv -> UniqueM ()-updateBEnv i bs = modify $ \s -> s{benv = bs, ubs = i:(ubs s)}+updateBEnv :: BindId -> BindEnv a -> UniqueM a ()+updateBEnv i bs = modify $ \s -> s{benv = bs, ubs = i : ubs s} -setChange :: UniqueM ()+setChange :: UniqueM ann () setChange = modify $ \s -> s{change = True} -resetChange :: UniqueM ()+resetChange :: UniqueM ann () resetChange = modify $ \s -> s{change = False} -initUniqueST :: BindEnv ->  UniqueST+initUniqueST :: BindEnv a ->  UniqueST a initUniqueST = UniqueST 0 mempty False mempty Nothing mempty -freshK, freshK' :: KVar -> UniqueM KVar+freshK, freshK' :: KVar -> UniqueM ann KVar freshK k  = do   setChange   cached <- cache <$> get@@ -202,15 +194,15 @@  freshK' k = do   i <- freshId <$> get-  modify $ (\s -> s{freshId = i + 1})+  modify (\s -> s{freshId = i + 1})   let k' = KV $ gradIntSymbol i   addK k k'   addCache k k'   return k' -addK :: KVar -> KVar -> UniqueM ()+addK :: KVar -> KVar -> UniqueM ann () addK key val =-  modify $ (\s -> s{kmap = M.insertWith (++) key [(val, uloc s)] (kmap s)})+  modify (\s -> s{kmap = M.insertWith (++) key [(val, uloc s)] (kmap s)})  ------------------------------------------------------------------------------- -- | expandWF -----------------------------------------------------------------@@ -221,16 +213,18 @@          -> M.HashMap KVar (WfC a)          -> M.HashMap KVar (WfC a) expandWF km ws-  = M.fromList $+  = M.fromList        ([(k, updateKVar k src w) | (i, w) <- gws, (kw, ks) <- km', kw == i, (k, src) <- ks]         ++ kws)   where     (gws, kws)       = L.partition (isGWfc . snd) $ M.toList ws     km'              = M.toList km-    updateKVar k src wfc = wfc { wrft = (\(v,s,_) -> (v,s,k)) $ wrft wfc-                               , wloc = (wloc wfc){gused = src}-                               } +    updateKVar k src wfc = let wrft' = (\(v,s,_) -> (v,s,k)) $ wrft wfc in+      case wfc of+        GWfC{} -> wfc { wrft = wrft', wloc = (wloc wfc){gused = src} }+        WfC{}  -> wfc { wrft = wrft' }+ ------------------------------------------------------------------------------- -- |  Substitute Gradual Solution --------------------------------------------- -------------------------------------------------------------------------------@@ -253,8 +247,8 @@ instance Gradual (SimpC a) where   gsubst su c = c {_crhs = gsubst su (_crhs c)} -instance Gradual BindEnv where-  gsubst su = mapBindEnv (\_ (x, r) -> (x, gsubst su r))+instance Gradual (BindEnv a) where+  gsubst su = mapBindEnv (\_ (x, r, l) -> (x, gsubst su r, l))  instance Gradual v => Gradual (M.HashMap k v) where   gsubst su = M.map (gsubst su)

src/Language/Fixpoint/Types/Names.hs view

@@ -5,12 +5,11 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE ViewPatterns               #-}-{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE PatternGuards              #-} +{-# OPTIONS_GHC -Wno-orphans            #-}  -- | This module contains Haskell variables representing globally visible names. --   Rather than have strings floating around the system, all constant names@@ -43,12 +42,13 @@   -- , isCtorSymbol   , isNontrivialVV   , isDummy+  , isFixKey    -- * Destructors   , prefixOfSym   , suffixOfSym   , stripPrefix-  , stripSuffix +  , stripSuffix   , consSym   , unconsSym   , dropSym@@ -82,7 +82,7 @@   , kArgSymbol   , existSymbol   , suffixSymbol-  , mappendSym +  , mappendSym    -- * Unwrapping Symbols   , unLitSymbol@@ -130,9 +130,6 @@ import           Control.Arrow               (second) import           Data.Char                   (ord) import           Data.Maybe                  (fromMaybe)-#if !MIN_VERSION_base(4,14,0)-import           Data.Monoid                 ((<>))-#endif import           Data.Generics               (Data) import           Data.Hashable               (Hashable (..)) import qualified Data.HashSet                as S hiding (size)@@ -329,10 +326,7 @@ isUnsafeChar :: Char -> Bool isUnsafeChar c =   let ic = ord c-   in if ic < Arr.numElements okSymChars then-        not (okSymChars Arr.! ic)-      else-        True+   in ic >= Arr.numElements okSymChars || not (okSymChars Arr.! ic)  keywords :: S.HashSet T.Text keywords   = S.fromList [ "env"@@ -434,7 +428,7 @@ vv Nothing          = vvName  isNontrivialVV      :: Symbol -> Bool-isNontrivialVV      = not . (vv Nothing ==)+isNontrivialVV      = (vv Nothing /=)  vvCon, dummySymbol :: Symbol vvCon       = vvName `suffixSymbol` "F"@@ -555,7 +549,7 @@ buildMany :: [Builder.Builder] -> Builder.Builder buildMany []     = mempty buildMany [b]    = b-buildMany (b:bs) = b <> mconcat [ " " <> b | b <- bs ]+buildMany (b:bs) = b <> mconcat [ " " <> b' | b' <- bs ]  ---------------------------------------------------------------------------- --------------- Global Name Definitions ------------------------------------@@ -640,11 +634,11 @@ mulFuncName  = "Z3_OP_MUL" divFuncName  = "Z3_OP_DIV" -isPrim :: Symbol -> Bool -isPrim x = S.member x prims +isPrim :: Symbol -> Bool+isPrim x = S.member x prims  prims :: S.HashSet Symbol-prims = S.fromList +prims = S.fromList   [ propConName   , _hpropConName   , vvName

src/Language/Fixpoint/Types/PrettyPrint.hs view

@@ -13,10 +13,6 @@ import qualified Data.List           as L import           Language.Fixpoint.Misc import           Data.Hashable-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup (Semigroup (..))-#endif- import qualified Data.Text as T  traceFix     ::  (Fixpoint a) => String -> a -> a@@ -100,7 +96,7 @@ instance PPrint Doc where   pprintTidy _ = id -instance (PPrint a, PPrint b) => PPrint (Either a b) where +instance (PPrint a, PPrint b) => PPrint (Either a b) where   pprintTidy k (Left  a) = "Left"  <+> pprintTidy k a   pprintTidy k (Right b) = "Right" <+> pprintTidy k b

@@ -1,8 +1,5 @@ {-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -13,9 +10,11 @@ {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE GADTs                      #-}-{-# LANGUAGE PatternGuards              #-} {-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE ViewPatterns               #-} +{-# OPTIONS_GHC -Wno-orphans            #-}+ -- | This module has the types for representing terms in the refinement logic.  module Language.Fixpoint.Types.Refinements (@@ -72,18 +71,21 @@   , isNonTrivial   , isContraPred   , isTautoPred-  , isSingletonExpr +  , isSingletonExpr   , isSingletonReft   , isFalse    -- * Destructing   , flattenRefas   , conjuncts+  , dropECst   , eApps   , eAppC+  , eCst   , exprKVars   , exprSymbolsSet   , splitEApp+  , splitEAppThroughECst   , splitPAnd   , reftConjuncts   , sortedReftSymbols@@ -134,7 +136,6 @@   instance NFData KVar-instance NFData SrcSpan instance NFData Subst instance NFData GradInfo instance NFData Constant@@ -149,8 +150,6 @@   -- put = B.put . M.toList   -- get = M.fromList <$> B.get -instance (Eq a, Hashable a, S.Store a) => S.Store (TCEmb a) -instance S.Store SrcSpan instance S.Store KVar instance S.Store Subst instance S.Store GradInfo@@ -165,7 +164,6 @@ instance B.Binary SymConst instance B.Binary Constant instance B.Binary Bop-instance B.Binary SrcSpan instance B.Binary GradInfo instance B.Binary Brel instance B.Binary KVar@@ -176,17 +174,15 @@   put = B.put . M.toList   get = M.fromList <$> B.get -instance B.Binary Subst +instance B.Binary Subst instance B.Binary Expr-instance B.Binary Reft -instance B.Binary TCArgs-instance (Eq a, Hashable a, B.Binary a) => B.Binary (TCEmb a)+instance B.Binary Reft   reftConjuncts :: Reft -> [Reft] reftConjuncts (Reft (v, ra)) = [Reft (v, ra') | ra' <- ras']   where-    ras'                     = if null ps then ks else ((conj ps) : ks)  -- see [NOTE:pAnd-SLOW]+    ras'                     = if null ps then ks else conj ps : ks  -- see [NOTE:pAnd-SLOW]     (ks, ps)                 = partition (\p -> isKvar p || isGradual p) $ refaConjuncts ra  @@ -198,12 +194,12 @@ class HasGradual a where   isGradual :: a -> Bool   gVars     :: a -> [KVar]-  gVars _ = [] +  gVars _ = []   ungrad    :: a -> a-  ungrad x = x +  ungrad x = x  instance HasGradual Expr where-  isGradual (PGrad {}) = True+  isGradual PGrad{} = True   isGradual (PAnd xs)  = any isGradual xs   isGradual _          = False @@ -211,7 +207,7 @@   gVars (PAnd xs)       = concatMap gVars xs   gVars _               = [] -  ungrad (PGrad {}) = PTrue+  ungrad PGrad{} = PTrue   ungrad (PAnd xs)  = PAnd (ungrad <$> xs )   ungrad e          = e @@ -247,9 +243,9 @@ instance Hashable Bop instance Hashable SymConst instance Hashable Constant-instance Hashable GradInfo -instance Hashable Subst -instance Hashable Expr +instance Hashable GradInfo+instance Hashable Subst+instance Hashable Expr instance Hashable Reft  --------------------------------------------------------------------------------@@ -285,8 +281,8 @@  -- | Uninterpreted constants that are embedded as  "constant symbol : Str" -data SymConst = SL !Text-              deriving (Eq, Ord, Show, Data, Typeable, Generic)+newtype SymConst = SL Text+                   deriving (Eq, Ord, Show, Data, Typeable, Generic)  data Constant = I !Integer               | R !Double@@ -321,7 +317,7 @@           | PAll   ![(Symbol, Sort)] !Expr           | PExist ![(Symbol, Sort)] !Expr           | PGrad  !KVar !Subst !GradInfo !Expr-          | ECoerc !Sort !Sort !Expr  +          | ECoerc !Sort !Sort !Expr           deriving (Eq, Show, Ord, Data, Typeable, Generic)  onEverySubexpr :: (Expr -> Expr) -> Expr -> Expr@@ -440,13 +436,28 @@     go acc (EApp f e) = go (e:acc) f     go acc e          = (e, acc) +splitEAppThroughECst :: Expr -> (Expr, [Expr])+splitEAppThroughECst = go []+  where+    go acc (dropECst -> (EApp f e)) = go (e:acc) f+    go acc e          = (e, acc)++dropECst :: Expr -> Expr+dropECst e = case e of+  ECst e' _ -> dropECst e'+  _ -> e+ splitPAnd :: Expr -> [Expr] splitPAnd (PAnd es) = concatMap splitPAnd es splitPAnd e         = [e]  eAppC :: Sort -> Expr -> Expr -> Expr-eAppC s e1 e2 = ECst (EApp e1 e2) s+eAppC s e1 e2 = eCst (EApp e1 e2) s +-- | Eliminates redundant casts+eCst :: Expr -> Sort -> Expr+eCst e t = ECst (dropECst e) t+ -------------------------------------------------------------------------------- debruijnIndex :: Expr -> Int debruijnIndex = go@@ -462,8 +473,8 @@     go (EIte e e1 e2)  = go e + go e1 + go e2     go (ETAbs e _)     = go e     go (ETApp e _)     = go e-    go (PAnd es)       = foldl (\n e -> n + go e) 0 es-    go (POr es)        = foldl (\n e -> n + go e) 0 es+    go (PAnd es)       = foldl' (\n e -> n + go e) 0 es+    go (POr es)        = foldl' (\n e -> n + go e) 0 es     go (PNot e)        = go e     go (PImp e1 e2)    = go e1 + go e2     go (PIff e1 e2)    = go e1 + go e2@@ -482,6 +493,8 @@ data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft }                   deriving (Eq, Ord, Data, Typeable, Generic) +instance Hashable SortedReft+ sortedReftSymbols :: SortedReft -> HashSet Symbol sortedReftSymbols sr =   HashSet.union@@ -669,12 +682,6 @@ instance PPrint Bop where   pprintTidy _  = toFix -instance PPrint Sort where-  pprintTidy _ = toFix--instance PPrint a => PPrint (TCEmb a) where -  pprintTidy k = pprintTidy k . tceToList - instance PPrint KVar where   pprintTidy _ (KV x) = text "$" <-> pprint x @@ -737,7 +744,7 @@     where zi = 1    -- RJ: DO NOT DELETE!-  pprintPrec _ k (ECst e so)     = parens $ pprint e <+> ":" <+> {- const (text "...") -} (pprintTidy k so)+  pprintPrec _ k (ECst e so)     = parens $ pprint e <+> ":" <+> {- const (text "...") -} pprintTidy k so   -- pprintPrec z k (ECst e _)      = pprintPrec z k e   pprintPrec _ _ PTrue           = trueD   pprintPrec _ _ PFalse          = falseD@@ -745,14 +752,14 @@                                    "not" <+> pprintPrec (zn+1) k p     where zn = 8   pprintPrec z k (PImp p1 p2)    = parensIf (z > zi) $-                                   (pprintPrec (zi+1) k p1) <+>+                                   pprintPrec (zi+1) k p1 <+>                                    "=>"                     <+>-                                   (pprintPrec (zi+1) k p2)+                                   pprintPrec (zi+1) k p2     where zi = 2   pprintPrec z k (PIff p1 p2)    = parensIf (z > zi) $-                                   (pprintPrec (zi+1) k p1) <+>+                                   pprintPrec (zi+1) k p1 <+>                                    "<=>"                    <+>-                                   (pprintPrec (zi+1) k p2)+                                   pprintPrec (zi+1) k p2     where zi = 2   pprintPrec z k (PAnd ps)       = parensIf (z > za) $                                    pprintBin (za + 1) k trueD andD ps@@ -769,7 +776,7 @@   pprintPrec _ k (PExist xts p)  = pprintQuant k "exists" xts p   pprintPrec _ k (ELam (x,t) e)  = "lam" <+> toFix x <+> ":" <+> toFix t <+> text "." <+> pprintTidy k e   pprintPrec _ k (ECoerc a t e)  = parens $ "coerce" <+> toFix a <+> "~" <+> toFix t <+> text "in" <+> pprintTidy k e-  pprintPrec _ _ p@(PKVar {})    = toFix p+  pprintPrec _ _ p@PKVar{}    = toFix p   pprintPrec _ _ (ETApp e s)     = "ETApp" <+> toFix e <+> toFix s   pprintPrec _ _ (ETAbs e s)     = "ETAbs" <+> toFix e <+> toFix s   pprintPrec z k (PGrad x _ _ e) = pprintPrec z k e <+> "&&" <+> toFix x -- "??"@@ -862,7 +869,7 @@ isSingletonExpr v (PAtom r e1 e2)   | e1 == EVar v && isEq r = Just e2   | e2 == EVar v && isEq r = Just e1-isSingletonExpr v (PIff e1 e2) +isSingletonExpr v (PIff e1 e2)   | e1 == EVar v           = Just e2   | e2 == EVar v           = Just e1 isSingletonExpr _ _        = Nothing@@ -885,14 +892,16 @@  pOr           = simplify . POr +infixl 9 &.& (&.&) :: Pred -> Pred -> Pred (&.&) p q = pAnd [p, q] +infixl 9 |.| (|.|) :: Pred -> Pred -> Pred (|.|) p q = pOr [p, q]  pIte :: Pred -> Expr -> Expr -> Expr-pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3]+pIte p1 p2 p3 = pAnd [p1 `PImp` p2, PNot p1 `PImp` p3]  pExist :: [(Symbol, Sort)] -> Pred -> Pred pExist []  p = p@@ -948,7 +957,7 @@ -- | Gradual Type Manipulation  ---------------------------- ------------------------------------------------------------ pGAnds :: [Expr] -> Expr-pGAnds = foldl pGAnd PTrue+pGAnds = foldl' pGAnd PTrue  pGAnd :: Expr -> Expr -> Expr pGAnd (PGrad k su i p) q = PGrad k su i (pAnd [p, q])@@ -1039,3 +1048,6 @@   toReft  :: r -> Reft   ofReft  :: Reft -> r   params  :: r -> [Symbol]          -- ^ parameters for Reft, vv + others++instance Fixpoint Doc where+  toFix = id

src/Language/Fixpoint/Types/Solutions.hs view

@@ -15,6 +15,8 @@ {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE TupleSections              #-} +{-# OPTIONS_GHC -Wno-name-shadowing     #-}+ -- | This module contains the top-level SOLUTION data types, --   including various indices used for solving. @@ -75,19 +77,15 @@ import           GHC.Generics import           Control.DeepSeq import           Data.Hashable-import qualified Data.Maybe                 as Mb +import qualified Data.Maybe                 as Mb import qualified Data.HashMap.Strict        as M import qualified Data.List                  as L import           Data.Generics             (Data)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif- import           Data.Typeable             (Typeable) import           Control.Monad (filterM) import           Language.Fixpoint.Misc import           Language.Fixpoint.Types.PrettyPrint-import           Language.Fixpoint.Types.Spans +import           Language.Fixpoint.Types.Spans import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Types.Theories@@ -140,7 +138,7 @@ emptyGMap sol = mapGMap sol (\(x,_) -> (x, GB []))  updateGMapWithKey :: [(KVar, QBind)] -> GSolution -> GSolution-updateGMapWithKey kqs sol = sol {gMap =  foldl (\m (k, (QB eq)) -> M.adjust (\(x, GB eqs) -> (x, GB (if eq `elem` eqs then eqs else eq:eqs))) k m) (gMap sol) kqs }+updateGMapWithKey kqs sol = sol {gMap = L.foldl' (\m (k, QB eq) -> M.adjust (\(x, GB eqs) -> (x, GB (if eq `elem` eqs then eqs else eq:eqs))) k m) (gMap sol) kqs }  qb :: [EQual] -> QBind qb = QB@@ -181,8 +179,8 @@  -------------------------------------------------------------------------------- -- | An `EbindSol` contains the relevant information for an existential-binder;---   (See tests/pos/ebind-*.fq for examples.) This is either ---   1. the constraint whose HEAD is a singleton that defines the binder, OR +--   (See tests/pos/ebind-*.fq for examples.) This is either+--   1. the constraint whose HEAD is a singleton that defines the binder, OR --   2. the solved out TERM that we should use in place of the ebind at USES. -------------------------------------------------------------------------------- data EbindSol@@ -192,19 +190,19 @@   | EbIncr                 -- ^ EBinds not to be solved for (because they're currently being solved for)    deriving (Show, Generic, NFData) -instance PPrint EbindSol where +instance PPrint EbindSol where   pprintTidy k (EbDef i x) = "EbDef:" <+> pprintTidy k i <+> pprintTidy k x   pprintTidy k (EbSol e)   = "EbSol:" <+> pprintTidy k e-  pprintTidy _ (EbIncr)    = "EbIncr"+  pprintTidy _ EbIncr    = "EbIncr"  ---------------------------------------------------------------------------------updateEbind :: Sol a b -> BindId -> Pred -> Sol a b +updateEbind :: Sol a b -> BindId -> Pred -> Sol a b ---------------------------------------------------------------------------------updateEbind s i !e = case M.lookup i (sEbd s) of +updateEbind s i !e = case M.lookup i (sEbd s) of   Nothing         -> errorstar $ "updateEBind: Unknown ebind " ++ show i-  Just (EbSol e0) -> errorstar $ "updateEBind: Re-assigning ebind " ++ show i ++ " with solution: " ++ show e0 +  Just (EbSol e0) -> errorstar $ "updateEBind: Re-assigning ebind " ++ show i ++ " with solution: " ++ show e0   Just _          -> s { sEbd = M.insert i (EbSol e) (sEbd s) }-    + -------------------------------------------------------------------------------- -- | A `Sol` contains the various indices needed to compute a solution, --   in particular, to compute `lhsPred` for any given constraint.@@ -228,21 +226,21 @@ mapGMap sol f = sol {gMap = M.map f (gMap sol)}  instance Semigroup (Sol a b) where-  s1 <> s2 = Sol { sEnv  = (sEnv s1)  <> (sEnv s2)-                 , sMap  = (sMap s1)  <> (sMap s2)-                 , gMap  = (gMap s1)  <> (gMap s2)-                 , sHyp  = (sHyp s1)  <> (sHyp s2)-                 , sScp  = (sScp s1)  <> (sScp s2)-                 , sEbd  = (sEbd s1)  <> (sEbd s2) -                 , sxEnv = (sxEnv s1) <> (sxEnv s2) +  s1 <> s2 = Sol { sEnv  = sEnv s1  <> sEnv s2+                 , sMap  = sMap s1  <> sMap s2+                 , gMap  = gMap s1  <> gMap s2+                 , sHyp  = sHyp s1  <> sHyp s2+                 , sScp  = sScp s1  <> sScp s2+                 , sEbd  = sEbd s1  <> sEbd s2+                 , sxEnv = sxEnv s1 <> sxEnv s2                  }  instance Monoid (Sol a b) where-  mempty = Sol { sEnv = mempty -               , sMap = mempty -               , gMap = mempty -               , sHyp = mempty -               , sScp = mempty +  mempty = Sol { sEnv = mempty+               , sMap = mempty+               , gMap = mempty+               , sHyp = mempty+               , sScp = mempty                , sEbd = mempty                , sxEnv = mempty                }@@ -253,7 +251,7 @@  instance (PPrint a, PPrint b) => PPrint (Sol a b) where   pprintTidy k s = vcat [ "sMap :=" <+> pprintTidy k (sMap s)-                        , "sEbd :=" <+> pprintTidy k (sEbd s) +                        , "sEbd :=" <+> pprintTidy k (sEbd s)                         ]  --------------------------------------------------------------------------------@@ -276,7 +274,7 @@ -------------------------------------------------------------------------------- result :: Sol a QBind -> M.HashMap KVar Expr ---------------------------------------------------------------------------------result s = sMap $ (pAnd . fmap eqPred . qbEQuals) <$> s+result s = sMap $ pAnd . fmap eqPred . qbEQuals <$> s   --------------------------------------------------------------------------------@@ -291,11 +289,11 @@ -------------------------------------------------------------------------------- -- | Create a Solution --------------------------------------------------------- ---------------------------------------------------------------------------------fromList :: SymEnv -         -> [(KVar, a)] -         -> [(KVar, b)] -         -> [(KVar, Hyp)] -         -> M.HashMap KVar IBindEnv +fromList :: SymEnv+         -> [(KVar, a)]+         -> [(KVar, b)]+         -> [(KVar, Hyp)]+         -> M.HashMap KVar IBindEnv          -> [(BindId, EbindSol)]          -> SEnv (BindId, Sort)          -> Sol a b@@ -312,9 +310,9 @@ -------------------------------------------------------------------------------- qbPreds msg s su (QB eqs) = [ (elabPred eq, eq) | eq <- eqs ]   where-    elabPred eq           = elaborate (atLoc eq $ "qbPreds:" ++ msg) env -                          . subst su -                          . eqPred +    elabPred eq           = elaborate (atLoc eq $ "qbPreds:" ++ msg) env+                          . subst su+                          . eqPred                           $ eq     env                   = sEnv s @@ -379,8 +377,8 @@   , _eqArgs :: ![Expr]   } deriving (Eq, Show, Data, Typeable, Generic) -instance Loc EQual where -  srcSpan = srcSpan . eqQual +instance Loc EQual where+  srcSpan = srcSpan . eqQual  trueEqual :: EQual trueEqual = EQL trueQual mempty []

src/Language/Fixpoint/Types/Sorts.hs view

@@ -2,7 +2,6 @@ {-# LANGUAGE TupleSections              #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE LambdaCase                 #-}@@ -11,7 +10,10 @@ {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE GADTs                      #-}+{-# LANGUAGE ViewPatterns               #-} +{-# OPTIONS_GHC -Wno-name-shadowing     #-}+ -- | This module contains the data types, operations and --   serialization functions for representing Fixpoint's --   implication (i.e. subtyping) and well-formedness@@ -73,10 +75,10 @@    -- * Embedding Source types as Sorts   , TCEmb, TCArgs (..)-  , tceLookup -  , tceFromList +  , tceLookup+  , tceFromList   , tceToList-  , tceMember +  , tceMember   , tceInsert   , tceInsertWith   , tceMap@@ -86,11 +88,6 @@ import           Data.Generics             (Data) import           Data.Typeable             (Typeable) import           GHC.Generics              (Generic)--#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif- import           Data.Hashable import           Data.HashSet (HashSet) import qualified Data.HashSet as HashSet@@ -234,24 +231,24 @@     go vs ss t             = (reverse vs, reverse ss, t)  -sortAbs :: Sort -> Int -sortAbs (FAbs i s)    = max i (sortAbs s) -sortAbs (FFunc s1 s2) = max (sortAbs s1) (sortAbs s2) +sortAbs :: Sort -> Int+sortAbs (FAbs i s)    = max i (sortAbs s)+sortAbs (FFunc s1 s2) = max (sortAbs s1) (sortAbs s2) sortAbs (FApp  s1 s2) = max (sortAbs s1) (sortAbs s2)-sortAbs _             = -1  +sortAbs _             = -1 -mapFVar :: (Int -> Int) -> Sort -> Sort -mapFVar f = go +mapFVar :: (Int -> Int) -> Sort -> Sort+mapFVar f = go   where go (FVar i)      = FVar (f i)         go (FAbs i t)    = FAbs (f i) (go t)         go (FFunc t1 t2) = FFunc (go t1) (go t2)         go (FApp t1 t2)  = FApp (go t1) (go t2)-        go t@(FObj _)    = t  -        go t@(FTC _)     = t  -        go t@FInt        = t  -        go t@FReal       = t  -        go t@FNum        = t  -        go t@FFrac       = t  +        go t@(FObj _)    = t+        go t@(FTC _)     = t+        go t@FInt        = t+        go t@FReal       = t+        go t@FNum        = t+        go t@FFrac       = t  -------------------------------------------------------------------------------- -- | Sorts ---------------------------------------------------------------------@@ -268,6 +265,9 @@           | FApp  !Sort !Sort    -- ^ constructed type             deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance PPrint Sort where+  pprintTidy _ = toFix+ sortSymbols :: Sort -> HashSet Symbol sortSymbols = \case   FObj s -> HashSet.singleton s@@ -317,7 +317,7 @@ muSort dds = mapSortDataDecl tx <$> dds   where     selfs = [(fTyconSelfSort c n, fTyconSort c) | DDecl c n _ <- dds]-    tx t  = fromMaybe t $ L.lookup t selfs +    tx t  = fromMaybe t $ L.lookup t selfs      mapSortDataDecl f  dd = dd { ddCtors  = mapSortDataCTor f  <$> ddCtors  dd }     mapSortDataCTor f  ct = ct { dcFields = mapSortDataField f <$> dcFields ct }@@ -352,7 +352,7 @@  isString :: Sort -> Bool isString (FApp l c)     = (isList l && isChar c) || isString l-isString (FTC (TC c i)) = (val c == strConName || tc_isString i)+isString (FTC (TC c i)) = val c == strConName || tc_isString i isString (FAbs _ s)     = isString s isString _              = False @@ -374,7 +374,7 @@     go (i:is) ss = FAbs  i $ go is ss     go _ _       = error "cannot happen" -   -- foldl (flip FAbs) (foldl1 (flip FFunc) ss) [0..i-1]+   -- foldl' (flip FAbs) (foldl1 (flip FFunc) ss) [0..i-1]  bkFFunc :: Sort -> Maybe (Int, [Sort]) bkFFunc t    = (maximum (0 : as),) <$> bkFun t'@@ -399,8 +399,8 @@ isPoly FAbs {} = True isPoly _       = False -mkPoly :: Int -> Sort -> Sort -mkPoly i s = foldl (flip FAbs) s [0..i] +mkPoly :: Int -> Sort -> Sort+mkPoly i s = foldl' (flip FAbs) s [0..i]   instance Hashable FTycon where@@ -429,11 +429,12 @@ toFixSort t@(FApp _ _) = toFixFApp (unFApp t)  toFixAbsApp :: Sort -> Doc-toFixAbsApp t = text "func" <-> parens (toFix n <+> text "," <+> toFix ts)+toFixAbsApp (functionSort -> Just (vs, ss, s)) =+  text "func" <-> parens (toFix n <+> text "," <+> toFix ts)   where-    Just (vs, ss, s) = functionSort t     n                = length vs     ts               = ss ++ [s]+toFixAbsApp _ = error "Unexpected nothing function sort"  toFixFApp            :: ListNE Sort -> Doc toFixFApp [t]        = toFixSort t@@ -501,9 +502,9 @@   | otherwise       = FTC c  basicSorts :: [Sort]-basicSorts = [FInt, boolSort] +basicSorts = [FInt, boolSort] -type SortSubst = M.HashMap Symbol Sort +type SortSubst = M.HashMap Symbol Sort  mkSortSubst :: [(Symbol, Sort)] -> SortSubst mkSortSubst = M.fromList@@ -517,8 +518,8 @@ sortSubst θ (FAbs i t)    = FAbs i (sortSubst θ t) sortSubst _  t            = t --- instance (S.Store a) => S.Store (TCEmb a) -instance S.Store TCArgs +-- instance (S.Store a) => S.Store (TCEmb a)+instance S.Store TCArgs instance S.Store FTycon instance S.Store TCInfo instance S.Store Sort@@ -531,12 +532,13 @@ instance B.Binary TCInfo instance B.Binary FTycon instance B.Binary Sort+instance (Eq a, Hashable a, B.Binary (M.HashMap a (Sort, TCArgs))) => B.Binary (TCEmb a)  instance NFData FTycon where   rnf (TC x i) = x `seq` i `seq` () -instance (NFData a) => NFData (TCEmb a) -instance NFData TCArgs +instance (NFData a) => NFData (TCEmb a)+instance NFData TCArgs instance NFData TCInfo instance NFData Sort instance NFData DataField@@ -556,57 +558,61 @@   mappend = (<>)  ---------------------------------------------------------------------------------- | Embedding stuff as Sorts +-- | Embedding stuff as Sorts --------------------------------------------------------------------------------newtype TCEmb a = TCE (M.HashMap a (Sort, TCArgs)) -  deriving (Eq, Show, Data, Typeable, Generic) +newtype TCEmb a = TCE (M.HashMap a (Sort, TCArgs))+  deriving (Eq, Show, Data, Typeable, Generic)  instance Hashable a => Hashable (TCEmb a)+instance PPrint a => PPrint (TCEmb a) where+  pprintTidy k = pprintTidy k . tceToList -data TCArgs = WithArgs | NoArgs -  deriving (Eq, Ord, Show, Data, Typeable, Generic)  -instance Hashable TCArgs +data TCArgs = WithArgs | NoArgs+  deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance Hashable TCArgs+instance B.Binary TCArgs+ tceInsertWith :: (Eq a, Hashable a) => (Sort -> Sort -> Sort) -> a -> Sort -> TCArgs -> TCEmb a -> TCEmb a tceInsertWith f k t a (TCE m) = TCE (M.insertWith ff k (t, a) m)-  where +  where     ff (t1, a1) (t2, a2)      = (f t1 t2, a1 <> a2) -instance Semigroup TCArgs where +instance Semigroup TCArgs where   NoArgs <> NoArgs = NoArgs   _      <> _      = WithArgs -instance Monoid TCArgs where -  mempty = NoArgs +instance Monoid TCArgs where+  mempty = NoArgs   mappend = (<>) -instance PPrint TCArgs where +instance PPrint TCArgs where   pprintTidy _ WithArgs = "*"   pprintTidy _ NoArgs   = ""  tceInsert :: (Eq a, Hashable a) => a -> Sort -> TCArgs -> TCEmb a -> TCEmb a tceInsert k t a (TCE m) = TCE (M.insert k (t, a) m) -tceLookup :: (Eq a, Hashable a) => a -> TCEmb a -> Maybe (Sort, TCArgs) +tceLookup :: (Eq a, Hashable a) => a -> TCEmb a -> Maybe (Sort, TCArgs) tceLookup k (TCE m) = M.lookup k m -instance (Eq a, Hashable a) => Semigroup (TCEmb a) where +instance (Eq a, Hashable a) => Semigroup (TCEmb a) where   (TCE m1) <> (TCE m2) = TCE (m1 <> m2) -instance (Eq a, Hashable a) => Monoid (TCEmb a) where -  mempty  = TCE mempty +instance (Eq a, Hashable a) => Monoid (TCEmb a) where+  mempty  = TCE mempty   mappend = (<>)   tceMap :: (Eq b, Hashable b) => (a -> b) -> TCEmb a -> TCEmb b-tceMap f = tceFromList . fmap (mapFst f) . tceToList +tceMap f = tceFromList . fmap (mapFst f) . tceToList  tceFromList :: (Eq a, Hashable a) => [(a, (Sort, TCArgs))] -> TCEmb a-tceFromList = TCE . M.fromList +tceFromList = TCE . M.fromList  tceToList :: TCEmb a -> [(a, (Sort, TCArgs))] tceToList (TCE m) = M.toList m -tceMember :: (Eq a, Hashable a) => a -> TCEmb a -> Bool +tceMember :: (Eq a, Hashable a) => a -> TCEmb a -> Bool tceMember k (TCE m) = M.member k m

src/Language/Fixpoint/Types/Spans.hs view

@@ -4,6 +4,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables       #-} +{-# OPTIONS_GHC -Wno-orphans           #-}+ module Language.Fixpoint.Types.Spans (    -- * Concrete Location Type@@ -34,7 +36,7 @@    -- * Destructing spans   , sourcePosElts-  , srcLine +  , srcLine   ) where  -- import           Control.Exception@@ -153,7 +155,7 @@ ppSourcePos :: SourcePos -> Doc ppSourcePos z = text (printf "%s:%d:%d" f l c)   where-    (f,l,c) = sourcePosElts $ z+    (f,l,c) = sourcePosElts z  instance Fixpoint SourcePos where   toFix = text . show@@ -224,7 +226,10 @@                   , sp_stop  :: !SourcePos}                  deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance NFData SrcSpan+instance S.Store SrcSpan instance Serialize SrcSpan+instance B.Binary SrcSpan  instance PPrint SrcSpan where   pprintTidy _ = ppSrcSpan@@ -246,13 +251,13 @@ instance Hashable SrcSpan where   hashWithSalt i z = hashWithSalt i (sp_start z, sp_stop z) -instance Loc SrcSpan where -  srcSpan x = x +instance Loc SrcSpan where+  srcSpan x = x  instance Loc () where   srcSpan _ = dummySpan -instance Loc SourcePos where +instance Loc SourcePos where   srcSpan l = SS l l  dummySpan :: SrcSpan

src/Language/Fixpoint/Types/Substitutions.hs view

@@ -1,10 +1,11 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans   #-}+ -- | This module contains the various instances for Subable, --   which (should) depend on the visitors, and hence cannot --   be in the same place as the @Term@ definitions.--{-# LANGUAGE FlexibleInstances #-} module Language.Fixpoint.Types.Substitutions (     mkSubst   , isEmptySubst@@ -20,10 +21,6 @@ import           Data.Maybe import qualified Data.HashMap.Strict       as M import qualified Data.HashSet              as S-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif- import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types.Sorts@@ -63,7 +60,7 @@ targetSubstSyms (Su ms) = syms $ M.elems ms  -  + instance Subable () where   syms _      = []   subst _ ()  = ()@@ -88,7 +85,7 @@   substf = fmap . substf   substa = fmap . substa - + instance Subable a => Subable (M.HashMap k a) where   syms   = syms . M.elems   subst  = M.map . subst@@ -274,6 +271,7 @@   toFix (RR so (Reft (v, ra)))     = braces     $ toFix v <+> text ":" <+> toFix so <+> text "|" <+> toFix (conjuncts ra)+  simplify (RR so (Reft (v, ra))) = RR (simplify so) (Reft (simplify v, simplify ra))  instance Show Reft where   show = showFix

src/Language/Fixpoint/Types/Templates.hs view

@@ -1,6 +1,6 @@ module Language.Fixpoint.Types.Templates ( -  anything, Templates, makeTemplates, +  anything, Templates, makeTemplates,    isEmptyTemplates, isAnyTemplates, @@ -13,94 +13,94 @@ import Language.Fixpoint.Types.PrettyPrint import Text.PrettyPrint.HughesPJ.Compat -data Templates -  = TAll -  | TExprs [Template] +data Templates+  = TAll+  | TExprs [Template]   deriving Show   type Template = ([Symbol], Expr)  -class HasTemplates a where -  filterUnMatched :: Templates -> a -> a +class HasTemplates a where+  filterUnMatched :: Templates -> a -> a   instance HasTemplates Expr where-  filterUnMatched temps e = pAnd $ filter (not . matchesTemplates temps) $ conjuncts e +  filterUnMatched temps e = pAnd $ filter (not . matchesTemplates temps) $ conjuncts e  instance HasTemplates Reft where   filterUnMatched temps (Reft (x,e)) = Reft (x, filterUnMatched temps e) -matchesTemplates :: Templates -> Expr -> Bool -matchesTemplates TAll _ = True +matchesTemplates :: Templates -> Expr -> Bool+matchesTemplates TAll _ = True matchesTemplates (TExprs ts) e = any (`matchesTemplate` e) ts -matchesTemplate :: Template -> Expr -> Bool +matchesTemplate :: Template -> Expr -> Bool matchesTemplate (xs, t@(EVar x)) e-  = x `elem` xs || e == t  -matchesTemplate (xs, EApp t1 t2) (EApp e1 e2) -  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, ENeg t) (ENeg e) +  = x `elem` xs || e == t+matchesTemplate (xs, EApp t1 t2) (EApp e1 e2)+  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2+matchesTemplate (xs, ENeg t) (ENeg e)   = matchesTemplate (xs, t) e-matchesTemplate (xs, EBin b t1 t2) (EBin b' e1 e2) -  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, EIte t1 t2 t3) (EIte e1 e2 e3) -  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 && matchesTemplate (xs, t3) e3 -matchesTemplate (xs, ECst t s) (ECst e s') +matchesTemplate (xs, EBin b t1 t2) (EBin b' e1 e2)+  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2+matchesTemplate (xs, EIte t1 t2 t3) (EIte e1 e2 e3)+  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 && matchesTemplate (xs, t3) e3+matchesTemplate (xs, ECst t s) (ECst e s')   = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, ELam b t) (ELam b' e) +matchesTemplate (xs, ELam b t) (ELam b' e)   = b == b' && matchesTemplate (xs, t) e-matchesTemplate (xs, ETApp t s) (ETApp e s') +matchesTemplate (xs, ETApp t s) (ETApp e s')   = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, ETAbs t s) (ETAbs e s') +matchesTemplate (xs, ETAbs t s) (ETAbs e s')   = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, PNot t) (PNot e) +matchesTemplate (xs, PNot t) (PNot e)   = matchesTemplate (xs, t) e-matchesTemplate (xs, PAnd ts) (PAnd es) -  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es -matchesTemplate (xs, POr ts) (POr es) -  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es -matchesTemplate (xs, PImp t1 t2) (PImp e1 e2) -  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, PIff t1 t2) (PIff e1 e2) -  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, PAtom b t1 t2) (PAtom b' e1 e2) -  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, PAll s t) (PAll s' e) +matchesTemplate (xs, PAnd ts) (PAnd es)+  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es+matchesTemplate (xs, POr ts) (POr es)+  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es+matchesTemplate (xs, PImp t1 t2) (PImp e1 e2)+  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2+matchesTemplate (xs, PIff t1 t2) (PIff e1 e2)+  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2+matchesTemplate (xs, PAtom b t1 t2) (PAtom b' e1 e2)+  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2+matchesTemplate (xs, PAll s t) (PAll s' e)   = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, PExist s t) (PExist s' e) +matchesTemplate (xs, PExist s t) (PExist s' e)   = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, PGrad s1 s2 s3 t) (PGrad s1' s2' s3' e) +matchesTemplate (xs, PGrad s1 s2 s3 t) (PGrad s1' s2' s3' e)   = s1 == s1' && s2 == s2' && s3 == s3' && matchesTemplate (xs, t) e-matchesTemplate (xs, ECoerc s1 s2 t) (ECoerc s1' s2' e) +matchesTemplate (xs, ECoerc s1 s2 t) (ECoerc s1' s2' e)   = s1 == s1' && s2 == s2' && matchesTemplate (xs, t) e-matchesTemplate (_, t) e -  = t == e +matchesTemplate (_, t) e+  = t == e    makeTemplates :: [([Symbol], Expr)] -> Templates-makeTemplates = TExprs +makeTemplates = TExprs  -isEmptyTemplates, isAnyTemplates :: Templates -> Bool -isEmptyTemplates (TExprs []) = True -isEmptyTemplates _           = False +isEmptyTemplates, isAnyTemplates :: Templates -> Bool+isEmptyTemplates (TExprs []) = True+isEmptyTemplates _           = False -isAnyTemplates TAll = True -isAnyTemplates _    = False +isAnyTemplates TAll = True+isAnyTemplates _    = False  anything :: Templates anything = TAll -instance Semigroup Templates where +instance Semigroup Templates where   TAll <> _ = TAll   _ <> TAll = TAll   TExprs i1 <> TExprs i2 = TExprs (i1 ++ i2) -instance Monoid Templates where -  mempty = TExprs [] +instance Monoid Templates where+  mempty = TExprs []  instance PPrint Templates where-  pprintTidy _ = text . show +  pprintTidy _ = text . show

src/Language/Fixpoint/Types/Theories.hs view

@@ -4,6 +4,9 @@ {-# LANGUAGE PatternGuards              #-} {-# LANGUAGE DeriveDataTypeable         #-} +{-# OPTIONS_GHC -Wno-orphans            #-}+{-# OPTIONS_GHC -Wno-name-shadowing     #-}+ -- | This module contains the types defining an SMTLIB2 interface.  module Language.Fixpoint.Types.Theories (@@ -35,10 +38,6 @@   import           Data.Generics             (Data)-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup            (Semigroup (..))-#endif- import           Data.Typeable             (Typeable) import           Data.Hashable import           GHC.Generics              (Generic)@@ -50,13 +49,13 @@ import           Language.Fixpoint.Types.Environments  import           Text.PrettyPrint.HughesPJ.Compat-import qualified Data.List                as L +import qualified Data.List                as L import           Data.Text (Text) import qualified Data.Text                as Text import qualified Data.Text.Lazy           as LT import qualified Data.Store              as S import qualified Data.HashMap.Strict      as M-import qualified Language.Fixpoint.Misc   as Misc +import qualified Language.Fixpoint.Misc   as Misc import Data.Functor.Contravariant (Contravariant(contramap))  --------------------------------------------------------------------------------@@ -65,7 +64,7 @@ type Raw = LT.Text  instance S.Store Raw where-  peek = LT.fromStrict <$> S.peek  +  peek = LT.fromStrict <$> S.peek   poke = S.poke . LT.toStrict   size = contramap LT.toStrict S.size @@ -106,13 +105,13 @@     xEnv'                 = unionSEnv xEnv wiredInEnv     dEnv                  = fromListSEnv [(symbol d, d) | d <- ds]     sortMap               = M.fromList (zip smts [0..])-    smts                  = funcSorts dEnv ts +    smts                  = funcSorts dEnv ts  -- | These are "BUILT-in" polymorphic functions which are --   UNININTERPRETED but POLYMORPHIC, hence need to go through --   the apply-defunc stuff. wiredInEnv :: M.HashMap Symbol Sort-wiredInEnv = M.fromList +wiredInEnv = M.fromList   [ (toIntName, mkFFunc 1 [FVar 0, FInt])   , (tyCastName, FAbs 0 $ FAbs 1 $ FFunc (FVar 0) (FVar 1))   ]@@ -158,7 +157,7 @@ insertSymEnv x t env = env { seSort = insertSEnv x t (seSort env) }  insertsSymEnv :: SymEnv -> [(Symbol, Sort)] -> SymEnv-insertsSymEnv = L.foldl' (\env (x, s) -> insertSymEnv x s env) +insertsSymEnv = L.foldl' (\env (x, s) -> insertSymEnv x s env)  symbolAtName :: (PPrint a) => Symbol -> SymEnv -> a -> Sort -> Text symbolAtName mkSym env e = symbolAtSmtName mkSym env e . ffuncSort env@@ -178,7 +177,7 @@ ffuncSort :: SymEnv -> Sort -> FuncSort ffuncSort env t      = {- tracepp ("ffuncSort " ++ showpp (t1,t2)) -} (tx t1, tx t2)   where-    tx               = applySmtSort (seData env) +    tx               = applySmtSort (seData env)     (t1, t2)         = args t     args (FFunc a b) = (a, b)     args _           = (FInt, FInt)@@ -254,21 +253,22 @@ --   using `Int` (though really, there SHOULD BE NO floating tyVars... --   'smtSort True  msg t' serializes a sort 't' using type variables, --   'smtSort False msg t' serializes a sort 't' using 'Int' instead of tyvars.- sortSmtSort :: Bool -> SEnv DataDecl -> Sort -> SmtSort sortSmtSort poly env t  = {- tracepp ("sortSmtSort: " ++ showpp t) else id) $ -}  go . unAbs $ t   where-    m = sortAbs t +    m = sortAbs t     go (FFunc _ _)    = SInt     go FInt           = SInt     go FReal          = SReal     go t       | t == boolSort = SBool-      | isString t    = SString +      | isString t    = SString     go (FVar i)       | poly, i < m   = SVar i       | otherwise     = SInt-    go t              = fappSmtSort poly m env ct ts where (ct:ts) = unFApp t+    go t+      | (ct:ts) <- unFApp t = fappSmtSort poly m env ct ts+      | otherwise = error "Unexpected empty 'unFApp t'"  fappSmtSort :: Bool -> Int -> SEnv DataDecl -> Sort -> [Sort] -> SmtSort fappSmtSort poly m env = go

src/Language/Fixpoint/Types/Triggers.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} @@ -18,7 +17,7 @@ import           Text.PrettyPrint.HughesPJ  import Language.Fixpoint.Types.Refinements-import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.PrettyPrint import Language.Fixpoint.Misc              (errorstar)  @@ -28,10 +27,10 @@ data Trigger = NoTrigger | LeftHandSide   deriving (Eq, Show, Generic) -instance PPrint Trigger where -  pprintTidy _ = text . show +instance PPrint Trigger where+  pprintTidy _ = text . show -instance PPrint a => PPrint (Triggered a) where +instance PPrint a => PPrint (Triggered a) where   pprintTidy k (TR t x) = parens (pprintTidy k t <+> text ":" <+> pprintTidy k x)  noTrigger :: e -> Triggered e

src/Language/Fixpoint/Types/Utils.hs view

@@ -35,7 +35,7 @@ -------------------------------------------------------------------------------- kvarDomain si k = domain (bs si) (getWfC si k) -domain :: BindEnv -> WfC a -> [Symbol]+domain :: BindEnv a -> WfC a -> [Symbol] domain be wfc = fst3 (wrft wfc) : map fst (envCs be $ wenv wfc)  getWfC :: SInfo a -> KVar -> WfC a@@ -58,9 +58,9 @@     rs                   = reftConjuncts (sr_reft sr)     t                    = sr_sort sr -    go ps ks gs ((v, PKVar k su    ):xs) = go ps (KVS v t k su:ks) gs xs -    go ps ks gs ((v, PGrad k su _ _):xs) = go ps ks (KVS v t k su:gs) xs -    go ps ks gs ((_, p):xs)              = go (p:ps) ks gs xs +    go ps ks gs ((v, PKVar k su    ):xs) = go ps (KVS v t k su:ks) gs xs+    go ps ks gs ((v, PGrad k su _ _):xs) = go ps ks (KVS v t k su:gs) xs+    go ps ks gs ((_, p):xs)              = go (p:ps) ks gs xs     go ps ks gs []                       = (ps, ks, gs)  @@ -78,17 +78,17 @@ -------------------------------------------------------------------------------  isRegular []       = error "impossible: isRegular"-isRegular ds@(d:_) = all (\d' -> ddVars d' == nArgs) ds   -- same number of tyArgs +isRegular ds@(d:_) = all (\d' -> ddVars d' == nArgs) ds   -- same number of tyArgs                   && all isRegApp fldSortApps         -- 'regular' application (tc @0 ... @n)   where     nArgs          = ddVars d     tcs            = S.fromList ( symbol . ddTyCon <$> ds)-    fldSortApps    = [ (c,ts) | d           <- ds-                              , ctor        <- ddCtors d-                              , DField _ t  <- dcFields ctor +    fldSortApps    = [ (c,ts) | d'          <- ds+                              , ctor        <- ddCtors d'+                              , DField _ t  <- dcFields ctor                               , (c, ts)     <- sortApps t-                     ]         -    isRegApp cts   = case cts of +                     ]+    isRegApp cts   = case cts of                         (FTC c, ts) -> not (S.member (symbol c) tcs) || isRegularArgs nArgs ts                         _           -> False @@ -98,17 +98,17 @@ type SortApp = (Sort, [Sort])  sortApps :: Sort -> [SortApp]-sortApps = go -  where +sortApps = go+  where     go t@FApp {}     = (f, ts) : concatMap go ts where (f, ts) = splitApp t     go (FFunc t1 t2) = go t1 ++ go t2     go (FAbs _ t)    = go t     go _             = [] -splitApp :: Sort -> SortApp +splitApp :: Sort -> SortApp splitApp = go []   where-    go stk (FApp t1 t2) = go (t2:stk) t1  +    go stk (FApp t1 t2) = go (t2:stk) t1     go stk t            = (t, stk)  --------------------------------------------------------------------------------@@ -140,5 +140,5 @@     go (FTC c)       = [c]     go (FApp  t1 t2) = go t1 ++ go t2     go (FFunc t1 t2) = go t1 ++ go t2-    go (FAbs _ t)    = go t +    go (FAbs _ t)    = go t     go _             = []

src/Language/Fixpoint/Types/Visitor.hs view

@@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns  #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Fixpoint.Types.Visitor (   -- * Visitor      Visitor (..)@@ -45,18 +45,10 @@   , foldSort   , mapSort   , foldDataDecl--  , (<$$>)--   ) where  -- import           Control.Monad.Trans.State.Strict (State, modify, runState) -- import           Control.DeepSeq-#if !MIN_VERSION_base(4,14,0)-import           Data.Semigroup      (Semigroup (..))-#endif- import           Control.Monad.State.Strict import qualified Data.HashSet        as S import qualified Data.HashMap.Strict as M@@ -106,17 +98,6 @@   -- !cur <- get   -- put ((mappend $!! z) $!! cur) -(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b]-f <$$> xs = f Misc.<$$> xs---- (<$$>) ::  (Applicative f) => (a -> f b) -> [a] -> f [b]--- f <$$> x = traverse f x--- _ <$$> []     = return []--- f <$$> (x:xs) = do-  -- !y  <- f x-  -- !ys <- f <$$> xs-  -- return (y:ys)------------------------------------------------------------------------------- class Visitable t where   visit :: (Monoid a) => Visitor a c -> c -> t -> VisitM a t @@ -129,10 +110,10 @@ instance Visitable SortedReft where   visit v c (RR t r) = RR t <$> visit v c r -instance Visitable (Symbol, SortedReft) where-  visit v c (sym, sr) = (sym, ) <$> visit v c sr+instance Visitable (Symbol, SortedReft, a) where+  visit v c (sym, sr, a) = (sym, ,a) <$> visit v c sr -instance Visitable BindEnv where+instance Visitable (BindEnv a) where   visit v c = mapM (visit v c)  ---------------------------------------------------------------------------------@@ -153,56 +134,56 @@   visit v c x = do     cm' <- mapM (visit v c) (cm x)     bs' <- visit v c (bs x)-    ae' <- visit v c (ae x) +    ae' <- visit v c (ae x)     return x { cm = cm', bs = bs', ae = ae' } -instance Visitable AxiomEnv where -  visit v c x = do -    eqs'    <- mapM (visit v c) (aenvEqs   x) -    simpls' <- mapM (visit v c) (aenvSimpl x) -    return x { aenvEqs = eqs' , aenvSimpl = simpls'} +instance Visitable AxiomEnv where+  visit v c x = do+    eqs'    <- mapM (visit v c) (aenvEqs   x)+    simpls' <- mapM (visit v c) (aenvSimpl x)+    return x { aenvEqs = eqs' , aenvSimpl = simpls'} -instance Visitable Equation where -  visit v c eq = do -    body' <- visit v c (eqBody eq) -    return eq { eqBody = body' } +instance Visitable Equation where+  visit v c eq = do+    body' <- visit v c (eqBody eq)+    return eq { eqBody = body' } -instance Visitable Rewrite where -  visit v c rw = do -    body' <- visit v c (smBody rw) -    return rw { smBody = body' } +instance Visitable Rewrite where+  visit v c rw = do+    body' <- visit v c (smBody rw)+    return rw { smBody = body' }  --------------------------------------------------------------------------------- visitExpr :: (Monoid a) => Visitor a ctx -> ctx -> Expr -> VisitM a Expr visitExpr !v    = vE   where-    vE !c !e    = do {- SCC "visitExpr.vE.accum" #-} accum acc-                     {- SCC "visitExpr.vE.step" #-}  step c' e'+    vE !c !e    = do {- SCC "visitExpr.vE.accum" -} accum acc+                     {- SCC "visitExpr.vE.step" -}  step c' e'       where !c'  = ctxExpr v c  e             !e'  = txExpr  v c' e             !acc = accExpr v c' e-    step _ !e@(ESym _)       = return e-    step _ !e@(ECon _)       = return e-    step _ !e@(EVar _)       = return e-    step !c !(EApp f e)      = EApp        <$> vE c f  <*> vE c e-    step !c !(ENeg e)        = ENeg        <$> vE c e-    step !c !(EBin o e1 e2)  = EBin o      <$> vE c e1 <*> vE c e2-    step !c !(EIte p e1 e2)  = EIte        <$> vE c p  <*> vE c e1 <*> vE c e2-    step !c !(ECst e t)      = (`ECst` t)  <$> vE c e-    step !c !(PAnd  ps)      = PAnd        <$> (vE c <$$> ps)-    step !c !(POr  ps)       = POr         <$> (vE c <$$> ps)-    step !c !(PNot p)        = PNot        <$> vE c p-    step !c !(PImp p1 p2)    = PImp        <$> vE c p1 <*> vE c p2-    step !c !(PIff p1 p2)    = PIff        <$> vE c p1 <*> vE c p2-    step !c !(PAtom r e1 e2) = PAtom r     <$> vE c e1 <*> vE c e2-    step !c !(PAll xts p)    = PAll   xts  <$> vE c p-    step !c !(ELam (x,t) e)  = ELam (x,t)  <$> vE c e-    step !c !(ECoerc a t e)  = ECoerc a t  <$> vE c e-    step !c !(PExist xts p)  = PExist xts  <$> vE c p-    step !c !(ETApp e s)     = (`ETApp` s) <$> vE c e-    step !c !(ETAbs e s)     = (`ETAbs` s) <$> vE c e-    step _  !p@(PKVar _ _)   = return p-    step !c !(PGrad k su i e) = PGrad k su i <$> vE c e+    step _ e@(ESym _)       = return e+    step _ e@(ECon _)       = return e+    step _ e@(EVar _)       = return e+    step !c (EApp f e)      = EApp        <$> vE c f  <*> vE c e+    step !c (ENeg e)        = ENeg        <$> vE c e+    step !c (EBin o e1 e2)  = EBin o      <$> vE c e1 <*> vE c e2+    step !c (EIte p e1 e2)  = EIte        <$> vE c p  <*> vE c e1 <*> vE c e2+    step !c (ECst e t)      = (`ECst` t)  <$> vE c e+    step !c (PAnd  ps)      = PAnd        <$> (vE c `traverse` ps)+    step !c (POr  ps)       = POr         <$> (vE c `traverse` ps)+    step !c (PNot p)        = PNot        <$> vE c p+    step !c (PImp p1 p2)    = PImp        <$> vE c p1 <*> vE c p2+    step !c (PIff p1 p2)    = PIff        <$> vE c p1 <*> vE c p2+    step !c (PAtom r e1 e2) = PAtom r     <$> vE c e1 <*> vE c e2+    step !c (PAll xts p)    = PAll   xts  <$> vE c p+    step !c (ELam (x,t) e)  = ELam (x,t)  <$> vE c e+    step !c (ECoerc a t e)  = ECoerc a t  <$> vE c e+    step !c (PExist xts p)  = PExist xts  <$> vE c p+    step !c (ETApp e s)     = (`ETApp` s) <$> vE c e+    step !c (ETAbs e s)     = (`ETAbs` s) <$> vE c e+    step _  p@(PKVar _ _)   = return p+    step !c (PGrad k su i e) = PGrad k su i <$> vE c e  mapKVars :: Visitable t => (KVar -> Maybe Expr) -> t -> t mapKVars f = mapKVars' f'@@ -268,24 +249,24 @@     go e@(ECon _)      = f e     go e@(EVar _)      = f e     go e@(PKVar _ _)   = f e-    go (PGrad k s i e) = f =<< (PGrad k s i <$>  go e                     )-    go (ENeg e)        = f =<< (ENeg        <$>  go e                     )-    go (PNot p)        = f =<< (PNot        <$>  go p                     )-    go (ECst e t)      = f =<< ((`ECst` t)  <$>  go e                     )-    go (PAll xts p)    = f =<< (PAll   xts  <$>  go p                     )-    go (ELam (x,t) e)  = f =<< (ELam (x,t)  <$>  go e                     )-    go (ECoerc a t e)  = f =<< (ECoerc a t  <$>  go e                     )-    go (PExist xts p)  = f =<< (PExist xts  <$>  go p                     )-    go (ETApp e s)     = f =<< ((`ETApp` s) <$>  go e                     )-    go (ETAbs e s)     = f =<< ((`ETAbs` s) <$>  go e                     )+    go (PGrad k s i e) = f . PGrad k s i =<< go e+    go (ENeg e)        = f . ENeg =<< go e+    go (PNot p)        = f . PNot =<< go p+    go (ECst e t)      = f . (`ECst` t) =<< go e+    go (PAll xts p)    = f . PAll   xts =<< go p+    go (ELam (x,t) e)  = f . ELam (x,t) =<< go e+    go (ECoerc a t e)  = f . ECoerc a t =<< go e+    go (PExist xts p)  = f . PExist xts =<< go p+    go (ETApp e s)     = f . (`ETApp` s) =<< go e+    go (ETAbs e s)     = f . (`ETAbs` s) =<< go e     go (EApp g e)      = f =<< (EApp        <$>  go g  <*> go e           )     go (EBin o e1 e2)  = f =<< (EBin o      <$>  go e1 <*> go e2          )     go (PImp p1 p2)    = f =<< (PImp        <$>  go p1 <*> go p2          )     go (PIff p1 p2)    = f =<< (PIff        <$>  go p1 <*> go p2          )     go (PAtom r e1 e2) = f =<< (PAtom r     <$>  go e1 <*> go e2          )     go (EIte p e1 e2)  = f =<< (EIte        <$>  go p  <*> go e1 <*> go e2)-    go (PAnd  ps)      = f =<< (PAnd        <$> (go <$$> ps)              )-    go (POr  ps)       = f =<< (POr         <$> (go <$$> ps)              )+    go (PAnd ps)       = f . PAnd =<< (go `traverse` ps)+    go (POr ps)        = f . POr =<< (go `traverse` ps)  mapKVarSubsts :: Visitable t => (KVar -> Subst -> Subst) -> t -> t mapKVarSubsts f          = trans kvVis () ()@@ -354,13 +335,13 @@       PAnd ps -> foldr (flip go) acc ps       POr ps -> foldr (flip go) acc ps -envKVars :: (TaggedC c a) => BindEnv -> c a -> [KVar]+envKVars :: (TaggedC c a) => BindEnv a -> c a -> [KVar] envKVars be c = squish [ kvs sr |  (_, sr) <- clhs be c]   where     squish    = S.toList  . S.fromList . concat     kvs       = kvarsExpr . reftPred . sr_reft -envKVarsN :: (TaggedC c a) => BindEnv -> c a -> [(KVar, Int)]+envKVarsN :: (TaggedC c a) => BindEnv a -> c a -> [(KVar, Int)] envKVarsN be c = tally [ kvs sr |  (_, sr) <- clhs be c]   where     tally      = Misc.count . concat@@ -376,9 +357,9 @@ isConcC = all isConc . conjuncts . crhs  isKvar :: Expr -> Bool-isKvar (PKVar {}) = True-isKvar (PGrad {}) = True-isKvar _          = False+isKvar PKVar{} = True+isKvar PGrad{} = True+isKvar _       = False  isConc :: Expr -> Bool isConc = null . kvarsExpr@@ -400,16 +381,17 @@ --   to the ty-vars that they should be substituted with. Note the --   domain and range are both Symbol and not the Int used for real ty-vars. ---------------------------------------------------------------------------------type CoSub = M.HashMap Symbol Sort +type CoSub = M.HashMap Symbol Sort  applyCoSub :: CoSub -> Expr -> Expr-applyCoSub coSub      = mapExpr fE+applyCoSub coSub = mapExprOnExpr fE   where     fE (ECoerc s t e) = ECoerc  (txS s) (txS t) e     fE (ELam (x,t) e) = ELam (x, txS t)         e+    fE (ECst e t)     = ECst e (txS t)     fE e              = e-    txS               = mapSort fS-    fS (FObj a)       = {- FObj -} (txV a)+    txS               = mapSortOnlyOnce fS+    fS (FObj a)       = {- FObj -} txV a     fS t              = t     txV a             = M.lookupDefault (FObj a) a coSub @@ -425,13 +407,31 @@     go b (FAbs _ t)    = go b t     go b _             = b +-- | Like 'mapSort' but it doesn't substitute on the result+-- of the function.+--+-- > mapSortOnlyOnce [(a,b), (b,c)] a = b+--+-- whereas+--+-- > mapSort [(a,b), (b,c)] a = c+--+mapSortOnlyOnce :: (Sort -> Sort) -> Sort -> Sort+mapSortOnlyOnce f = step+  where+    step !x           = f $ go x+    go (FFunc t1 t2) = FFunc (step t1) (step t2)+    go (FApp t1 t2)  = FApp  (step t1) (step t2)+    go (FAbs i t)    = FAbs i (step t)+    go !t             = t+ mapSort :: (Sort -> Sort) -> Sort -> Sort mapSort f = step   where     step !x           = go (f x)-    go !(FFunc t1 t2) = FFunc (step t1) (step t2)-    go !(FApp t1 t2)  = FApp  (step t1) (step t2)-    go !(FAbs i t)    = FAbs i (step t)+    go (FFunc t1 t2) = FFunc (step t1) (step t2)+    go (FApp t1 t2)  = FApp  (step t1) (step t2)+    go (FAbs i t)    = FAbs i (step t)     go !t             = t  foldDataDecl :: (a -> Sort -> a) -> a -> DataDecl -> a@@ -454,16 +454,16 @@   instance SymConsts a => SymConsts [a] where-  symConsts xs = concatMap symConsts xs -  -instance SymConsts AxiomEnv where +  symConsts xs = concatMap symConsts xs++instance SymConsts AxiomEnv where   symConsts xs =  symConsts (aenvEqs xs) ++ symConsts (aenvSimpl xs) -instance SymConsts Equation where -  symConsts = symConsts . eqBody +instance SymConsts Equation where+  symConsts = symConsts . eqBody -instance SymConsts Rewrite where -  symConsts = symConsts . smBody +instance SymConsts Rewrite where+  symConsts = symConsts . smBody   -- instance  SymConsts (FInfo a) where@@ -474,8 +474,8 @@       bsLits   = symConsts           $ bs                fi       qsLits   = concatMap symConsts $ qBody   <$> quals fi -instance SymConsts BindEnv where-  symConsts    = concatMap (symConsts . snd) . M.elems . beBinds+instance SymConsts (BindEnv a) where+  symConsts    = concatMap (symConsts . Misc.snd3) . M.elems . beBinds  instance SymConsts (SubC a) where   symConsts c  = symConsts (slhs c) ++

src/Language/Fixpoint/Utils/Builder.hs view

@@ -22,6 +22,7 @@   , blt   ) where +import           Data.Foldable (fold) import           Data.String import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy         as LT@@ -61,6 +62,7 @@ parens :: Builder -> Builder parens b = "(" <>  b <> ")" +infixl 9 <+> (<+>) :: Builder -> Builder -> Builder x <+> y = x <> " " <> y @@ -77,7 +79,7 @@ key3 k b1 b2 b3 = parenSeqs [k, b1, b2, b3]  seqs :: [Builder] -> Builder-seqs = foldr (<>) mempty . L.intersperse " "+seqs = fold . L.intersperse " "  bShow :: Show a => a -> Builder bShow = fromString . show

src/Language/Fixpoint/Utils/Files.hs view

@@ -74,7 +74,7 @@          | Js       -- ^ JavaScript source          | Ts       -- ^ Typescript source          | Spec     -- ^ Spec file (e.g. include/Prelude.spec)-         | BinSpec  -- ^ Lifted-Spec file, containing automatically generated specifications +         | BinSpec  -- ^ Lifted-Spec file, containing automatically generated specifications          | Hquals   -- ^ Qualifiers file (e.g. include/Prelude.hquals)          | Result   -- ^ Final result: SAFE/UNSAFE          | Cst      -- ^ HTML file with templates?

src/Language/Fixpoint/Utils/Trie.hs view

@@ -1,4 +1,4 @@-module Language.Fixpoint.Utils.Trie +module Language.Fixpoint.Utils.Trie   ( -- * Datatype     Trie (..)   , Branch (..)@@ -8,75 +8,75 @@   , insert   , fromList -    -- * Visitors -  , fold +    -- * Visitors+  , fold   , foldM-  ) -  where +  )+  where -import qualified Data.List as L -import Language.Fixpoint.Types.PrettyPrint  +import qualified Data.List as L+import Language.Fixpoint.Types.PrettyPrint import qualified Language.Fixpoint.Misc as Misc  type Key  = Int type Path = [Key] -data Trie a -  = Node ![Branch a]+newtype Trie a+  = Node [Branch a]   deriving (Eq, Show) -data Branch a +data Branch a   = Bind !Key !(Trie a)-  | Val a +  | Val a   deriving (Eq, Show)  --------------------------------------------------------------------------------empty :: Trie a +empty :: Trie a ------------------------------------------------------------------------------- empty = Node []  --------------------------------------------------------------------------------insert :: Path -> a -> Trie a -> Trie a +insert :: Path -> a -> Trie a -> Trie a --------------------------------------------------------------------------------insert []     v (Node ts) = Node ((Val v) : ts) +insert []     v (Node ts) = Node (Val v : ts) insert (i:is) v (Node ts) = Node (insertKey i is v ts)   --------------------------------------------------------------------------------fromList :: [(Path, a)] -> Trie a +fromList :: [(Path, a)] -> Trie a --------------------------------------------------------------------------------fromList = L.foldl' (\t (k, v) -> insert k v t) empty +fromList = L.foldl' (\t (k, v) -> insert k v t) empty --- i=3 --- 0 1 2 3 4 5 6 -  +-- i=3+-- 0 1 2 3 4 5 6+ insertKey :: Key -> Path -> a -> [Branch a] -> [Branch a]-insertKey i is v bs@((Bind j tj) : bs') -  | i == j              = Bind i (insert is v tj) : bs' -  | i <  j              = Bind i (pathTrie is v)  : bs -insertKey i is v (b:bs) = b : insertKey i is v bs -insertKey i is v []     = [ Bind i (pathTrie is v) ] +insertKey i is v bs@((Bind j tj) : bs')+  | i == j              = Bind i (insert is v tj) : bs'+  | i <  j              = Bind i (pathTrie is v)  : bs+insertKey i is v (b:bs) = b : insertKey i is v bs+insertKey i is v []     = [ Bind i (pathTrie is v) ] -pathTrie :: Path -> a -> Trie a -pathTrie []     v = Node [Val v] +pathTrie :: Path -> a -> Trie a+pathTrie []     v = Node [Val v] pathTrie (i:is) v = Node [Bind i (pathTrie is v)]  --------------------------------------------------------------------------------fold :: (acc -> Path -> a -> acc) -> acc -> Trie a -> acc +fold :: (acc -> Path -> a -> acc) -> acc -> Trie a -> acc ------------------------------------------------------------------------------- fold = undefined  --------------------------------------------------------------------------------foldM :: (Monad m) => (acc -> Path -> a -> m acc) -> acc -> Trie a -> m acc +foldM :: (Monad m) => (acc -> Path -> a -> m acc) -> acc -> Trie a -> m acc ------------------------------------------------------------------------------- foldM = undefined  -instance Show a => PPrint (Trie a) where -  pprintTidy _ = Misc.tshow +instance Show a => PPrint (Trie a) where+  pprintTidy _ = Misc.tshow  -{- +{-       e1         <----@@ -108,14 +108,14 @@  as the `trie` -     1 -> 2 -----------> A +     1 -> 2 -----------> A            `-> 3 -> 4 -> B      |         ` -> 5 -> C      `-> 6 ------------> D  -} --- >>> _example0 == _example1 +-- >>> _example0 == _example1 -- True  _example0 :: Trie Char@@ -126,7 +126,7 @@     n3   = Node [Bind 4 n4, Bind 5 n5]     n4   = Node [Val 'B']     n5   = Node [Val 'C']-    n6   = Node [Val 'D'] +    n6   = Node [Val 'D']   _example1 :: Trie Char

− stack.yaml

@@ -1,20 +0,0 @@--resolver: lts-18.14-compiler: ghc-8.10.7-# compiler: ghc-8.8.4-# compiler: ghc-8.6.5-allow-newer: true--# resolver: lts-14.0--flags:-  liquid-fixpoint:-    devel: true --packages:-- '.'---extra-deps:-- hashable-1.3.0.0-- rest-rewrite-0.1.1

− tests/crash/EqConstr0.fq

@@ -1,9 +0,0 @@- -bind 1 x : {v: int | true } -bind 2 y : {v: a   | true } --constraint:  -  env [1; 2]-  lhs {v: int | x = y }-  rhs {v: Int | y = x }-  id 1 tag []

− tests/crash/EqConstr1.fq

@@ -1,12 +0,0 @@-data Thing 0 = [-  | mkCons { head : int } -]-  -bind 1 x : {v: Thing | true } -bind 2 y : {v: a     | true } --constraint:  -  env [1; 2]-  lhs {v: int | x = y }-  rhs {v: Int | y = x }-  id 1 tag []

− tests/crash/num00.fq

@@ -1,29 +0,0 @@-// This qualifier saves the day; solve constraints WITHOUT IT--qualif Zog(v:a) : (0 <= v)-qualif Bog(v:a) : (0 <= 1)---bind 0 zog : {v : int | true}--constraint:-  env [0]-  lhs {v : alpha | (v = 10)}-  rhs {v : alpha | $k0}-  id 1 tag []--constraint:-  env [0]-  lhs {v : alpha | $k0}-  rhs {v : alpha | $k0}-  id 2 tag []--constraint:-  env [0]-  lhs {v : alpha | $k0}-  rhs {v : alpha | 0 <= v}-  id 3 tag []--wf:-  env [0]-  reft {v: alpha | $k0}

− tests/crash/sort00.fq

@@ -1,12 +0,0 @@-// for LH Issue 773--constant foo : (func(0, [int; int]))--bind 0 x     : {v: Str | true}--constraint:-  env [ 0 ]-  lhs {v : int | (foo x = 0)}-  rhs {v : int | (3 = 1 + 2) }-  id 1 tag []-

− tests/crash/sort01.fq

@@ -1,13 +0,0 @@-// for LH Issue 774--constant foo : (func(0, [int; int]))--bind 0 x     : {v: Str | true}-bind 1 y     : {v: Str | true}--constraint:-  env [ 0; 1 ]-  lhs {v : int | (foo x = foo y)}-  rhs {v : int | (3 = 1 + 2) }-  id 1 tag []-

− tests/cut/test00-tx.fq

@@ -1,12 +0,0 @@---// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 a : {v:int | (v = 10 || v = 20) }--constraint:-  env [ 0 ]-  lhs {v : int | v = a}-  rhs {v : int | 10 <= v}-  id 3

− tests/cut/test00.fq

@@ -1,28 +0,0 @@---// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 a : {v: int | $k0}--constraint:-  env [ ]-  lhs {v : int | (v = 10)}-  rhs {v : int | $k0}-  id 1 --constraint:-  env [ ]-  lhs {v : int | v = 20}-  rhs {v : int | $k0}-  id 2 --constraint:-  env [ 0 ]-  lhs {v : int | v = a}-  rhs {v : int | 10 <= v}-  id 3 --wf:-  env [ ]-  reft {v: int | $k0}

− tests/cut/test00a-tx.fq

@@ -1,43 +0,0 @@-// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--constraint:-  env [z : {v : int | true}]-  lhs {v : int | (z=10) \/ (z=20)}-  rhs {v : int | 10 <= z}-  id 3 --/*--Rewriting constraints as:--    id 1-    x:int, v:int |- x=10 /\ v=x => k0-    -    id 2-    y:int, v:int |- y=20 /\ v=y => k0--Projecting out all variables NOT in the WF of k0--    id 1-    v:int |- (exists x:int. x=10 /\ v=x) => k0-           -    id 2-    v:int |- (exists y:int. y=20 /\ v=y) => k0--Take the \/ of all constraints on k0--     k0 = (exists x:int. x=10 /\ v=x) \/ (exists y:int. y=20 /\ v=y)-     -     k0[z/v]-       = (\x. x=10 /\ v=x) \/ (\y. y=20 /\ v=y)[z/v]-         = (\x. x=10 /\ z=x) \/ (\y. y=20 /\ z=y)--So you get:--     env [2]-        lhs {v : int | (\x. x=10 /\ z=x) \/ (\y. y=20 /\ z=y)}-     rhs {v : int | 10 <= z}-     id 3 --*/

− tests/cut/test00a.fq

@@ -1,29 +0,0 @@-// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 x : {v : int | true}-bind 1 y : {v : int | true}-bind 2 z : {v : int | true}--constraint:-  env [0]-  lhs {v : int | (x = 10)}-  rhs {v : int | $k0[v:=x]}-  id 1 --constraint:-  env [1]-  lhs {v : int | y = 20}-  rhs {v : int | $k0[v:=y]}-  id 2 --constraint:-  env [2]-  lhs {v : int | $k0[v:=z]}-  rhs {v : int | 10 <= z}-  id 3 --wf:-  env [ ]-  reft {v: int | $k0}-

− tests/cut/test1-tx.fq

@@ -1,43 +0,0 @@--// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--constraint:-  env [a : {v : int | (exists x:int. x=10 /\ v=x) -                   \/ (exists y:int. y=20 /\ v=y) }]-  lhs {v : int | v = a  }-  rhs {v : int | 10 <= v}-  id 3 --/*--Rewriting constraints as:--    id 1-    x:int, v:int |- (v=10)[x/v] /\ (v=x) => k0-    x:int, v:int |- (x=10) /\ (v=x) => k0--    id 2-    y:int, v:int |- (v=20)[y/v] /\ (v=y) => k0-    y:int, v:int |- (y=20) /\ (v=y) => k0--Projecting out all variables NOT in the WF of k0--    id 1-    v:int |- (exists x:int. x=10 /\ v=x) => k0--    id 2-    v:int |- (exists y:int. y=20 /\ v=y) => k0--Take the \/ of all constraints on k0--    k0 = (exists x:int. x=10 /\ v=x) \/ (exists y:int. y=20 /\ v=y)-     -So you get:--    env [a : {v : int | (exists x:int. x=10 /\ v=x) \/ (exists y:int. y=20 /\ v=y) }]-      lhs {v : int | v = a  }-    rhs {v : int | 10 <= v}-    id 3--*/

− tests/cut/test1.fq

@@ -1,29 +0,0 @@--// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 x : {v : int | v = 10}-bind 1 y : {v : int | v = 20}-bind 2 a : {v : int | $k0    }-      -constraint:-  env [0]-  lhs {v : int | v = x}-  rhs {v : int | $k0   }-  id 1 --constraint:-  env [1]-  lhs {v : int | v = y}-  rhs {v : int | $k0   }-  id 2 --constraint:-  env [2]-  lhs {v : int | v = a  }-  rhs {v : int | 10 <= v}-  id 3 --wf:-  env [ ]-  reft {v : int | $k0}

− tests/cut/test2-tx.fq

@@ -1,112 +0,0 @@--// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a): (10 <= v)--// But you may use this one-qualif Pog(v:a): (0 <= v)-----/* ---- Version 1 (eliminate k1) ----Rewriting constraints as:--    id 0-    v:int |- (v=0) => k1--    id 3-    v:int |- k0 => k1--Projecting out all variables NOT in the WF of k1--    N/A--Take the \/ of all constraints on k1--    k1 = (v=0) \/ k0--So you get:--  bind 0 x: {v: int | v = 10      }-  bind 1 a: {v: int | (v=0) \/ k0 }-  bind 2 y: {v: int | v = 20      }-  bind 3 b: {v: int | (v=0) \/ k0 }-  bind 4 c: {v: int | k0          }--  constraint:-    env [ 0; 1]-      lhs {v : int | v = x + a}-    rhs {v : int | k0}-    id 1 --  constraint:-    env [2; 3]-      lhs {v : int | v = y + b}-    rhs {v : int | k0}-    id 2 --  constraint:-    env [4]-      lhs {v : int | v = c  }-    rhs {v : int | 10 <= v}-    id 4 --  wf:-    env [ ]-    reft {v: int | k1}------- Version 2 (eliminate k0) ----Rewriting constraints as:--    id 1-    x:int, a:int, v:int |- (v=10)[x/v] /\ k1[a/v] /\ (v=x+a) => k0-    x:int, a:int, v:int |- (x=10) /\ k1[a/v] /\ (v=x+a) => k0--    id 2-    y:int, b:int, v:int |- (v=20)[y/v] /\ k1[b/v] /\ (v=y+b) => k0-    y:int, b:int, v:int |- (y=20) /\ k1[b/v] /\ (v=y+b) => k0--Projecting out all variables NOT in the WF of k0--    id 1-    v:int |- (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a)) => k0-    -    id 2-    v:int |- (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b)) => k0--Take the \/ of all constraints on k0--    k0 = (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a))-      \/ (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b))--So you get:--  bind 4 c: {v: int | (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a))-                   \/ (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b))    }--  constraint:-    env [ ]-      lhs {v : int | v = 0}-    rhs {v : int | k1 }-    id 0 ---  constraint:-    env [ ]-      lhs {v : int | (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a))-                \/ (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b))}-    rhs {v : int | k1}-    id 3--  constraint:-    env [4]-      lhs {v : int | v = c  }-    rhs {v : int | 10 <= v}-    id 4

− tests/cut/test2.fq

@@ -1,51 +0,0 @@--// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a): (10 <= v)--// But you may use this one-qualif Pog(v:a): (0 <= v)--bind 0 x: {v: int | v = 10}-bind 1 a: {v: int | $k1    }-bind 2 y: {v: int | v = 20}-bind 3 b: {v: int | $k1    }-bind 4 c: {v: int | $k0    }--constraint:-  env [ ]-  lhs {v : int | v = 0}-  rhs {v : int | $k1 }-  id 0 ---constraint:-  env [ 0; 1]-  lhs {v : int | v = x + a}-  rhs {v : int | $k0}-  id 1 --constraint:-  env [2; 3]-  lhs {v : int | v = y + b}-  rhs {v : int | $k0}-  id 2 --constraint:-  env [ ]-  lhs {v : int | $k0}-  rhs {v : int | $k1}-  id 3--constraint:-  env [4]-  lhs {v : int | v = c  }-  rhs {v : int | 10 <= v}-  id 4 --wf:-  env [ ]-  reft {v: int | $k0}--wf:-  env [ ]-  reft {v: int | $k1}

− tests/elim/div00.fq

@@ -1,23 +0,0 @@--// --eliminate should be able to solve this WITHOUT the qualifier-// qualif Zog(v:int) : (v /= 0)--bind 0 n : {v: int | true }-bind 1 m : {v: int | true }-bind 2 z : {v: int | $k0[n := m] }--constraint:-  env [ ]-  lhs {v : int | v = 12 }-  rhs {v : int | $k0    }-  id 1 tag []--constraint:-  env [ 1; 2 ]-  lhs {v : int | v  = z}-  rhs {v : int | v /= 0}-  id 2 tag []--wf:-  env [ 0 ]-  reft {v: int | $k0 }

− tests/elim/elim00.fq

@@ -1,1494 +0,0 @@-fixpoint "--defunct"--// qualif Cmp(v : @(0), x : @(0)): ((v > x)) // "tests/todo/elim00.hs.fq" (line 1, column 8)-// qualif Cmp(v : @(0), x : @(0)): ((v = x)) // "tests/todo/elim00.hs.fq" (line 2, column 8)---constant Control.Exception.Base.irrefutPatError##09 : (func(1, [int;-                                                                @(0)]))-constant GHC.Base..##r2C : (func(3, [func(0, [@(0); @(1)]);-                                     func(0, [@(2); @(0)]);-                                     @(2);-                                     @(1)]))-constant runFun : (func(2, [(Arrow  @(0)  @(1)); @(0); @(1)]))-constant GHC.Tuple.$40$$44$$44$$41$$35$$35$76 : (func(3, [@(0);-                                                          @(1);-                                                          @(2);-                                                          (Tuple  @(0)  @(1)  @(2))]))-constant GHC.Real.D$58$Integral$35$$35$rWH : (func(1, [func(0, [@(0);-                                                                @(0);-                                                                @(0)]);-                                                       func(0, [@(0); @(0); @(0)]);-                                                       func(0, [@(0); @(0); @(0)]);-                                                       func(0, [@(0); @(0); @(0)]);-                                                       func(0, [@(0); @(0); (Tuple  @(0)  @(0))]);-                                                       func(0, [@(0); @(0); (Tuple  @(0)  @(0))]);-                                                       func(0, [@(0); int]);-                                                       (GHC.Real.Integral  @(0))]))-constant addrLen : (func(0, [int; int]))-constant papp5 : (func(10, [(Pred  @(0)  @(1)  @(2)  @(3)  @(4));-                            @(5);-                            @(6);-                            @(7);-                            @(8);-                            @(9);-                            bool]))-constant xsListSelector : (func(1, [[@(0)]; [@(0)]]))-constant x_Tuple21 : (func(2, [(Tuple  @(0)  @(1)); @(0)]))-constant x_Tuple65 : (func(6, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5));-                               @(4)]))-constant Elim.foo##rlD : (func(0, [Elim.Foo; Elim.Foo]))-constant x_Tuple55 : (func(5, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4));-                               @(4)]))-constant GHC.Integer.Type.smallInteger##0Z : (func(0, [int; int]))-constant x_Tuple33 : (func(3, [(Tuple  @(0)  @(1)  @(2)); @(2)]))-constant x_Tuple77 : (func(7, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                               @(6)]))-constant GHC.Base.Just##r1e : (func(1, [@(0);-                                        (GHC.Base.Maybe  @(0))]))-constant Elim.xx##rlB : (func(0, [Elim.Foo; int]))-constant papp3 : (func(6, [(Pred  @(0)  @(1)  @(2));-                           @(3);-                           @(4);-                           @(5);-                           bool]))-constant GHC.Prim.$43$$35$$35$$35$98 : (func(0, [int; int; int]))-constant x_Tuple63 : (func(6, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5));-                               @(2)]))-constant x_Tuple41 : (func(4, [(Tuple  @(0)  @(1)  @(2)  @(3));-                               @(0)]))-constant GHC.Types.LT##6S : (GHC.Types.Ordering)-constant GHC.Prim.$60$$35$$35$$35$9q : (func(0, [int; int; int]))-constant papp4 : (func(8, [(Pred  @(0)  @(1)  @(2)  @(3));-                           @(4);-                           @(5);-                           @(6);-                           @(7);-                           bool]))-constant Elim.PP##rlx : (func(2, [@(0);-                                  @(1);-                                  (Elim.Pair  @(0)  @(1))]))-constant x_Tuple64 : (func(6, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5));-                               @(3)]))-constant GHC.Types.GT##6W : (GHC.Types.Ordering)-constant GHC.Prim.$45$$35$$35$$35$99 : (func(0, [int; int; int]))-constant GHC.Types.$58$$35$$35$64 : (func(1, [@(0);-                                              [@(0)];-                                              [@(0)]]))-constant autolen : (func(1, [@(0); int]))-constant GHC.Types.I###6c : (func(0, [int; int]))-constant x_Tuple52 : (func(5, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4));-                               @(1)]))-constant xx : (func(0, [Elim.Foo; int]))-constant null : (func(1, [[@(0)]; bool]))-constant GHC.Num.$43$$35$$35$rt : (func(1, [@(0); @(0); @(0)]))-constant GHC.Tuple.$40$$44$$44$$44$$44$$41$$35$$35$7a : (func(5, [@(0);-                                                                  @(1);-                                                                  @(2);-                                                                  @(3);-                                                                  @(4);-                                                                  (Tuple  @(0)  @(1)  @(2)  @(3)  @(4))]))-constant papp2 : (func(4, [(Pred  @(0)  @(1)); @(2); @(3); bool]))-constant x_Tuple62 : (func(6, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5));-                               @(1)]))-constant GHC.Tuple.$40$$44$$41$$35$$35$74 : (func(2, [@(0);-                                                      @(1);-                                                      (Tuple  @(0)  @(1))]))-constant Elim.yy##rlC : (func(0, [Elim.Foo; int]))-constant fromJust : (func(1, [(GHC.Base.Maybe  @(0)); @(0)]))-constant papp7 : (func(14, [(Pred  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                            @(7);-                            @(8);-                            @(9);-                            @(10);-                            @(11);-                            @(12);-                            @(13);-                            bool]))-constant x_Tuple53 : (func(5, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4));-                               @(2)]))-constant x_Tuple71 : (func(7, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                               @(0)]))-constant GHC.Prim.$62$$35$$35$$35$9m : (func(0, [int; int; int]))-constant x_Tuple74 : (func(7, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                               @(3)]))-constant Elim.Emp##rly : (func(2, [(Elim.Pair  @(0)  @(1))]))-constant len : (func(2, [(@(0)  @(1)); int]))-constant GHC.Tuple.$40$$44$$44$$44$$44$$44$$44$$41$$35$$35$7e : (func(7, [@(0);-                                                                          @(1);-                                                                          @(2);-                                                                          @(3);-                                                                          @(4);-                                                                          @(5);-                                                                          @(6);-                                                                          (Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6))]))-constant papp6 : (func(12, [(Pred  @(0)  @(1)  @(2)  @(3)  @(4)  @(5));-                            @(6);-                            @(7);-                            @(8);-                            @(9);-                            @(10);-                            @(11);-                            bool]))-constant x_Tuple22 : (func(2, [(Tuple  @(0)  @(1)); @(1)]))-constant Data.Foldable.length##r1s : (func(2, [(@(0)  @(0)); int]))-constant x_Tuple66 : (func(6, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5));-                               @(5)]))-constant x_Tuple44 : (func(4, [(Tuple  @(0)  @(1)  @(2)  @(3));-                               @(3)]))-constant xListSelector : (func(1, [[@(0)]; @(0)]))-constant strLen : (func(0, [int; int]))-constant x_Tuple72 : (func(7, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                               @(1)]))-constant GHC.Tuple.$40$$44$$44$$44$$41$$35$$35$78 : (func(4, [@(0);-                                                              @(1);-                                                              @(2);-                                                              @(3);-                                                              (Tuple  @(0)  @(1)  @(2)  @(3))]))-constant isJust : (func(1, [(GHC.Base.Maybe  @(0)); bool]))-constant GHC.Prim.$61$$61$$35$$35$$35$9o : (func(0, [int;-                                                     int;-                                                     int]))-constant Elim.Foo##rlA : (func(0, [int; int; Elim.Foo]))-constant Prop : (func(0, [GHC.Types.Bool; bool]))-constant x_Tuple31 : (func(3, [(Tuple  @(0)  @(1)  @(2)); @(0)]))-constant x_Tuple75 : (func(7, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                               @(4)]))-constant papp1 : (func(2, [(Pred  @(0)); @(1); bool]))-constant yy : (func(0, [Elim.Foo; int]))-constant x_Tuple61 : (func(6, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5));-                               @(0)]))-constant GHC.Prim.$62$$61$$35$$35$$35$9n : (func(0, [int;-                                                     int;-                                                     int]))-constant lit$36$tests$47$pos$47$elim00.hs$58$14$58$5$45$30$124$PP$32$wink$32$cow : (Str)-constant x_Tuple43 : (func(4, [(Tuple  @(0)  @(1)  @(2)  @(3));-                               @(2)]))-constant GHC.Types.EQ##6U : (GHC.Types.Ordering)-constant x_Tuple51 : (func(5, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4));-                               @(0)]))-constant GHC.Base.Nothing##r1d : (func(1, [(GHC.Base.Maybe  @(0))]))-constant GHC.Num.$45$$35$$35$02B : (func(1, [@(0); @(0); @(0)]))-constant GHC.Num.$42$$35$$35$ru : (func(1, [@(0); @(0); @(0)]))-constant x_Tuple73 : (func(7, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                               @(2)]))-constant GHC.Types.$91$$93$$35$$35$6m : (func(1, [[@(0)]]))-constant x_Tuple54 : (func(5, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4));-                               @(3)]))-constant cmp : (func(0, [GHC.Types.Ordering; GHC.Types.Ordering]))-constant x_Tuple32 : (func(3, [(Tuple  @(0)  @(1)  @(2)); @(1)]))-constant x_Tuple76 : (func(7, [(Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5)  @(6));-                               @(5)]))-constant GHC.Prim.$60$$61$$35$$35$$35$9r : (func(0, [int;-                                                     int;-                                                     int]))-constant GHC.Real.D$58$Fractional$35$$35$rVU : (func(1, [func(0, [@(0);-                                                                  @(0);-                                                                  @(0)]);-                                                         func(0, [@(0); @(0)]);-                                                         func(0, [(GHC.Real.Ratio  int); @(0)]);-                                                         (GHC.Real.Fractional  @(0))]))-constant fst : (func(2, [(Tuple  @(0)  @(1)); @(0)]))-constant snd : (func(2, [(Tuple  @(0)  @(1)); @(1)]))-constant GHC.Tuple.$40$$44$$44$$44$$44$$44$$41$$35$$35$7c : (func(6, [@(0);-                                                                      @(1);-                                                                      @(2);-                                                                      @(3);-                                                                      @(4);-                                                                      @(5);-                                                                      (Tuple  @(0)  @(1)  @(2)  @(3)  @(4)  @(5))]))-constant x_Tuple42 : (func(4, [(Tuple  @(0)  @(1)  @(2)  @(3));-                               @(1)]))-constant GHC.Prim.void###0l : (GHC.Prim.Void#)---bind 0 GHC.Prim.void###0l : {VV##180 : GHC.Prim.Void# | []}-bind 1 Elim.Emp##rly : {VV : func(2, [(Elim.Pair  @(0)  @(1))]) | []}-bind 2 GHC.Types.EQ##6U : {VV##185 : GHC.Types.Ordering | [(VV##185 = GHC.Types.EQ##6U)]}-bind 3 GHC.Types.LT##6S : {VV##186 : GHC.Types.Ordering | [(VV##186 = GHC.Types.LT##6S)]}-bind 4 GHC.Types.GT##6W : {VV##187 : GHC.Types.Ordering | [(VV##187 = GHC.Types.GT##6W)]}-bind 5 Elim.Emp##rly : {VV : func(2, [(Elim.Pair  @(0)  @(1))]) | []}-bind 6 GHC.Types.$91$$93$$35$$35$6m : {VV : func(1, [[@(0)]]) | []}-bind 7 GHC.Types.GT##6W : {VV##213 : GHC.Types.Ordering | [((cmp VV##213) = GHC.Types.GT##6W)]}-bind 8 GHC.Types.LT##6S : {VV##214 : GHC.Types.Ordering | [((cmp VV##214) = GHC.Types.LT##6S)]}-bind 9 GHC.Types.EQ##6U : {VV##215 : GHC.Types.Ordering | [((cmp VV##215) = GHC.Types.EQ##6U)]}-bind 10 GHC.Base.Nothing##r1d : {VV : func(1, [(GHC.Base.Maybe  @(0))]) | []}-bind 11 ds_dxd : {VV##222 : Elim.Foo | []}-bind 12 lq_anf$##dxr : {lq_tmp$x##223 : Elim.Foo | [(lq_tmp$x##223 = ds_dxd)]}-bind 13 lq_anf$##dxr : {lq_tmp$x##225 : Elim.Foo | [(lq_tmp$x##225 = ds_dxd)]}-bind 14 xig##awy : {lq_tmp$x##233 : int | []}-bind 15 yog##awz : {lq_tmp$x##234 : int | [(xig##awy < lq_tmp$x##234)]}-bind 16 lq_anf$##dxr : {lq_tmp$x##225 : Elim.Foo | [(lq_tmp$x##225 = ds_dxd);-                                                    ((yy lq_tmp$x##225) = yog##awz);-                                                    ((xx lq_tmp$x##225) = xig##awy);-                                                    (lq_tmp$x##225 = (Elim.Foo##rlA xig##awy yog##awz));-                                                    ((yy lq_tmp$x##225) = yog##awz);-                                                    ((xx lq_tmp$x##225) = xig##awy)]}-bind 17 lq_anf$##dxs : {lq_tmp$x##242 : (Elim.Pair  int  int) | [(lq_tmp$x##242 = (Elim.PP##rlx xig##awy yog##awz))]}-bind 18 lq_anf$##dxt : {lq_tmp$x##273 : (Elim.Pair  int  int) | [(lq_tmp$x##273 = lq_anf$##dxs)]}-bind 19 lq_anf$##dxt : {lq_tmp$x##277 : (Elim.Pair  int  int) | [(lq_tmp$x##277 = lq_anf$##dxs)]}-bind 20 wink##ax3 : {lq_tmp$x##275 : int | [$k_##248[lq_tmp$x##277:=lq_anf$##dxt][VV##247:=lq_tmp$x##275][lq_tmp$x##242:=lq_anf$##dxt][lq_tmp$x##271:=lq_tmp$x##275][lq_tmp$x##273:=lq_anf$##dxt][lq_tmp$x##245:=xig##awy][lq_tmp$x##246:=yog##awz][lq_tmp$x##250:=lq_tmp$x##275]]}-bind 21 cow##ax4 : {lq_tmp$x##276 : int | [$k_##252[lq_tmp$x##277:=lq_anf$##dxt][lq_tmp$x##281:=wink##ax3][VV##251:=lq_tmp$x##276][lq_tmp$x##242:=lq_anf$##dxt][lq_tmp$x##254:=lq_tmp$x##276][lq_tmp$x##273:=lq_anf$##dxt][lq_tmp$x##245:=xig##awy][lq_tmp$x##246:=yog##awz][lq_tmp$x##272:=lq_tmp$x##276]]}-bind 22 lq_anf$##dxt : {lq_tmp$x##277 : (Elim.Pair  int  int) | [(lq_tmp$x##277 = lq_anf$##dxs);-                                                                 (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4));-                                                                 (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4));-                                                                 (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4))]}-bind 23 lq_tmp$x##307 : {VV##308 : int | []}-bind 24 lq_anf$##dxt : {lq_tmp$x##313 : (Elim.Pair  int  int) | [(lq_tmp$x##313 = lq_anf$##dxs)]}-bind 25 lq_anf$##dxt : {lq_tmp$x##313 : (Elim.Pair  int  int) | [(lq_tmp$x##313 = lq_anf$##dxs);-                                                                 (lq_tmp$x##313 = Elim.Emp##rly);-                                                                 (lq_tmp$x##313 = Elim.Emp##rly);-                                                                 (lq_tmp$x##313 = Elim.Emp##rly)]}-bind 26 ds_dxg : {VV##318 : GHC.Prim.Void# | [$k_##319]}-bind 27 lq_anf$##dxu : {lq_tmp$x##335 : int | [(lq_tmp$x##335 ~~ lit$36$tests$47$pos$47$elim00.hs$58$14$58$5$45$30$124$PP$32$wink$32$cow);-                                               ((strLen lq_tmp$x##335) = 39)]}-bind 28 ds_dxh : {VV##268 : (Tuple  int  int) | [$k_##269]}-bind 29 lq_anf$##dxw : {lq_tmp$x##368 : (Tuple  int  int) | [(lq_tmp$x##368 = ds_dxh)]}-bind 30 lq_anf$##dxw : {lq_tmp$x##374 : (Tuple  int  int) | [(lq_tmp$x##374 = ds_dxh)]}-bind 31 wink##ax3 : {lq_tmp$x##370 : int | [$k_##259[lq_tmp$x##368:=lq_anf$##dxw][VV##268:=lq_anf$##dxw][lq_tmp$x##364:=lq_tmp$x##370][VV##258:=lq_tmp$x##370][lq_tmp$x##374:=lq_anf$##dxw]]}-bind 32 cow##Xxd : {lq_tmp$x##371 : int | [$k_##262[lq_tmp$x##368:=lq_anf$##dxw][VV##268:=lq_anf$##dxw][VV##261:=lq_tmp$x##371][lq_tmp$x##365:=lq_tmp$x##371][lq_tmp$x##379:=wink##ax3][lq_tmp$x##374:=lq_anf$##dxw];-                                           $k_##266[lq_tmp$x##368:=lq_anf$##dxw][lq_tmp$x##373:=lq_tmp$x##371][VV##265:=lq_tmp$x##371][lq_tmp$x##264:=wink##ax3][lq_tmp$x##367:=lq_tmp$x##371][VV##268:=lq_anf$##dxw][lq_tmp$x##372:=wink##ax3][lq_tmp$x##366:=wink##ax3][lq_tmp$x##379:=wink##ax3][lq_tmp$x##374:=lq_anf$##dxw]]}-bind 33 lq_anf$##dxw : {lq_tmp$x##374 : (Tuple  int  int) | [(lq_tmp$x##374 = ds_dxh);-                                                             ((snd lq_tmp$x##374) = cow##Xxd);-                                                             ((fst lq_tmp$x##374) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##374) = cow##Xxd);-                                                             ((x_Tuple21 lq_tmp$x##374) = wink##ax3);-                                                             (lq_tmp$x##374 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##Xxd));-                                                             ((snd lq_tmp$x##374) = cow##Xxd);-                                                             ((fst lq_tmp$x##374) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##374) = cow##Xxd);-                                                             ((x_Tuple21 lq_tmp$x##374) = wink##ax3)]}-bind 34 wink##ax3 : {VV##361 : int | [$k_##362]}-// bind 45 wink##ax3 : {lq_tmp$x##452 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][VV##427:=lq_tmp$x##452][lq_tmp$x##426:=cow##ax4][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##430:=lq_tmp$x##452][lq_tmp$x##446:=lq_tmp$x##452][lq_tmp$x##422:=lq_anf$##dxy]]}--bind 35 lq_anf$##dxv : {lq_tmp$x##398 : (Tuple  int  int) | [(lq_tmp$x##398 = ds_dxh)]}-bind 36 lq_anf$##dxv : {lq_tmp$x##404 : (Tuple  int  int) | [(lq_tmp$x##404 = ds_dxh)]}-bind 37 wink##ax3 : {lq_tmp$x##400 : int | [$k_##259[VV##268:=lq_anf$##dxv][lq_tmp$x##394:=lq_tmp$x##400][VV##258:=lq_tmp$x##400][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##404:=lq_anf$##dxv]]}-bind 38 cow##ax4 : {lq_tmp$x##401 : int | [$k_##262[VV##268:=lq_anf$##dxv][VV##261:=lq_tmp$x##401][lq_tmp$x##409:=wink##ax3][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##395:=lq_tmp$x##401][lq_tmp$x##404:=lq_anf$##dxv];-                                           $k_##266[lq_tmp$x##396:=wink##ax3][VV##265:=lq_tmp$x##401][lq_tmp$x##264:=wink##ax3][VV##268:=lq_anf$##dxv][lq_tmp$x##397:=lq_tmp$x##401][lq_tmp$x##409:=wink##ax3][lq_tmp$x##403:=lq_tmp$x##401][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##402:=wink##ax3][lq_tmp$x##404:=lq_anf$##dxv]]}-bind 39 lq_anf$##dxv : {lq_tmp$x##404 : (Tuple  int  int) | [(lq_tmp$x##404 = ds_dxh);-                                                             ((snd lq_tmp$x##404) = cow##ax4);-                                                             ((fst lq_tmp$x##404) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##404) = cow##ax4);-                                                             ((x_Tuple21 lq_tmp$x##404) = wink##ax3);-                                                             (lq_tmp$x##404 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4));-                                                             ((snd lq_tmp$x##404) = cow##ax4);-                                                             ((fst lq_tmp$x##404) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##404) = cow##ax4);-                                                             ((x_Tuple21 lq_tmp$x##404) = wink##ax3)]}-bind 40 cow##ax4 : {VV##391 : int | [$k_##392]}-bind 41 lq_tmp$x##438 : {VV##439 : int | []}-bind 42 ds_dxi : {lq_tmp$x##422 : (Tuple  int  int) | [((snd lq_tmp$x##422) = cow##ax4);-                                                       ((fst lq_tmp$x##422) = wink##ax3);-                                                       ((x_Tuple22 lq_tmp$x##422) = cow##ax4);-                                                       ((x_Tuple21 lq_tmp$x##422) = wink##ax3)]}-bind 43 lq_anf$##dxy : {lq_tmp$x##450 : (Tuple  int  int) | [(lq_tmp$x##450 = ds_dxi)]}-bind 44 lq_anf$##dxy : {lq_tmp$x##456 : (Tuple  int  int) | [(lq_tmp$x##456 = ds_dxi)]}-bind 45 wink##ax3 : {lq_tmp$x##452 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][VV##427:=lq_tmp$x##452][lq_tmp$x##426:=cow##ax4][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##430:=lq_tmp$x##452][lq_tmp$x##446:=lq_tmp$x##452][lq_tmp$x##422:=lq_anf$##dxy]]}-bind 46 cow##ax4 : {lq_tmp$x##453 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][lq_tmp$x##426:=cow##ax4][VV##431:=lq_tmp$x##453][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##447:=lq_tmp$x##453][lq_tmp$x##461:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxy][lq_tmp$x##434:=lq_tmp$x##453];-                                           $k_##436[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][lq_tmp$x##426:=cow##ax4][lq_tmp$x##455:=lq_tmp$x##453][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##461:=wink##ax3][lq_tmp$x##438:=wink##ax3][lq_tmp$x##421:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxy][lq_tmp$x##434:=lq_tmp$x##453][lq_tmp$x##448:=wink##ax3][lq_tmp$x##449:=lq_tmp$x##453][VV##435:=lq_tmp$x##453][lq_tmp$x##454:=wink##ax3]]}-bind 47 lq_anf$##dxy : {lq_tmp$x##456 : (Tuple  int  int) | [(lq_tmp$x##456 = ds_dxi);-                                                             ((snd lq_tmp$x##456) = cow##ax4);-                                                             ((fst lq_tmp$x##456) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##456) = cow##ax4);-                                                             ((x_Tuple21 lq_tmp$x##456) = wink##ax3);-                                                             (lq_tmp$x##456 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4));-                                                             ((snd lq_tmp$x##456) = cow##ax4);-                                                             ((fst lq_tmp$x##456) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##456) = cow##ax4);-                                                             ((x_Tuple21 lq_tmp$x##456) = wink##ax3)]}-bind 48 wink##awA : {VV##443 : int | [$k_##444]}--bind 49 lq_anf$##dxx : {lq_tmp$x##480 : (Tuple  int  int) | [(lq_tmp$x##480 = ds_dxi)]}-bind 50 lq_anf$##dxx : {lq_tmp$x##486 : (Tuple  int  int) | [(lq_tmp$x##486 = ds_dxi)]}-bind 51 wink##ax3 : {lq_tmp$x##482 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][VV##427:=lq_tmp$x##482][lq_tmp$x##426:=cow##ax4][lq_tmp$x##476:=lq_tmp$x##482][lq_tmp$x##430:=lq_tmp$x##482][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##486:=lq_anf$##dxx]]}-bind 52 cow##ax4 : {lq_tmp$x##483 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][lq_tmp$x##426:=cow##ax4][VV##431:=lq_tmp$x##483][lq_tmp$x##491:=wink##ax3][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##477:=lq_tmp$x##483][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##434:=lq_tmp$x##483][lq_tmp$x##486:=lq_anf$##dxx];-                                           $k_##436[lq_tmp$x##425:=wink##ax3][lq_tmp$x##426:=cow##ax4][lq_tmp$x##491:=wink##ax3][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##479:=lq_tmp$x##483][lq_tmp$x##485:=lq_tmp$x##483][lq_tmp$x##438:=wink##ax3][lq_tmp$x##421:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##434:=lq_tmp$x##483][lq_tmp$x##484:=wink##ax3][lq_tmp$x##478:=wink##ax3][lq_tmp$x##486:=lq_anf$##dxx][VV##435:=lq_tmp$x##483]]}-bind 53 lq_anf$##dxx : {lq_tmp$x##486 : (Tuple  int  int) | [(lq_tmp$x##486 = ds_dxi);-                                                             ((snd lq_tmp$x##486) = cow##ax4);-                                                             ((fst lq_tmp$x##486) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##486) = cow##ax4);-                                                             ((x_Tuple21 lq_tmp$x##486) = wink##ax3);-                                                             (lq_tmp$x##486 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4));-                                                             ((snd lq_tmp$x##486) = cow##ax4);-                                                             ((fst lq_tmp$x##486) = wink##ax3);-                                                             ((x_Tuple22 lq_tmp$x##486) = cow##ax4);-                                                             ((x_Tuple21 lq_tmp$x##486) = wink##ax3)]}-bind 54 cow##awB : {VV##473 : int | [$k_##474]}-bind 55 ds_dxo : {VV##514 : Elim.Foo | []}-bind 56 lq_anf$##dxz : {lq_tmp$x##515 : Elim.Foo | [(lq_tmp$x##515 = ds_dxo)]}-bind 57 lq_anf$##dxz : {lq_tmp$x##517 : Elim.Foo | [(lq_tmp$x##517 = ds_dxo)]}-bind 58 ds_dxp : {lq_tmp$x##525 : int | []}-bind 59 ds_dxq : {lq_tmp$x##526 : int | [(ds_dxp < lq_tmp$x##526)]}-bind 60 lq_anf$##dxz : {lq_tmp$x##517 : Elim.Foo | [(lq_tmp$x##517 = ds_dxo);-                                                    ((yy lq_tmp$x##517) = ds_dxq);-                                                    ((xx lq_tmp$x##517) = ds_dxp);-                                                    (lq_tmp$x##517 = (Elim.Foo##rlA ds_dxp ds_dxq));-                                                    ((yy lq_tmp$x##517) = ds_dxq);-                                                    ((xx lq_tmp$x##517) = ds_dxp)]}-bind 61 ds_dxl : {VV##537 : Elim.Foo | []}-bind 62 lq_anf$##dxA : {lq_tmp$x##538 : Elim.Foo | [(lq_tmp$x##538 = ds_dxl)]}-bind 63 lq_anf$##dxA : {lq_tmp$x##540 : Elim.Foo | [(lq_tmp$x##540 = ds_dxl)]}-bind 64 ds_dxm : {lq_tmp$x##548 : int | []}-bind 65 ds_dxn : {lq_tmp$x##549 : int | [(ds_dxm < lq_tmp$x##549)]}-bind 66 lq_anf$##dxA : {lq_tmp$x##540 : Elim.Foo | [(lq_tmp$x##540 = ds_dxl);-                                                    ((yy lq_tmp$x##540) = ds_dxn);-                                                    ((xx lq_tmp$x##540) = ds_dxm);-                                                    (lq_tmp$x##540 = (Elim.Foo##rlA ds_dxm ds_dxn));-                                                    ((yy lq_tmp$x##540) = ds_dxn);-                                                    ((xx lq_tmp$x##540) = ds_dxm)]}-bind 67 VV##559 : {VV##559 : int | [(VV##559 = ds_dxm)]}-bind 68 VV##561 : {VV##561 : int | [(VV##561 = ds_dxq)]}-bind 69 VV##563 : {VV##563 : Elim.Foo | [((yy VV##563) = cow##awB);-                                         ((xx VV##563) = wink##awA)]}-bind 70 VV##565 : {VV##565 : int | [(VV##565 = cow##awB)]}-bind 71 VV##567 : {VV##567 : int | [(VV##567 = wink##awA)]}-bind 72 VV##569 : {VV##569 : int | [(VV##569 = cow##ax4)]}-bind 73 VV##571 : {VV##571 : int | [(VV##571 = wink##ax3)]}-bind 74 VV##573 : {VV##573 : int | [(VV##573 = cow##ax4)]}-bind 75 VV##575 : {VV##575 : int | [(VV##575 = wink##ax3)]}-bind 76 VV##577 : {VV##577 : int | [(VV##577 = cow##ax4)]}-bind 77 VV##579 : {VV##579 : int | [(VV##579 = wink##ax3)]}-bind 78 VV##581 : {VV##581 : (Tuple  int  int) | [$k_##333[VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]}-bind 79 VV##583 : {VV##583 : int | [$k_##323[VV##322:=VV##583][VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]}-bind 80 VV##585 : {VV##585 : int | [$k_##326[VV##325:=VV##585][VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]}-bind 81 lq_tmp$x##264 : {VV##587 : int | []}-bind 82 VV##588 : {VV##588 : int | [$k_##330[VV##332:=VV##581][VV##329:=VV##588][ds_dxg:=GHC.Prim.void###0l][lq_tmp$x##328:=lq_tmp$x##264]]}-bind 83 VV##590 : {VV##590 : GHC.Prim.Void# | [(VV##590 = GHC.Prim.void###0l)]}-bind 84 VV##592 : {VV##592 : (Tuple  int  int) | [$k_##351[lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##350:=VV##592]]}-bind 85 VV##594 : {VV##594 : int | [$k_##341[lq_tmp$x##353:=VV##594][lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##340:=VV##594][VV##350:=VV##592]]}-bind 86 VV##596 : {VV##596 : int | [$k_##344[lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##343:=VV##596][lq_tmp$x##354:=VV##596][VV##350:=VV##592]]}-bind 87 lq_tmp$x##328 : {VV##598 : int | []}-bind 88 VV##599 : {VV##599 : int | [$k_##348[lq_tmp$x##355:=lq_tmp$x##328][lq_tmp$x##356:=VV##599][VV##347:=VV##599][lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##346:=lq_tmp$x##328][lq_tmp$x##357:=VV##592][VV##350:=VV##592]]}-bind 89 VV##601 : {VV##601 : int | [(VV##601 = lq_anf$##dxu)]}-bind 90 VV##603 : {VV##603 : (Tuple  int  int) | [((snd VV##603) = cow##ax4);-                                                  ((fst VV##603) = wink##ax3);-                                                  ((x_Tuple22 VV##603) = cow##ax4);-                                                  ((x_Tuple21 VV##603) = wink##ax3)]}-bind 91 VV##605 : {VV##605 : int | [$k_##297[lq_tmp$x##295:=cow##ax4][lq_tmp$x##299:=VV##605][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##296:=VV##605]]}-bind 92 VV##607 : {VV##607 : int | [$k_##301[lq_tmp$x##295:=cow##ax4][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##300:=VV##607][lq_tmp$x##303:=VV##607]]}-bind 93 lq_tmp$x##264 : {VV##609 : int | []}-bind 94 VV##610 : {VV##610 : int | [$k_##305[lq_tmp$x##295:=cow##ax4][lq_tmp$x##290:=lq_tmp$x##264][VV##304:=VV##610][lq_tmp$x##307:=lq_tmp$x##264][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##610]]}-bind 95 VV##612 : {VV##612 : int | [(VV##612 = cow##ax4)]}-bind 96 VV##614 : {VV##614 : int | [(VV##614 = wink##ax3)]}-bind 97 VV##616 : {VV##616 : int | [(VV##616 = yog##awz)]}-bind 98 VV##618 : {VV##618 : int | [(VV##618 = xig##awy)]}-bind 99 VV##473 : {VV##473 : int | [$k_##474]}-bind 100 VV##443 : {VV##443 : int | [$k_##444]}-bind 101 VV##435 : {VV##435 : int | [$k_##436]}-bind 102 VV##431 : {VV##431 : int | [$k_##432]}-bind 103 VV##427 : {VV##427 : int | [$k_##428]}-bind 104 VV##391 : {VV##391 : int | [$k_##392]}-bind 105 VV##361 : {VV##361 : int | [$k_##362]}-bind 106 VV##318 : {VV##318 : GHC.Prim.Void# | [$k_##319]}-bind 107 VV##350 : {VV##350 : (Tuple  int  int) | [$k_##351]}-bind 108 VV##340 : {VV##340 : int | [$k_##341]}-bind 109 VV##343 : {VV##343 : int | [$k_##344]}-bind 110 lq_tmp$x##346 : {VV##631 : int | []}-bind 111 VV##347 : {VV##347 : int | [$k_##348]}-bind 112 VV##332 : {VV##332 : (Tuple  int  int) | [$k_##333]}-bind 113 VV##322 : {VV##322 : int | [$k_##323]}-bind 114 VV##325 : {VV##325 : int | [$k_##326]}-bind 115 lq_tmp$x##328 : {VV##636 : int | []}-bind 116 VV##329 : {VV##329 : int | [$k_##330]}-bind 117 VV##304 : {VV##304 : int | [$k_##305]}-bind 118 VV##300 : {VV##300 : int | [$k_##301]}-bind 119 VV##296 : {VV##296 : int | [$k_##297]}-bind 120 VV##268 : {VV##268 : (Tuple  int  int) | [$k_##269]}-bind 121 VV##258 : {VV##258 : int | [$k_##259]}-bind 122 VV##261 : {VV##261 : int | [$k_##262]}-bind 123 lq_tmp$x##264 : {VV##644 : int | []}-bind 124 VV##265 : {VV##265 : int | [$k_##266]}-bind 125 VV##251 : {VV##251 : int | [$k_##252]}-bind 126 VV##247 : {VV##247 : int | [$k_##248]}--constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40;-       42;-       48;-       54 ]-  lhs {VV##1 : int | [(VV##1 = cow##awB)]}-  rhs {VV##1 : int | [(wink##awA < VV##1)]}-  id 1 tag [1]-  // META constraint id 1 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40;-       42;-       48;-       49;-       50;-       51;-       52;-       53]-  lhs {VV##2 : int | [(VV##2 = cow##ax4)]}-  rhs {VV##2 : int | [$k_##474[VV##569:=VV##2][VV##F##2:=VV##2][VV##F:=VV##2][VV##473:=VV##2]]}-  id 2 tag [1]-  // META constraint id 2 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22]-  lhs {VV##18 : (Tuple  int  int) | [((snd VV##18) = cow##ax4);-                                     ((fst VV##18) = wink##ax3);-                                     ((x_Tuple22 VV##18) = cow##ax4);-                                     ((x_Tuple21 VV##18) = wink##ax3)]}-  rhs {VV##18 : (Tuple  int  int) | [$k_##269[VV##F##18:=VV##18][VV##268:=VV##18][VV##603:=VV##18][VV##F:=VV##18]]}-  id 18 tag [1]-  // META constraint id 18 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40;-       42;-       43;-       44;-       45;-       46;-       47]-  lhs {VV##3 : int | [(VV##3 = wink##ax3)]}-  rhs {VV##3 : int | [$k_##444[VV##571:=VV##3][VV##F:=VV##3][VV##F##3:=VV##3][VV##443:=VV##3]]}-  id 3 tag [1]-  // META constraint id 3 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22;-       90]-  lhs {VV##19 : int | [$k_##297[lq_tmp$x##295:=cow##ax4][VV##605:=VV##19][lq_tmp$x##299:=VV##19][lq_tmp$x##291:=VV##603][VV##F##19:=VV##19][lq_tmp$x##294:=wink##ax3][VV##F:=VV##19][VV##296:=VV##19]]}-  rhs {VV##19 : int | [$k_##259[VV##605:=VV##19][VV##268:=VV##603][VV##258:=VV##19][VV##F##19:=VV##19][VV##F:=VV##19]]}-  id 19 tag [1]-  // META constraint id 19 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40]-  lhs {VV##4 : int | [(VV##4 = cow##ax4)]}-  rhs {VV##4 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][VV##431:=VV##4][VV##573:=VV##4][lq_tmp$x##434:=VV##4][VV##F:=VV##4][VV##F##4:=VV##4]]}-  id 4 tag [1]-  // META constraint id 4 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22;-       90]-  lhs {VV##20 : int | [$k_##301[lq_tmp$x##295:=cow##ax4][VV##607:=VV##20][VV##F##20:=VV##20][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##300:=VV##20][lq_tmp$x##303:=VV##20][VV##F:=VV##20]]}-  rhs {VV##20 : int | [$k_##262[VV##268:=VV##603][VV##607:=VV##20][VV##F##20:=VV##20][VV##261:=VV##20][VV##F:=VV##20]]}-  id 20 tag [1]-  // META constraint id 20 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40]-  lhs {VV##5 : int | [(VV##5 = cow##ax4)]}-  rhs {VV##5 : int | [$k_##436[lq_tmp$x##425:=wink##ax3][VV##F##5:=VV##5][VV##573:=VV##5][lq_tmp$x##438:=wink##ax3][lq_tmp$x##434:=VV##5][VV##F:=VV##5][VV##435:=VV##5]]}-  id 5 tag [1]-  // META constraint id 5 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22;-       90;-       93]-  lhs {VV##21 : int | [$k_##305[lq_tmp$x##295:=cow##ax4][lq_tmp$x##290:=lq_tmp$x##264][VV##304:=VV##21][VV##610:=VV##21][lq_tmp$x##307:=lq_tmp$x##264][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##21][VV##F##21:=VV##21][VV##F:=VV##21]]}-  rhs {VV##21 : int | [$k_##266[VV##265:=VV##21][VV##610:=VV##21][VV##268:=VV##603][VV##F##21:=VV##21][VV##F:=VV##21]]}-  id 21 tag [1]-  // META constraint id 21 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40]-  lhs {VV##6 : int | [(VV##6 = wink##ax3)]}-  rhs {VV##6 : int | [$k_##428[VV##F##6:=VV##6][VV##427:=VV##6][lq_tmp$x##430:=VV##6][VV##F:=VV##6][VV##575:=VV##6]]}-  id 6 tag [1]-  // META constraint id 6 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22]-  lhs {VV##22 : int | [(VV##22 = cow##ax4)]}-  rhs {VV##22 : int | [$k_##301[VV##F##22:=VV##22][VV##612:=VV##22][lq_tmp$x##294:=wink##ax3][VV##300:=VV##22][lq_tmp$x##303:=VV##22][VV##F:=VV##22]]}-  id 22 tag [1]-  // META constraint id 22 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       35;-       36;-       37;-       38;-       39]-  lhs {VV##7 : int | [(VV##7 = cow##ax4)]}-  rhs {VV##7 : int | [$k_##392[VV##391:=VV##7][VV##F##7:=VV##7][VV##F:=VV##7][VV##577:=VV##7]]}-  id 7 tag [1]-  // META constraint id 7 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22]-  lhs {VV##23 : int | [(VV##23 = cow##ax4)]}-  rhs {VV##23 : int | [$k_##305[VV##304:=VV##23][lq_tmp$x##307:=wink##ax3][VV##612:=VV##23][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##23][VV##F:=VV##23][VV##F##23:=VV##23]]}-  id 23 tag [1]-  // META constraint id 23 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       29;-       30;-       31;-       32;-       33]-  lhs {VV##8 : int | [(VV##8 = wink##ax3)]}-  rhs {VV##8 : int | [$k_##362[VV##579:=VV##8][VV##F##8:=VV##8][VV##361:=VV##8][VV##F:=VV##8]]}-  id 8 tag [1]-  // META constraint id 8 : ()---constraint:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22]-  lhs {VV##24 : int | [(VV##24 = wink##ax3)]}-  rhs {VV##24 : int | [$k_##297[lq_tmp$x##299:=VV##24][VV##614:=VV##24][VV##F:=VV##24][VV##296:=VV##24][VV##F##24:=VV##24]]}-  id 24 tag [1]-  // META constraint id 24 : ()---constraint:-  env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16]-  lhs {VV##25 : int | [(VV##25 = yog##awz)]}-  rhs {VV##25 : int | [$k_##252[VV##251:=VV##25][lq_tmp$x##254:=VV##25][lq_tmp$x##245:=xig##awy][VV##F:=VV##25][VV##616:=VV##25][VV##F##25:=VV##25]]}-  id 25 tag [1]-  // META constraint id 25 : ()---constraint:-  env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16]-  lhs {VV##26 : int | [(VV##26 = xig##awy)]}-  rhs {VV##26 : int | [$k_##248[VV##618:=VV##26][VV##247:=VV##26][VV##F##26:=VV##26][VV##F:=VV##26][lq_tmp$x##250:=VV##26]]}-  id 26 tag [1]-  // META constraint id 26 : ()-----wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26;-       115]-  reft {VV##329 : int | [$k_##330]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25]-  reft {VV##318 : GHC.Prim.Void# | [$k_##319]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26;-       27;-       107]-  reft {VV##343 : int | [$k_##344]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40]-  reft {VV##427 : int | [$k_##428]}-  // META wf : ()---wf:-  env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16]-  reft {VV##247 : int | [$k_##248]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40;-       41]-  reft {VV##435 : int | [$k_##436]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40;-       42]-  reft {VV##443 : int | [$k_##444]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22]-  reft {VV##296 : int | [$k_##297]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26;-       27;-       110]-  reft {VV##347 : int | [$k_##348]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40;-       42;-       48]-  reft {VV##473 : int | [$k_##474]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26;-       27]-  reft {VV##350 : (Tuple  int  int) | [$k_##351]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34]-  reft {VV##391 : int | [$k_##392]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26]-  reft {VV##332 : (Tuple  int  int) | [$k_##333]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       120]-  reft {VV##258 : int | [$k_##259]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       120]-  reft {VV##261 : int | [$k_##262]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26;-       27;-       107]-  reft {VV##340 : int | [$k_##341]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22;-       23]-  reft {VV##304 : int | [$k_##305]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26;-       112]-  reft {VV##325 : int | [$k_##326]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28]-  reft {VV##361 : int | [$k_##362]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       123]-  reft {VV##265 : int | [$k_##266]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       24;-       25;-       26;-       112]-  reft {VV##322 : int | [$k_##323]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       18;-       19;-       20;-       21;-       22]-  reft {VV##300 : int | [$k_##301]}-  // META wf : ()---wf:-  env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17]-  reft {VV##268 : (Tuple  int  int) | [$k_##269]}-  // META wf : ()---wf:-  env [0;-       1;-       2;-       3;-       4;-       5;-       6;-       7;-       8;-       9;-       10;-       11;-       12;-       13;-       14;-       15;-       16;-       17;-       28;-       34;-       40]-  reft {VV##431 : int | [$k_##432]}-  // META wf : ()---wf:-  env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16]-  reft {VV##251 : int | [$k_##252]}-  // META wf : ()

− tests/elim/kvparam00.fq

@@ -1,20 +0,0 @@-bind 0 x : {v : int | []}--bind 1 y : {v : int | []}--constraint:-  env [0; 1]-  lhs {VV#F1 : int | []}-  rhs {VV#F1 : int | [$k_0[v:=x]]}-  id 1 tag [3]--constraint:-  env [0; 1]-  lhs {VV#F2 : int | [$k_0[v:=y]]}-  rhs {VV#F2 : int | [y = x]}-  id 2 tag [4]--wf:-  env []-  reft {v : int | [$k_0]}-

− tests/elim/len00.fq

@@ -1,23 +0,0 @@--// This qualifier saves the day; solve constraints WITHOUT IT-// qualif ListZ(v : [@(0)]): (len v >= 0)--constant len : (func(2, [(@(0)  @(1)); int]))--bind 0 y : {v : [(Tuple int a)] | [len v >= 0]}--constraint:-  env [0]-  lhs {v : [(Tuple int a)] | [v = y] }-  rhs {v : [(Tuple int a)] | [$k0]   }-  id 1 tag []--constraint:-  env []-  lhs {v : [(Tuple int a)] | [$k0]             }-  rhs {v : [(Tuple int a)] | [len v >= 0] }-  id 2 tag []--wf:-  env [ ]-  reft {v : [(Tuple int a)] | [$k0] }

− tests/elim/test00-tx.fq

@@ -1,12 +0,0 @@---// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 a : {v:int | (v = 10 || v = 20) }--constraint:-  env [ 0 ]-  lhs {v : int | v = a}-  rhs {v : int | 10 <= v}-  id 3 tag []

− tests/elim/test00.fq

@@ -1,26 +0,0 @@-// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 a : {v: int | $k0}--constraint:-  env [ ]-  lhs {v : int | v = 10}-  rhs {v : int | $k0}-  id 1 tag []--constraint:-  env [ ]-  lhs {v : int | v = 20}-  rhs {v : int | $k0}-  id 2 tag []--constraint:-  env [ 0 ]-  lhs {v : int | v = a}-  rhs {v : int | 10 <= v}-  id 3 tag []--wf:-  env [ ]-  reft {v: int | $k0}

− tests/elim/test00a.fq

@@ -1,28 +0,0 @@-// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 x : {v : int | true}-bind 1 y : {v : int | true}-bind 2 z : {v : int | true}--constraint:-  env [0]-  lhs {v : int | (x = 10)}-  rhs {v : int | $k0[v:=x]}-  id 1 tag []--constraint:-  env [1]-  lhs {v : int | y = 20}-  rhs {v : int | $k0[v:=y]}-  id 2 tag []--constraint:-  env [2]-  lhs {v : int | $k0[v:=z]}-  rhs {v : int | 10 <= z}-  id 3 tag []--wf:-  env [ ]-  reft {v: int | $k0}

− tests/elim/test1.fq

@@ -1,29 +0,0 @@--// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a) : (10 <= v)--bind 0 x : {v : int | v = 10}-bind 1 y : {v : int | v = 20}-bind 2 a : {v : int | $k0    }-      -constraint:-  env [0]-  lhs {v : int | v = x}-  rhs {v : int | $k0   }-  id 1 tag []--constraint:-  env [1]-  lhs {v : int | v = y}-  rhs {v : int | $k0   }-  id 2 tag []--constraint:-  env [2]-  lhs {v : int | v = a  }-  rhs {v : int | 10 <= v}-  id 3 tag []--wf:-  env [ ]-  reft {v : int | $k0}

− tests/elim/test2.fq

@@ -1,53 +0,0 @@--// This qualifier saves the day; solve constraints WITHOUT IT-// qualif Zog(v:a): (10 <= v)--// But you may use this one-qualif Pog(v:a): (0 <= v)--bind 0 x: {v: int | v = 10}-bind 1 a: {v: int | $k1    }-bind 2 y: {v: int | v = 20}-bind 3 b: {v: int | $k1    }-bind 4 c: {v: int | $k0    }--cut $k1--constraint:-  env [ ]-  lhs {v : int | v = 0}-  rhs {v : int | $k1 }-  id 0 tag []---constraint:-  env [0; 1]-  lhs {v : int | v = x + a}-  rhs {v : int | $k0}-  id 1 tag []--constraint:-  env [2; 3]-  lhs {v : int | v = y + b}-  rhs {v : int | $k0}-  id 2 tag []--constraint:-  env [ ]-  lhs {v : int | $k0}-  rhs {v : int | $k1}-  id 3 tag []--constraint:-  env [4]-  lhs {v : int | v = c  }-  rhs {v : int | 10 <= v}-  id 4 tag []--wf:-  env [ ]-  reft {v: int | $k0}--wf:-  env [ ]-  reft {v: int | $k1}

− tests/elim/tuple00.fq

@@ -1,114 +0,0 @@--bind 0 cat   : {v: int | v = 100 }-bind 1 dog   : {v: int | v = 200 }-bind 2 frog  : {v: int | v = 400 }-bind 3 mouse : {v: int | v = 500 }-bind 4 hippo : {v: int | v = 600 }-bind 5 goose : {v: int | v = 700 }-bind 6 crow  : {v: int | v = 800 }-bind 7 pig   : {v: int | v = 900 }--bind 20 x_1_1 : {v: int | $k_1_1 }-bind 21 x_1_2 : {v: int | $k_1_2 }-bind 22 x_2_1 : {v: int | $k_2_1 }-bind 23 x_2_2 : {v: int | $k_2_2 }-bind 24 x_3_1 : {v: int | $k_3_1 }-bind 25 x_3_2 : {v: int | $k_3_2 }--pack $k_1_1 : 1-pack $k_1_2 : 1-pack $k_2_1 : 2-pack $k_2_2 : 2-pack $k_3_1 : 3-pack $k_3_2 : 3-pack $k_4_1 : 4-pack $k_4_2 : 4----constraint:-  env [ 0; 1; 2; 3; 4; 5; 6; 7 ]-  lhs {v : int | v = 1}-  rhs {v : int | $k_1_1}-  id 1 tag []--constraint:-  env [ 0; 1; 2; 3; 4; 5; 6; 7 ]-  lhs {v : int | v = 2}-  rhs {v : int | $k_1_2}-  id 2 tag []--constraint:-  env [ 20; 21 ]-  lhs {v : int | v = x_1_1 }-  rhs {v : int | $k_2_1    }-  id 3 tag []--constraint:-  env [ 20; 21 ]-  lhs {v : int | v = x_1_2 }-  rhs {v : int | $k_2_2    }-  id 4 tag []--constraint:-  env [ 22; 23 ]-  lhs {v : int | v = x_2_1 }-  rhs {v : int | $k_3_1    }-  id 5 tag []--constraint:-  env [ 22; 23 ]-  lhs {v : int | v = x_2_2 }-  rhs {v : int | $k_3_2    }-  id 6 tag []--constraint:-  env [ 24; 25 ]-  lhs {v : int | v = x_3_1 }-  rhs {v : int | $k_4_1    }-  id 7 tag []--constraint:-  env [ 24; 25 ]-  lhs {v : int | v = x_3_2 }-  rhs {v : int | $k_4_2    }-  id 8 tag []--constraint:-  env [ ]-  lhs {v : int | $k_4_1 }-  rhs {v : int | v = 1  }-  id 9 tag []--wf:-  env [ ]-  reft {v: int | $k_1_1}--wf:-  env [ ]-  reft {v: int | $k_1_2}--wf:-  env [ ]-  reft {v: int | $k_2_1}--wf:-  env [ ]-  reft {v: int | $k_2_2}--wf:-  env [ ]-  reft {v: int | $k_3_1}--wf:-  env [ ]-  reft {v: int | $k_3_2}---wf:-  env [ ]-  reft {v: int | $k_4_1}--wf:-  env [ ]-  reft {v: int | $k_4_2}

− tests/elim/tuple01.fq

@@ -1,137 +0,0 @@-// This test illustrates how you can get an exponential VC from nested tuples--bind 0 cat   : {v: int | v = 100 }-bind 1 dog   : {v: int | v = 200 }-bind 2 frog  : {v: int | v = 400 }-bind 3 mouse : {v: int | v = 500 }-bind 4 hippo : {v: int | v = 600 }-bind 5 goose : {v: int | v = 700 }-bind 6 crow  : {v: int | v = 800 }-bind 7 pig   : {v: int | v = 900 }--bind 20 x_1_1 : {v: int | $k_1_1 }-bind 21 x_1_2 : {v: int | $k_1_2 }-bind 22 x_2_1 : {v: int | $k_2_1 }-bind 23 x_2_2 : {v: int | $k_2_2 }-bind 24 x_3_1 : {v: int | $k_3_1 }-bind 25 x_3_2 : {v: int | $k_3_2 }-bind 26 x_4_1 : {v: int | $k_4_1 }-bind 27 x_4_2 : {v: int | $k_4_2 }--// pack $k_1_1 : 1-// pack $k_1_2 : 1-// pack $k_2_1 : 2-// pack $k_2_2 : 2-// pack $k_3_1 : 3-// pack $k_3_2 : 3-// pack $k_4_1 : 4-// pack $k_4_2 : 4-// pack $k_5_1 : 5-// pack $k_5_2 : 5--constraint:-  env [ 0; 1; 2; 3; 4; 5; 6; 7 ]-  lhs {v : int | v = 1}-  rhs {v : int | $k_1_1}-  id 1 tag []--constraint:-  env [ 0; 1; 2; 3; 4; 5; 6; 7 ]-  lhs {v : int | v = 2}-  rhs {v : int | $k_1_2}-  id 2 tag []--constraint:-  env [ 20; 21 ]-  lhs {v : int | v = x_1_1 }-  rhs {v : int | $k_2_1    }-  id 3 tag []--constraint:-  env [ 20; 21 ]-  lhs {v : int | v = x_1_2 }-  rhs {v : int | $k_2_2    }-  id 4 tag []--constraint:-  env [ 22; 23 ]-  lhs {v : int | v = x_2_1 }-  rhs {v : int | $k_3_1    }-  id 5 tag []--constraint:-  env [ 22; 23 ]-  lhs {v : int | v = x_2_2 }-  rhs {v : int | $k_3_2    }-  id 6 tag []--constraint:-  env [ 24; 25 ]-  lhs {v : int | v = x_3_1 }-  rhs {v : int | $k_4_1    }-  id 7 tag []--constraint:-  env [ 24; 25 ]-  lhs {v : int | v = x_3_2 }-  rhs {v : int | $k_4_2    }-  id 8 tag []--constraint:-  env [ 26; 27 ]-  lhs {v : int | v = x_4_1 }-  rhs {v : int | $k_5_1    }-  id 9 tag []--constraint:-  env [ 26; 27 ]-  lhs {v : int | v = x_4_2 }-  rhs {v : int | $k_5_2    }-  id 10 tag []--constraint:-  env [ ]-  lhs {v : int | $k_5_1 }-  rhs {v : int | v = 1  }-  id 11 tag []--wf:-  env [ ]-  reft {v: int | $k_1_1}--wf:-  env [ ]-  reft {v: int | $k_1_2}--wf:-  env [ ]-  reft {v: int | $k_2_1}--wf:-  env [ ]-  reft {v: int | $k_2_2}--wf:-  env [ ]-  reft {v: int | $k_3_1}--wf:-  env [ ]-  reft {v: int | $k_3_2}---wf:-  env [ ]-  reft {v: int | $k_4_1}--wf:-  env [ ]-  reft {v: int | $k_4_2}--wf:-  env [ ]-  reft {v: int | $k_5_1}--wf:-  env [ ]-  reft {v: int | $k_5_2}

− tests/horn/neg/abs02-re.smt2

@@ -1,29 +0,0 @@-(fixpoint "--eliminate=horn")--(var $k_##1 ((Int) (Int)))-(var $k_##3 ((Int) (Int)))--(constraint-  (and-      (forall ((x int) (true))-       (forall ((pos bool) (pos <=> x >= 0))-        (and-         (forall ((lq_tmp$grd##3 bool) (pos))-          (forall ((VV int) (VV == x))-           (($k_##1 VV x))))-         (forall ((lq_tmp$grd##3 bool) (not pos))-          (forall ((v int) (v == 0 - x))-           (($k_##1 v x)))))))-      (forall ((z int) (true))-       (and-        (forall ((r int) (r >= 0))-         (forall ((v int) (v == r + 1))-          (($k_##3 v z))))-        (and-         (forall ((_t1 int) (_t1 >= 0))-          (forall ((VV##0 int) ($k_##1 VV##0 _t1))-           (((VV##0 >= 0)))))-         (forall ((res int) ($k_##3 res z))-          (forall ((ok bool) (ok <=> 6660 <= res))-           (forall ((v bool) ((v <=> 6660 <= res) && v == ok))-            ((v))))))))))

− tests/horn/neg/ebind03.smt2

@@ -1,16 +0,0 @@-(fixpoint "--eliminate=horn")--(var $ka ((Int)))-(var $kb ((Int)))--(constraint-(and- (exists ((x1 Int) (true))-  (and-   (forall ((v Int) (v = 1)) ((v = x1)))-   (forall ((v Int) (v = x1 + 1)) (($ka v)))))- (exists ((x2 Int) (true))-  (and-   (forall ((v Int) ($ka v)) ((v = x2)))-   (forall ((v Int) (v = x2 + 1)) (($kb v)))))- (forall ((v Int) ($kb v)) ((v = 5)))))

− tests/horn/neg/irregular_adt_00.smt2

@@ -1,36 +0,0 @@-// we want this to fail because FingerTree is NOT a 'regular' datatype. See `isRegularDataDecl`--(data Node 1 = [-       | Node3 {Node3_lqdc_select_Node3_1 : @(0), Node3_lqdc_select_Node3_2 : @(0), Node3_lqdc_select_Node3_3 : @(0)}-       | Node2 {Node2_lqdc_select_Node2_1 : @(0), Node2_lqdc_select_Node2_2 : @(0)}-])--(data Digit 1 = [-       | Four {Four_lqdc_select_Four_1 : @(0), Four_lqdc_select_Four_2 : @(0), Four_lqdc_select_Four_3 : @(0), Four_lqdc_select_Four_4 : @(0)}-       | Three {Three_lqdc_select_Three_1 : @(0), Three_lqdc_select_Three_2 : @(0), Three_lqdc_select_Three_3 : @(0)}-       | Two {Two_lqdc_select_Two_1 : @(0), Two_lqdc_select_Two_2 : @(0)}-       | One {One_lqdc_select_One_1 : @(0)}-])--(data FingerTree 1 = [-       | Deep {Deep_lqdc_select_Deep_1 : (Digit @(0)), Deep_lqdc_select_Deep_2 : (FingerTree (Node @(0))), Deep_lqdc_select_Deep_3 : (Digit @(0))}-       | Single {Single_lqdc_select_Single_1 : @(0)}-       | EmptyT {}-])---(constant len (func(1, [(FingerTree @(0)), int])))--(define len(l: [a]) : int = {-  if (is$VNil l) then 0 else (1 + len(tail l))-})--(constraint-  (forall ((x (FingerTree int)) (true))-    (forall ((y (FingerTree int)) (y = x)) -      (forall ((z (FingerTree int)) (z = y)) -        (((len z) == (len x)))-      )-    )-  )-)

− tests/horn/neg/ple0.smt2

@@ -1,13 +0,0 @@-(fixpoint "--rewrite")--(constant adder (func(0, [int, int, int])))--(define adder(x : int, y : int) : int = { x + y })--(constraint -   (forall ((x int) (x == 5)) -     (forall ((y int) (y == 6)) -       (( (adder x y) = 12 ))-     )-   )-)

− tests/horn/neg/ple_list00.smt2

@@ -1,12 +0,0 @@-(fixpoint "--rewrite")--(constant len (func(1, [(Main.List  @(0)), int])))-(constant Cons (func(2, [@(0), (Main.List  @(0)), (Main.List @(0))])))-(constant Nil  (Main.List @(0)))--(match len Nil = 0)-(match len Cons x xs = (1 + len xs))--(constraint-  ((len (Cons 1 (Cons 2 (Cons 3 Nil))) = 4))-)

− tests/horn/neg/ple_list01_adt.smt2

@@ -1,22 +0,0 @@-(fixpoint "--rewrite")--(data Vec 1 = [-  | VNil  { }-  | VCons { head : @(0), tail : Vec @(0)}-])--(constant len (func(1, [(Vec @(0)), int])))--(define len(l: [a]) : int = {-  if (is$VNil l) then 0 else (1 + len(tail l))-})--(constraint-  (forall ((x int) (true))-    (forall ((y int) (y = 2)) -      (forall ((z int) (z = 3)) -        ((len (VCons x (VCons y (VCons z VNil))) = 30))-      )-    )-  )-)

− tests/horn/neg/ple_list03.smt2

@@ -1,45 +0,0 @@-(fixpoint "--rewrite")--(define ints2 (): [int] = { -   Cons 1 (Cons 20 Nil)-})--(define filter (lq1 : func(0 , [a##a29r;bool]),  lq2 : [a##a29r]) : [a##a29r] = {-  if (isNil lq2) then Nil else (-      if (lq1 (head lq2)) -        then (Cons (head lq2) (filter lq1 (tail lq2))) -        else (filter lq1 (tail lq2)))-})--(define ints0 () : [int] = { -    Cons 0 (Cons 1 (Cons 2 Nil))-})--(define isPos (lq1 : int) : bool = {-    lq1 > 0-})---(match isCons Cons x xs = (true))-(match isNil  Cons x xs = (false))-(match isCons Nil       = (false))-(match isNil  Nil       = (true))-(match tail Cons x xs   = (xs))-(match head Cons x xs   = (x))--(constant isCons (func(1 , [[@(0)], bool])))-(constant isNil  (func(1 , [[@(0)], bool])))-(constant Nil    (func(1 , [[@(0)]])))-(constant tail   (func(1 , [[@(0)], [@(0)]])))-(constant head   (func(1 , [[@(0)], @(0)])))-(constant ints0   [int])-(constant ints2   [int])-(constant filter  (func(1 , [func(0 , [@(0), bool]), [@(0)], [@(0)]])))-                -(constant isPos  (func(0 , [int, bool])))-(constant Cons   (func(1 , [@(0), [@(0)], [@(0)]])))-(constant Nil    (func(1 , [[@(0)]])))--(constraint-  ((filter isPos ints0 == ints2))-)

− tests/horn/neg/ple_sum.smt2

@@ -1,12 +0,0 @@-(fixpoint "--rewrite")--(constant sum  (func(0, [int, int])))--(define sum(n : int) : int = { if (n <= 0) then (0) else (n + sum (n-1)) })--(constraint -   (forall ((x int) (x == 5)) -       (( (sum x) = 150 ))-   )-)-

− tests/horn/neg/ple_sum_fuel.5.smt2

@@ -1,14 +0,0 @@-(fixpoint "--rewrite")-(fixpoint "--save")-(fixpoint "--fuel=5")--(constant sum  (func(0, [int, int])))--(define sum(n : int) : int = { if (n <= 0) then (0) else (n + sum (n-1)) })--(constraint -   (forall ((x int) ((5 <= x) && (0 <= (sum (x-5))))) -       ((15 <= (sum x)))-   )-)-

− tests/horn/neg/tag00.smt2

@@ -1,16 +0,0 @@-(fixpoint "--eliminate=horn")--// TODO move to actual SMTLIB format --(constraint -(forall ((x Int) (x > 0))-  (and-    (forall ((y Int) (y > x))-      (forall ((v Int) (v = x + y)) -        ( (v > 0)  )))-    (forall ((z Int) (z > 10))-      (forall ((v Int) (v = x + z)) -        (tag (v > 100) "gt-100" )))))-)--

− tests/horn/neg/test00.smt2

@@ -1,10 +0,0 @@-(fixpoint "--eliminate=horn")--// TODO move to actual SMTLIB format --(constraint -(forall ((x Int) (x > 0))-  (forall ((y Int) (y > x))-    (forall ((v Int) (v = x + y)) -       ((v > 10)))))-)

− tests/horn/neg/test01.smt2

@@ -1,16 +0,0 @@-(fixpoint "--eliminate=horn")--// TODO move to actual SMTLIB format --(constraint -(forall ((x Int) (x > 0))-  (and-    (forall ((y Int) (y > x))-      (forall ((v Int) (v = x + y)) -        ( (v > 0)  )))-    (forall ((z Int) (z > 10))-      (forall ((v Int) (v = x + z)) -        (tag (v > 100) "gt-100" )))))-)--

− tests/horn/neg/test02.smt2

@@ -1,18 +0,0 @@-(fixpoint "--eliminate=horn")--// TODO move to actual SMTLIB format --(var $k0 ((Int)))--(qualif Foo ((v Int)) ((v > 100)))--(constraint -  (forall ((x Int) (x > 0))-    (and-      (forall ((y Int) (y > x + 100))-        (forall ((v Int) (v = x + y)) -          (($k0 v))))-      (forall ((z Int) ($k0 z))-        (forall ((v Int) (v = x + z)) -          ((v > 200)))))))-

− tests/horn/neg/test03.smt2

@@ -1,24 +0,0 @@-(fixpoint "--eliminate=horn")--// TODO move to actual SMTLIB format --(var $k0 ((Int)))--(qualif Foo ((v Int)) ((v > 10)))--(constraint -  (and -    (forall ((x Int) (x > 0))-      (forall ((v Int) (v = x)) -        (($k0 v))))-    (forall ((y Int) ($k0 y))-      (forall ((v Int) (v = y + 1)) -        (($k0 v))))-    (forall ((z Int) ($k0 z))-        ((z > 0)))))------

− tests/horn/pos/abs02-re.smt2

@@ -1,13 +0,0 @@-(constraint -  (and-      (forall ((x int) (true))-       (forall ((VV int) (VV == 10))-        ((VV >= 0))))-      (forall ((z int) (true))-       (and-        (forall ((r int) (r >= 0))-         (forall ((v int) (v >= 0 && v == r))-          (((v >= 0)))))-        (forall ((_t1 int) (_t1 >= 0))-         (forall ((v int) (v >= 0))-          (((v >= 0)))))))))

− tests/horn/pos/constant.smt2

@@ -1,13 +0,0 @@-(var $k0 ((Int)))--(qualif Foo ((v Int)) ((v > 100)))--(constraint -  (forall ((x Int) (x > 0))-    (and-     (forall ((v Int) (v = f x))-      (($k0 v)))-      (forall ((z Int) ($k0 z))-       ((z = f x))))))--(constant f (func(0, [Int;Int])))

− tests/horn/pos/ebind01.smt2

@@ -1,6 +0,0 @@-(constraint-  (forall ((m Int) (true))-    (exists ((x1 Int) (true))-      (and-        (forall ((v Int) (v = m + 1)) ((v = x1)))-        (forall ((v Int) (v = x1 + 1)) ((v = 2 + m)))))))

− tests/horn/pos/ebind02.smt2

@@ -1,11 +0,0 @@-(var $k ((Int)))--(constraint-  (forall ((m Int) (true))-    (forall ((z Int) (z = m - 1))-      (and-        (forall ((v1 Int) (v1 = z + 2)) (($k v1)))-        (exists ((x1 Int) (true))-          (and-            (forall ((v2 Int) ($k v2)) ((v2 = x1)))-            (forall ((v3 Int) (v3 = x1 + 1)) ((v3 = m + 2)))))))))

− tests/horn/pos/ebind03.smt2

@@ -1,14 +0,0 @@-(var $ka ((Int)))-(var $kb ((Int)))--(constraint-(and- (exists ((x1 Int) (true))-  (and-   (forall ((v Int) (v = 1)) ((v = x1)))-   (forall ((v Int) (v = x1 + 1)) (($ka v)))))- (exists ((x2 Int) (true))-  (and-   (forall ((v Int) ($ka v)) ((v = x2)))-   (forall ((v Int) (v = x2 + 1)) (($kb v)))))- (forall ((v Int) ($kb v)) ((v = 3)))))

− tests/horn/pos/icfp17-ex1.smt2

@@ -1,14 +0,0 @@-(fixpoint "--eliminate=horn")--(var $k ((Int)))--(constraint-  (forall ((x Int) (x >= 0))-    (and-      (forall ((v Int) (v = x - 1))-       (($k v)))-      (forall ((y Int) ($k y))-        (forall ((v Int) (v = y + 1))-          ((v >= 0)))))))--

− tests/horn/pos/icfp17-ex2.smt2

@@ -1,19 +0,0 @@-(fixpoint "--eliminate=horn")--(var $kx ((Int)))-(var $ky ((Int)))--(constraint-  (forall ((x Int) (x >= 0))-    (and-      (forall ((n Int) (n = x - 1))-       (forall ((p Int) (p = x + 1))-         (and-           (forall ((v Int) (v = n)) (($kx v)))-           (forall ((v Int) (v = p)) (($ky v)))-           (forall ((v Int) ($kx p)) (($ky v))))))-      (forall ((y Int) ($ky y))-        (forall ((v Int) (v = y + 1))-          ((v >= 0)))))))--

− tests/horn/pos/icfp17-ex3.smt2

@@ -1,16 +0,0 @@-(fixpoint "--eliminate=horn")--(var $ka ((Int)))-(var $kb ((Int)))-(var $kc ((Int)))--(constraint- (and-  (forall ((a Int) ($ka a))-   (forall ((v Int) (v = a - 1)) (($kb v))))-  (forall ((b Int) ($kb b))-   (forall ((v Int) (v = b + 1))-    (($kc v))))-  (forall ((v Int) (v >= 0)) (($ka v)))-  (forall ((v Int) ($kc v)) ((v >= 0)))))-

− tests/horn/pos/ple0.smt2

@@ -1,13 +0,0 @@-(fixpoint "--rewrite")--(constant adder (func(0, [int, int, int])))--(define adder(x : int, y : int) : int = { x + y })--(constraint -   (forall ((x int) (x == 5)) -     (forall ((y int) (y == 6)) -       (( (adder x y) = 11 ))-     )-   )-)

− tests/horn/pos/ple_list00.smt2

file too large to diff

− tests/horn/pos/ple_list01_adt.smt2

file too large to diff

− tests/horn/pos/ple_sum.smt2

file too large to diff

− tests/horn/pos/ple_sum_fuel.5.smt2

file too large to diff

− tests/horn/pos/sum-rec-ok.smt2

file too large to diff

− tests/horn/pos/sum-rec.smt2

file too large to diff

− tests/horn/pos/test00.smt2

file too large to diff

− tests/horn/pos/test01.smt2

file too large to diff

− tests/horn/pos/test02.smt2

file too large to diff

− tests/horn/pos/test03.smt2

file too large to diff

− tests/minimize/two-cores.fq

file too large to diff

+ tests/neg/maps02.fq view

file too large to diff

+ tests/pos/maps02.fq view

file too large to diff

+ tests/pos/maps03.fq view

file too large to diff

+ tests/pos/maps04.fq view

file too large to diff

+ tests/pos/maps05.fq view

file too large to diff

− tests/proof/GADTs.fq

file too large to diff

− tests/proof/IndPal00.fq

file too large to diff

− tests/proof/IndPal000.fq

file too large to diff

− tests/proof/LH1424.fq

file too large to diff

− tests/proof/T387.fq

file too large to diff

− tests/proof/T414.fq

file too large to diff

− tests/proof/contra.fq

file too large to diff

− tests/proof/even.fq

file too large to diff

− tests/proof/evenA.fq

file too large to diff

− tests/proof/intId.fq

file too large to diff

− tests/proof/list00.fq

file too large to diff

− tests/proof/list01.fq

file too large to diff

− tests/proof/list01_adt.fq

file too large to diff

− tests/proof/list02.fq

file too large to diff

− tests/proof/list03.fq

file too large to diff

− tests/proof/ple0.fq

file too large to diff

− tests/proof/ple1.fq

file too large to diff

− tests/proof/ple2.fq

file too large to diff

− tests/proof/ple3.fq

file too large to diff

− tests/proof/ple4.fq

file too large to diff

− tests/proof/pleBool.fq

file too large to diff

− tests/proof/pleBoolA.fq

file too large to diff

− tests/proof/pleBoolB.fq

file too large to diff

− tests/proof/pleBoolC.fq

file too large to diff

− tests/proof/pleSubst.fq

file too large to diff

− tests/proof/rewrite.fq

file too large to diff

− tests/proof/sum.fq

file too large to diff

− tests/rankNTypes/T407.hs.fq

file too large to diff

+ tests/tasty/Arbitrary.hs view

file too large to diff

+ tests/tasty/InterpretTests.hs view

file too large to diff

tests/tasty/Main.hs view

file too large to diff

tests/tasty/ShareMapReference.hs view

file too large to diff

tests/tasty/ShareMapTests.hs view

file too large to diff

+ tests/tasty/SimplifyInterpreter.hs view

file too large to diff

+ tests/tasty/SimplifyPLE.hs view

file too large to diff

+ tests/tasty/SimplifyTests.hs view

file too large to diff

+ tests/tasty/UndoANFTests.hs view

file too large to diff

tests/test.hs view

file too large to diff

− tests/todo-crash/wl01.fq

file too large to diff

− tests/todo/LH1090.fq

file too large to diff

− tests/todo/T1371-short.fq

file too large to diff

− tests/todo/ebind-kvar-chain.fq

file too large to diff

unix/Language/Fixpoint/Utils/Progress.hs view

file too large to diff