packages feed

liquidhaskell-boot 0.9.10.1 → 0.9.10.1.2

raw patch · 93 files changed

+9844/−9264 lines, 93 filesdep +arraydep −data-defaultdep −data-fixdep −recursion-schemesdep ~Diffdep ~hashabledep ~liquid-fixpoint

Dependencies added: array

Dependencies removed: data-default, data-fix, recursion-schemes

Dependency ranges changed: Diff, hashable, liquid-fixpoint, optparse-applicative

Files

liquidhaskell-boot.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               liquidhaskell-boot-version:            0.9.10.1+version:            0.9.10.1.2 synopsis:           Liquid Types for Haskell description:        This package provides a plugin to verify Haskell programs.                     But most likely you should be using the [liquidhaskell package](https://hackage.haskell.org/package/liquidhaskell)@@ -15,8 +15,6 @@ build-type:         Simple tested-with:        GHC == 9.10.1 -extra-source-files: tests/specfiles/pos/*.spec- source-repository head   type:     git   location: https://github.com/ucsd-progsys/liquidhaskell/@@ -36,14 +34,12 @@                       Language.Haskell.Liquid.Bare.Class                       Language.Haskell.Liquid.Bare.DataType                       Language.Haskell.Liquid.Bare.Expand-                      Language.Haskell.Liquid.Bare.Laws                       Language.Haskell.Liquid.Bare.Measure                       Language.Haskell.Liquid.Bare.Misc                       Language.Haskell.Liquid.Bare.Plugged                       Language.Haskell.Liquid.Bare.Resolve                       Language.Haskell.Liquid.Bare.ToBare                       Language.Haskell.Liquid.Bare.Types-                      Language.Haskell.Liquid.Bare.Slice                       Language.Haskell.Liquid.Bare.Typeclass                       Language.Haskell.Liquid.Bare.Elaborate                       Language.Haskell.Liquid.CSS@@ -60,10 +56,11 @@                       Language.Haskell.Liquid.Constraint.Termination                       Language.Haskell.Liquid.Constraint.Types                       Language.Haskell.Liquid.Constraint.Relational+                      Language.Haskell.Liquid.Constraint.RewriteCase                       Liquid.GHC.API+                      Liquid.GHC.API.Compat                       Liquid.GHC.API.Extra                       Liquid.GHC.API.StableModule-                      Language.Haskell.Liquid.GHC.CoreToLogic                       Language.Haskell.Liquid.GHC.Interface                       Language.Haskell.Liquid.GHC.Logging                       Language.Haskell.Liquid.GHC.Misc@@ -74,21 +71,21 @@                       Language.Haskell.Liquid.GHC.TypeRep                       Language.Haskell.Liquid.GHC.Plugin                       Language.Haskell.Liquid.GHC.Plugin.Tutorial-                      Language.Haskell.Liquid.LawInstances+                      Language.Haskell.Liquid.LHNameResolution                       Language.Haskell.Liquid.Liquid                       Language.Haskell.Liquid.Measure                       Language.Haskell.Liquid.Misc+                      Language.Haskell.Liquid.Name.LogicNameEnv                       Language.Haskell.Liquid.Parse                       Language.Haskell.Liquid.Termination.Structural                       Language.Haskell.Liquid.Transforms.ANF                       Language.Haskell.Liquid.Transforms.CoreToLogic-                      Language.Haskell.Liquid.Transforms.Rec                       Language.Haskell.Liquid.Transforms.RefSplit                       Language.Haskell.Liquid.Transforms.Rewrite                       Language.Haskell.Liquid.Transforms.Simplify                       Language.Haskell.Liquid.Transforms.InlineAux-                      Language.Haskell.Liquid.Types                       Language.Haskell.Liquid.Types.Bounds+                      Language.Haskell.Liquid.Types.DataDecl                       Language.Haskell.Liquid.Types.Dictionaries                       Language.Haskell.Liquid.Types.Equality                       Language.Haskell.Liquid.Types.Errors@@ -100,6 +97,8 @@                       Language.Haskell.Liquid.Types.PredType                       Language.Haskell.Liquid.Types.PrettyPrint                       Language.Haskell.Liquid.Types.RefType+                      Language.Haskell.Liquid.Types.RType+                      Language.Haskell.Liquid.Types.RTypeOp                       Language.Haskell.Liquid.Types.Specs                       Language.Haskell.Liquid.Types.Types                       Language.Haskell.Liquid.Types.Variance@@ -117,13 +116,14 @@                       Language.Haskell.Liquid.WiredIn                       LiquidHaskellBoot                       Paths_liquidhaskell_boot-  other-modules:      Language.Haskell.Liquid.GHC.Plugin.SpecFinder+  other-modules:      Language.Haskell.Liquid.GHC.Plugin.Serialisation+                      Language.Haskell.Liquid.GHC.Plugin.SpecFinder                       Language.Haskell.Liquid.GHC.Plugin.Types-                      Language.Haskell.Liquid.GHC.Plugin.Util-  hs-source-dirs:     src src-ghc+  hs-source-dirs:     src src-ghc src-ghc-9.10    build-depends:      base                 >= 4.11.1.0 && < 5                     , Diff                 >= 0.3 && < 0.6+                    , array                     , aeson                     , binary                     , bytestring           >= 0.10@@ -131,7 +131,6 @@                     , cereal                     , cmdargs              >= 0.10                     , containers           >= 0.5-                    , data-default         >= 0.5                     , deepseq              >= 1.3                     , directory            >= 1.2                     , filepath             >= 1.3@@ -141,9 +140,9 @@                     , ghc-boot                     , ghc-prim                     , gitrev-                    , hashable             >= 1.3 && < 1.5+                    , hashable             >= 1.3 && < 1.6                     , hscolour             >= 1.22-                    , liquid-fixpoint      == 0.9.6.3.1+                    , liquid-fixpoint      == 0.9.6.3.2                     , mtl                  >= 2.1                     , optparse-applicative < 0.19                     , githash@@ -160,8 +159,6 @@                     , unordered-containers >= 0.2.11                     , vector               >= 0.10                     , free-                    , recursion-schemes    < 5.3-                    , data-fix                     , extra   default-language:   Haskell98   default-extensions: PatternGuards, RecordWildCards, DoAndIfThenElse@@ -205,7 +202,6 @@ test-suite liquidhaskell-parser   type:             exitcode-stdio-1.0   main-is:          Parser.hs-  other-modules:    Paths_liquidhaskell_boot   hs-source-dirs:   tests   build-depends:    base            >= 4.8.1.0 && < 5                   , directory       >= 1.2.5 && < 1.4
+ src-ghc-9.10/Liquid/GHC/API/Compat.hs view
@@ -0,0 +1,48 @@+-- | This module contains definitions that change between different versions+-- of the GHC API. It helps encapsulating differences between branches of LH+-- that could support different versions of GHC.+module Liquid.GHC.API.Compat (+    UniqueId+  , toUniqueId++  , foldableModule+  , realModule++  , mkHsTyConApp+  , mkHsOverLit+  ) where++import Data.Word (Word64)+import qualified GHC.Builtin.Names as Ghc+import GHC (Module, LexicalFixity(..))+import GHC.Hs++----------------------+-- Uniques+----------------------++type UniqueId = Word64++toUniqueId :: Word64 -> UniqueId+toUniqueId = id+++----------------------+-- Built-in modules+----------------------++foldableModule, realModule :: Module++foldableModule = Ghc.gHC_INTERNAL_DATA_FOLDABLE+realModule = Ghc.gHC_INTERNAL_REAL+++----------------------+-- AST differences+----------------------++mkHsTyConApp ::  IdP GhcPs -> [LHsType GhcPs] -> LHsType GhcPs+mkHsTyConApp tyconId tyargs = nlHsTyConApp NotPromoted Prefix tyconId (map (HsValArg noExtField) tyargs)++mkHsOverLit :: HsOverLit GhcPs -> HsExpr GhcPs+mkHsOverLit = HsOverLit noExtField
src-ghc/Liquid/GHC/API.hs view
@@ -18,27 +18,22 @@   ) where  import Liquid.GHC.API.Extra as Ghc+import Liquid.GHC.API.Compat as Ghc  import           GHC                  as Ghc     ( Class     , DataCon     , DesugaredModule(DesugaredModule, dm_typechecked_module, dm_core_module)-    , DynFlags(backend, debugLevel, ghcLink, ghcMode)+    , DynFlags(backend, debugLevel, ghcLink, ghcMode, warningFlags)     , FixityDirection(InfixN, InfixR)     , FixitySig(FixitySig)     , GenLocated(L)-    , GeneralFlag-        ( Opt_DeferTypedHoles-        , Opt_Haddock-        , Opt_ImplicitImportQualified-        , Opt_InsertBreakpoints-        , Opt_KeepRawTokenStream-        , Opt_PIC-        )+    , GeneralFlag(..)     , Ghc     , GhcException(CmdLineError, ProgramError)     , GhcLink(LinkInMemory)     , GhcMode(CompManager)+    , GhcMonad     , GhcPs     , GhcRn     , HsDecl(SigD)@@ -68,7 +63,7 @@     , Name     , NamedThing     , NamespaceSpecifier (NoNamespaceSpecifier)-    , ParsedModule (pm_mod_summary, pm_parsed_source)+    , ParsedModule(..)     , PredType     , RealSrcLoc     , RealSrcSpan@@ -83,9 +78,11 @@     , TypecheckedModule(tm_checked_module_info, tm_internals_, tm_parsed_module)     , classMethods     , classSCTheta+    , coreModule     , dataConTyCon     , dataConFieldLabels     , dataConWrapperType+    , desugarModule     , getLocA     , getLogger     , getName@@ -111,6 +108,7 @@     , isRecordSelector     , isTypeSynonymTyCon     , isVanillaDataCon+    , lookupName     , mkHsApp     , mkHsDictLet     , mkHsForAllInvisTele@@ -156,6 +154,7 @@     , tyConDataCons     , tyConKind     , tyConTyVars+    , typecheckModule     , unLoc     ) @@ -164,14 +163,12 @@     , Unique     , and_RDR     , bindMName-    , gHC_INTERNAL_DATA_FOLDABLE     , eqClassKey     , eqClassName     , ge_RDR     , gt_RDR     , fractionalClassKey     , fractionalClassKeys-    , gHC_INTERNAL_REAL     , getUnique     , hasKey     , isStringClassName@@ -202,6 +199,7 @@     , intTyCon     , intTyConName     , liftedTypeKind+    , liftedTypeKindTyConName     , listTyCon     , listTyConName     , naturalTy@@ -212,7 +210,9 @@     , trueDataConId     , tupleDataCon     , tupleTyCon+    , tupleTyConName     , typeSymbolKind+    , unrestrictedFunTyConName     ) import GHC.Builtin.Types.Prim         as Ghc     ( isArrowTyCon@@ -236,6 +236,7 @@     , Expr(App, Case, Cast, Coercion, Lam, Let, Lit, Tick, Type, Var)     , Unfolding(CoreUnfolding, DFunUnfolding, uf_tmpl)     , bindersOf+    , bindersOfBinds     , cmpAlt     , collectArgs     , collectBinders@@ -247,12 +248,16 @@     , maybeUnfoldingTemplate     , mkApps     , mkLams+    , mkLets     , mkTyApps     , mkTyArg+    , rhssOfAlts+    , rhssOfBind     ) import GHC.Core.Class                 as Ghc     ( classAllSelIds     , classBigSig+    , classOpItems     , classSCSelIds     , Class        ( classKey@@ -269,11 +274,7 @@     , mkRepReflCo     ) import GHC.Core.Coercion.Axiom        as Ghc-    ( Branched-    , CoAxiom-    , CoAxiomRule(CoAxiomRule)-    , coAxiomTyCon-    )+    ( coAxiomTyCon ) import GHC.Core.ConLike               as Ghc     ( ConLike(RealDataCon) ) import GHC.Core.DataCon               as Ghc@@ -294,6 +295,7 @@     , dataConWrapId     , dataConWrapId_maybe     , isTupleDataCon+    , promoteDataCon     ) import GHC.Core.FamInstEnv            as Ghc     ( FamFlavor(DataFamilyInst)@@ -307,8 +309,10 @@ import GHC.Core.InstEnv               as Ghc     ( ClsInst(is_cls, is_dfun, is_dfun_name, is_tys)     , DFunId+    , InstEnvs     , instEnvElts     , instanceSig+    , lookupInstEnv     ) import GHC.Core.Make                  as Ghc     ( mkCoreApps@@ -324,26 +328,7 @@ import GHC.Core.TyCo.Rep              as Ghc     ( FunTyFlag(FTF_T_T, FTF_C_T)     , ForAllTyFlag(Required)-    , Coercion-        ( AppCo-        , AxiomRuleCo-        , AxiomInstCo-        , CoVarCo-        , ForAllCo-        , FunCo-        , HoleCo-        , InstCo-        , KindCo-        , LRCo-        , Refl-        , GRefl-        , SelCo-        , SubCo-        , SymCo-        , TransCo-        , TyConAppCo-        , UnivCo-        )+    , Coercion (AxiomInstCo, SymCo)     , TyLit(CharTyLit, NumTyLit, StrTyLit)     , Type         ( AppTy@@ -365,6 +350,7 @@     , mkTyVarTys     ) import GHC.Core.TyCo.Compare          as Ghc (eqType, nonDetCmpType)+import GHC.Core.TyCo.Subst            as Ghc (extendSubstInScopeSet, substCo, zipTvSubst) import GHC.Core.TyCon                 as Ghc     ( TyConBinder     , TyConBndrVis(AnonTCB)@@ -376,6 +362,7 @@     , isTupleTyCon     , isVanillaAlgTyCon     , mkPrimTyCon+    , newTyConEtadArity     , newTyConRhs     , tyConBinders     , tyConDataCons_maybe@@ -421,6 +408,7 @@     , bytesFS     , concatFS     , fsLit+    , lexicalCompareFS     , mkFastString     , mkFastStringByteString     , mkPtrString#@@ -434,24 +422,25 @@     , initDsMessageOpts     , initIfaceMessageOpts     )-import GHC.Driver.Main                as Ghc-    ( hscDesugar-    , hscTcRcLookupName+import GHC.Driver.Plugins             as Ghc+    ( ParsedResult(..)     ) import GHC.Driver.Phases              as Ghc (Phase(StopLn)) import GHC.Driver.Pipeline            as Ghc (compileFile) import GHC.Driver.Session             as Ghc     ( getDynFlags     , gopt_set+    , gopt_unset     , updOptLevel     , xopt_set     )-import GHC.Driver.Monad               as Ghc (withSession)+import GHC.Driver.Monad               as Ghc (withSession, reflectGhc, Session(..)) import GHC.HsToCore.Monad             as Ghc     ( DsM, initDsTc, initDsWithModGuts, newUnique ) import GHC.Iface.Syntax               as Ghc     ( IfaceAnnotation(ifAnnotatedValue) )-import GHC.Plugins                    as Ghc ( deserializeWithData+import GHC.Plugins                    as Ghc ( Serialized(Serialized)+                                             , deserializeWithData                                              , fromSerialized                                              , toSerialized                                              , defaultPlugin@@ -462,20 +451,36 @@                                              , extendIdSubst                                              , substExpr                                              )-import GHC.Core.FVs                   as Ghc (exprFreeVarsList)+import GHC.Core.FVs                   as Ghc+    ( exprFreeVars+    , exprFreeVarsList+    , exprsOrphNames+    , exprSomeFreeVarsList+    ) import GHC.Core.Opt.OccurAnal         as Ghc     ( occurAnalysePgm )+import GHC.Core.TyCo.FVs              as Ghc (tyCoVarsOfCo, tyCoVarsOfType) import GHC.Driver.Backend             as Ghc (interpreterBackend) import GHC.Driver.Env                 as Ghc-    ( HscEnv(hsc_mod_graph, hsc_unit_env, hsc_dflags, hsc_plugins) )+    ( HscEnv(hsc_NC, hsc_unit_env, hsc_dflags, hsc_plugins)+    , Hsc+    , hscSetFlags, hscUpdateFlags+    )+import GHC.Driver.Main                as Ghc+    ( hscDesugar ) import GHC.Driver.Errors              as Ghc     ( printMessages ) import GHC.Driver.Ppr                 as Ghc     ( showPpr     , showSDoc     )+import GHC.Hs                         as Ghc+    ( HsParsedModule(..)+    ) import GHC.HsToCore.Expr              as Ghc     ( dsLExpr )+import GHC.Iface.Binary               as Ghc+    ( TraceBinIFace(QuietBinIFace), getWithUserData, putWithUserData ) import GHC.Iface.Errors.Ppr            as Ghc     ( missingInterfaceErrorDiagnostic ) import GHC.Iface.Load                 as Ghc@@ -500,17 +505,30 @@     ) import GHC.Tc.Types                   as Ghc     ( Env(env_top)-    , TcGblEnv(tcg_anns, tcg_exports, tcg_insts, tcg_mod, tcg_rdr_env, tcg_rn_imports)+    , TcGblEnv+        ( tcg_anns+        , tcg_exports+        , tcg_imports+        , tcg_insts+        , tcg_mod+        , tcg_rdr_env+        , tcg_type_env+        )     , TcM     , TcRn     ) import GHC.Tc.Types.Evidence          as Ghc     ( TcEvBinds(EvBinds) ) import GHC.Tc.Types.Origin            as Ghc (lexprCtOrigin)+import GHC.Tc.Utils.Env               as Ghc+    ( tcGetInstEnvs ) import GHC.Tc.Utils.Monad             as Ghc     ( captureConstraints     , discardConstraints+    , getGblEnv+    , setGblEnv     , getEnv+    , getTopEnv     , failIfErrsM     , failM     , failWithTc@@ -521,6 +539,8 @@     , pushTcLevelM     , reportDiagnostic     , reportDiagnostics+    , updEnv+    , updTopEnv     ) import GHC.Tc.Utils.TcType            as Ghc (tcSplitDFunTy, tcSplitMethodTy) import GHC.Tc.Zonk.Type               as Ghc@@ -536,16 +556,20 @@ import GHC.Types.Avail                as Ghc     ( AvailInfo(Avail, AvailTC)     , availNames+    , availsToNameSet     ) import GHC.Types.Basic                as Ghc     ( Arity     , Boxity(Boxed)+    , DefMethSpec(VanillaDM)     , PprPrec     , PromotionFlag(NotPromoted)     , TopLevelFlag(NotTopLevel)+    , TupleSort(BoxedTuple)     , funPrec     , InlinePragma(inl_act, inl_inline, inl_rule, inl_sat, inl_src)     , isDeadOcc+    , isNoInlinePragma     , isStrongLoopBreaker     , noOccInfo     , topPrec@@ -572,19 +596,21 @@     , idInfo     , idOccInfo     , isConLikeId+    , idInlinePragma     , modifyIdInfo     , mkExportedLocalId-    , mkUserLocal+    , mkUserLocalOrCoVar     , realIdUnfolding     , setIdInfo     ) import GHC.Types.Id.Info              as Ghc     ( CafInfo(NoCafRefs)-    , IdDetails(DataConWorkId, DataConWrapId, RecSelId, VanillaId)+    , IdDetails(ClassOpId, DataConWorkId, DataConWrapId, RecSelId, VanillaId)     , IdInfo(occInfo, realUnfoldingInfo)     , cafInfo     , inlinePragInfo     , mayHaveCafRefs+    , realUnfoldingInfo     , setCafInfo     , setOccInfo     , vanillaIdInfo@@ -600,6 +626,7 @@     , getSrcSpan     , isInternalName     , isSystemName+    , isTupleTyConName     , mkInternalName     , mkSystemName     , mkTcOcc@@ -607,19 +634,56 @@     , mkVarOcc     , mkVarOccFS     , nameModule_maybe+    , nameNameSpace     , nameOccName     , nameSrcLoc     , nameStableString+    , nameUnique     , occNameFS     , occNameString     , stableNameCmp     )+import GHC.Types.Name.Env             as Ghc+    ( NameEnv+    , lookupNameEnv+    , mkNameEnv+    , mkNameEnvWith+    )+import GHC.Types.Name.Set             as Ghc+    ( NameSet+    , elemNameSet+    , nameSetElemsStable+    )+import GHC.Types.Name.Cache           as Ghc (NameCache)+import GHC.Types.Name.Occurrence      as Ghc+    ( NameSpace+    , isFieldNameSpace+    , mkOccName+    , dataName+    , tcName+    ) import GHC.Types.Name.Reader          as Ghc-    ( ImpItemSpec(ImpAll)+    ( FieldsOrSelectors(WantNormal)+    , GlobalRdrEnv+    , GREInfo+    , ImpItemSpec(ImpAll)+    , LookupGRE(LookupRdrName)+    , WhichGREs+        ( SameNameSpace+        , RelevantGREs+        , includeFieldSelectors+        , lookupTyConsAsWell+        , lookupVariablesForFields+        )     , getRdrName     , globalRdrEnvElts     , greName+    , isLocalGRE+    , lookupGRE+    , lookupGRE_Name     , mkQual+    , mkRdrQual+    , mkRdrUnqual     , mkVarUnqual     , mkUnqual     , nameRdrName@@ -651,6 +715,12 @@     , srcSpanToRealSrcSpan     ) import GHC.Types.Tickish              as Ghc (CoreTickish, GenTickish(..))+import GHC.Types.TypeEnv              as Ghc+    ( TypeEnv+    , lookupTypeEnv+    , mkTypeEnv+    , plusTypeEnv+    ) import GHC.Types.Unique               as Ghc     ( getKey, mkUnique ) import GHC.Types.Unique.Set           as Ghc (mkUniqSet)@@ -695,13 +765,23 @@     , IsBootInterface(NotBoot, IsBoot)     , ModuleNameWithIsBoot     , UnitId+    , lookupModuleEnv+    , stableModuleCmp     , fsToUnit     , mkModuleNameFS+    , moduleEnvKeys     , moduleNameFS     , moduleStableString     , toUnitId     , unitString     )+import GHC.Unit.Module.Deps       as Ghc+    ( ImportAvails(imp_mods) )+import GHC.Unit.Module.Imported       as Ghc+    ( ImportedMods+    , ImportedModsVal(imv_name, imv_qualified)+    , importedByUser+    ) import GHC.Unit.Module.ModGuts        as Ghc     ( ModGuts       ( mg_binds@@ -713,7 +793,20 @@       , mg_usages       )     )+import GHC.Unit.Types                 as Ghc+    ( moduleUnitId+    , unitIdString+    )+import GHC.Utils.Binary               as Ghc+    ( Binary(get, put_)+    , getByte+    , openBinMem+    , putByte+    , unsafeUnpackBinBuffer+    , withBinBuffer+    ) import GHC.Utils.Error                as Ghc (pprLocMsgEnvelope, withTiming) import GHC.Utils.Logger               as Ghc (Logger(logFlags), putLogMsg) import GHC.Utils.Outputable           as Ghc hiding ((<>)) import GHC.Utils.Panic                as Ghc (panic, throwGhcException, throwGhcExceptionIO)+import GHC.Utils.Misc                 as Ghc (lengthAtLeast)
src-ghc/Liquid/GHC/API/Extra.hs view
@@ -6,19 +6,15 @@ module Liquid.GHC.API.Extra (     module StableModule   , ApiComment(..)+  , addNoInlinePragmasToBinds   , apiComments   , apiCommentsParsedSource   , dataConSig-  , desugarModuleIO+  , directImports   , fsToUnitId   , isPatErrorAlt-  , lookupModSummary   , minus_RDR-  , modInfoLookupNameIO-  , moduleInfoTc-  , parseModuleIO   , qualifiedNameFS-  , relevantModules   , renderWithStyle   , showPprQualified   , showPprDebug@@ -27,19 +23,15 @@   , strictNothing   , thisPackage   , tyConRealArity-  , typecheckModuleIO   , untick   ) where -import Control.Monad.IO.Class import           Liquid.GHC.API.StableModule      as StableModule-import GHC-import Data.Data (Data, gmapQr)-import Data.Generics (extQ)+import GHC hiding (modInfoLookupName)+import Data.Data (Data, gmapQr, gmapT)+import Data.Generics (extQ, extT) import Data.Foldable                  (asum) import Data.List                      (sortOn)-import qualified Data.Map as Map-import qualified Data.Set as S import GHC.Builtin.Names ( dollarIdKey, minusName ) import GHC.Core                       as Ghc import GHC.Core.Coercion              as Ghc@@ -47,33 +39,20 @@ import GHC.Core.Make                  (pAT_ERROR_ID) import GHC.Core.Type                  as Ghc hiding (typeKind , isPredTy, extendCvSubst, linear) import GHC.Data.FastString            as Ghc-import qualified GHC.Data.EnumSet as EnumSet import GHC.Data.Maybe import qualified GHC.Data.Strict-import GHC.Driver.Env-import GHC.Driver.Main import GHC.Driver.Session             as Ghc import GHC.Tc.Types+import GHC.Types.Id+import GHC.Types.Basic import GHC.Types.Name                 (isSystemName, nameModule_maybe, occNameFS) import GHC.Types.Name.Reader          (nameRdrName) import GHC.Types.SrcLoc               as Ghc-import GHC.Types.TypeEnv import GHC.Types.Unique               (getUnique, hasKey)-import GHC.Types.Unique.FM -import GHC.Unit.Module.Deps           as Ghc (Dependencies(dep_direct_mods))-import GHC.Unit.Module.Graph          as Ghc-  ( NodeKey(NodeKey_Module)-  , ModNodeKeyWithUid(ModNodeKeyWithUid)-  , mgTransDeps-  )-import GHC.Unit.Module.ModDetails     (md_types)-import GHC.Unit.Module.ModSummary     (isBootSummary) import GHC.Utils.Outputable           as Ghc hiding ((<>))  import GHC.Unit.Module-import GHC.Unit.Module.ModGuts-import GHC.Unit.Module.Deps (Usage(..))  -- 'fsToUnitId' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'. fsToUnitId :: FastString -> UnitId@@ -92,18 +71,6 @@         Nothing -> acc         Just ks -> go (acc + 1) ks -getDependenciesModuleNames :: ModuleGraph -> UnitId -> Dependencies -> [ModuleNameWithIsBoot]-getDependenciesModuleNames mg unitId deps =-    mapMaybe nodeKeyToModuleName $ S.toList $ S.unions $ catMaybes-      [ Map.lookup k tdeps-      | (_, m) <- S.toList $ dep_direct_mods deps-      , let k = NodeKey_Module $ ModNodeKeyWithUid m unitId-      ]-  where-    tdeps = mgTransDeps mg-    nodeKeyToModuleName (NodeKey_Module (ModNodeKeyWithUid m _)) = Just m-    nodeKeyToModuleName _ = Nothing- renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String renderWithStyle dynflags sdoc style = Ghc.renderWithContext (Ghc.initSDocContext dynflags style) sdoc @@ -112,81 +79,9 @@ dataConSig dc   = (dataConUnivAndExTyCoVars dc, dataConTheta dc, map irrelevantMult $ dataConOrigArgTys dc, dataConOrigResTy dc) --- | The collection of dependencies and usages modules which are relevant for liquidHaskell-relevantModules :: ModuleGraph -> ModGuts -> S.Set Module-relevantModules mg modGuts = used `S.union` dependencies-  where-    dependencies :: S.Set Module-    dependencies = S.fromList $ map (toModule . gwib_mod)-                              . filter ((NotBoot ==) . gwib_isBoot)-                              . getDependenciesModuleNames mg thisUnitId $ deps--    deps :: Dependencies-    deps = mg_deps modGuts--    thisModule :: Module-    thisModule = mg_module modGuts--    thisUnitId = moduleUnitId thisModule--    toModule :: ModuleName -> Module-    toModule = unStableModule . mkStableModule thisUnitId--    used :: S.Set Module-    used = S.fromList $ foldl' collectUsage mempty . mg_usages $ modGuts-      where-        collectUsage :: [Module] -> Usage -> [Module]-        collectUsage acc = \case-          UsagePackageModule     { usg_mod      = modl    } -> modl : acc-          UsageHomeModule        { usg_mod_name = modName } -> toModule modName : acc-          UsageMergedRequirement { usg_mod      = modl    } -> modl : acc-          _ -> acc------- Parsing, typechecking and desugaring a module----parseModuleIO :: HscEnv -> ModSummary -> IO ParsedModule-parseModuleIO hscEnv ms = do-  let hsc_env_tmp = hscEnv { hsc_dflags = ms_hspp_opts ms }-  hpm <- hscParse hsc_env_tmp ms-  return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))---- | Our own simplified version of 'TypecheckedModule'.-data TypecheckedModuleLH = TypecheckedModuleLH {-    tmlh_parsed_module  :: ParsedModule-  , tmlh_renamed_source :: Maybe RenamedSource-  , tmlh_mod_summary    :: ModSummary-  , tmlh_gbl_env        :: TcGblEnv-  }--typecheckModuleIO :: HscEnv -> ParsedModule -> IO TypecheckedModuleLH-typecheckModuleIO hscEnv pmod = do-  -- Suppress all the warnings, so that they won't be printed (which would result in them being-  -- printed twice, one by GHC and once here).-  let ms = pm_mod_summary pmod-  let dynFlags' = ms_hspp_opts ms-  let hsc_env_tmp = hscEnv { hsc_dflags = dynFlags' { warningFlags = EnumSet.empty } }-  (tc_gbl_env, rn_info)-        <- hscTypecheckRename hsc_env_tmp ms $-                       HsParsedModule { hpm_module = parsedSource pmod,-                                        hpm_src_files = pm_extra_src_files pmod }-  return TypecheckedModuleLH {-      tmlh_parsed_module  = pmod-    , tmlh_renamed_source = rn_info-    , tmlh_mod_summary    = ms-    , tmlh_gbl_env        = tc_gbl_env-    }---- | Desugar a typechecked module.-desugarModuleIO :: HscEnv -> ModSummary -> TypecheckedModuleLH -> IO ModGuts-desugarModuleIO hscEnv originalModSum typechecked = do-  -- See [NOTE:ghc810] on why we override the dynFlags here before calling 'desugarModule'.-  let modSum         = originalModSum { ms_hspp_opts = hsc_dflags hscEnv }-  let parsedMod'     = (tmlh_parsed_module typechecked) { pm_mod_summary = modSum }-  let typechecked'   = typechecked { tmlh_parsed_module = parsedMod' }--  let hsc_env_tmp = hscEnv { hsc_dflags = ms_hspp_opts (tmlh_mod_summary typechecked') }-  hscDesugar hsc_env_tmp (tmlh_mod_summary typechecked') (tmlh_gbl_env typechecked')+-- | Extracts the direct imports of a module.+directImports :: TcGblEnv -> [Module]+directImports = moduleEnvKeys . imp_mods . tcg_imports  -- | Abstraction of 'EpaComment'. data ApiComment@@ -195,8 +90,8 @@   deriving (Eq, Show)  -- | Extract top-level comments from a module.-apiComments :: ParsedModule -> [Ghc.Located ApiComment]-apiComments pm = apiCommentsParsedSource (pm_parsed_source pm)+apiComments :: HsParsedModule -> [Ghc.Located ApiComment]+apiComments = apiCommentsParsedSource . hpm_module  apiCommentsParsedSource :: Located (HsModule GhcPs) -> [Ghc.Located ApiComment] apiCommentsParsedSource ps =@@ -217,35 +112,62 @@     spanToLineColumn =       fmap (\s -> (srcSpanStartLine s, srcSpanStartCol s)) . srcSpanToRealSrcSpan -lookupModSummary :: HscEnv -> ModuleName -> Maybe ModSummary-lookupModSummary hscEnv mdl = do-   let mg = hsc_mod_graph hscEnv-       mods_by_name = [ ms | ms <- mgModSummaries mg-                      , ms_mod_name ms == mdl-                      , NotBoot == isBootSummary ms ]-   case mods_by_name of-     [ms] -> Just ms-     _    -> Nothing+-- | Adds NOINLINE pragmas to all bindings in the module.+--+-- This prevents the simple optimizer from inlining such bindings which might+-- have specs that would otherwise be left dangling.+--+-- https://gitlab.haskell.org/ghc/ghc/-/issues/24386+--+addNoInlinePragmasToBinds :: TcGblEnv -> TcGblEnv+addNoInlinePragmasToBinds tcg = tcg{ tcg_binds = go (tcg_binds tcg) }+  where+    go :: forall a. Data a => a -> a+    go = gmapT $ go `extT` markHsBind --- | Our own simplified version of 'ModuleInfo' to overcome the fact we cannot construct the \"original\"--- one as the constructor is not exported, and 'getHomeModuleInfo' and 'getPackageModuleInfo' are not--- exported either, so we had to backport them as well.-newtype ModuleInfoLH = ModuleInfoLH { minflh_type_env :: UniqFM Name TyThing }+    -- Mark all user-originating `Id` binders as `NOINLINE`.+    markHsBind :: HsBind GhcTc -> HsBind GhcTc+    markHsBind = \case+        bind@VarBind{ var_id = var, var_rhs = rhs } -> bind{ var_id = markId var, var_rhs = go rhs }+        bind@FunBind{ fun_id = var, fun_matches = matches } -> bind{ fun_id = markId <$> var, fun_matches = go matches }+        bind@PatBind{ pat_lhs = lhs, pat_rhs = rhs } -> bind{ pat_lhs = markPat <$> lhs, pat_rhs = go rhs }+        PatSynBind{} -> error "markNoInline: unexpected PatSynBind, should have been eliminated by the typechecker"+        XHsBindsLR absBinds -> XHsBindsLR (markAbsBinds absBinds) -modInfoLookupNameIO :: HscEnv-                  -> ModuleInfoLH-                  -> Name-                  -> IO (Maybe TyThing)-modInfoLookupNameIO hscEnv minf name =-  case lookupTypeEnv (minflh_type_env minf) name of-    Just tyThing -> return (Just tyThing)-    Nothing      -> lookupType hscEnv name+    markPat :: Pat GhcTc -> Pat GhcTc+    markPat = \case+        VarPat ext var -> VarPat ext (markId <$> var)+        pat -> gmapT (id `extT` markPat) pat -moduleInfoTc :: HscEnv -> TcGblEnv -> IO ModuleInfoLH-moduleInfoTc hscEnv tcGblEnv = do-  details <- md_types <$> liftIO (makeSimpleDetails (hsc_logger hscEnv) tcGblEnv)-  pure ModuleInfoLH { minflh_type_env = details }+    markId :: Id -> Id+    markId var = var `setInlinePragma` neverInlinePragma +    -- The AbsBinds come from the GHC typechecker to handle polymorphism,+    -- overloading, and recursion, so those don't correspond directly to+    -- user-written `Id`s except for those in @abs_exports@. For instance,+    -- @tests/pos/Map0.hs@ would fail if Ids in @abs_exports@ are not marked.+    --+    -- See+    -- https://github.com/ucsd-progsys/liquidhaskell/issues/2257 for more+    -- context.+    markAbsBinds :: AbsBinds -> AbsBinds+    markAbsBinds absBinds0@AbsBinds{ abs_binds = binds, abs_exports = exports }  =+        absBinds0+          { abs_binds = fmap skipFirstHsBind <$> binds+          , abs_exports = map markABE exports+          }+      where+        skipFirstHsBind :: HsBind GhcTc -> HsBind GhcTc+        skipFirstHsBind = \case+          XHsBindsLR absBinds -> XHsBindsLR (markAbsBinds absBinds)+          b -> gmapT go b++        markABE :: ABExport -> ABExport+        markABE abe@ABE{ abe_poly = poly+                       , abe_mono = mono } = abe+          { abe_poly = markId poly+          , abe_mono = markId mono }+ -- | Tells if a case alternative calls to patError isPatErrorAlt :: CoreAlt -> Bool isPatErrorAlt (Alt _ _ exprCoreBndr) = hasPatErrorCall exprCoreBndr@@ -253,14 +175,23 @@    hasPatErrorCall :: CoreExpr -> Bool    -- auto generated undefined case: (\_ -> (patError @levity @type "error message")) void    -- Type arguments are erased before calling isUndefined-   hasPatErrorCall (App (Var x) _) = x == pAT_ERROR_ID+   hasPatErrorCall (App e _)+     | Var x <- unTick e = x == pAT_ERROR_ID+     | otherwise = hasPatErrorCall e    -- another auto generated undefined case:    -- let lqanf_... = patError "error message") in case lqanf_... of {}-   hasPatErrorCall (Let (NonRec x e) (Case (Var v) _ _ []))-     | x == v = hasPatErrorCall e+   hasPatErrorCall (Let (NonRec x e) ec)+     | Case e0 _ _ [] <- unTick ec+     , Var v <- unTick e0+     , x == v = hasPatErrorCall e+   hasPatErrorCall (Case e _ _ _) = hasPatErrorCall e    hasPatErrorCall (Let _ e) = hasPatErrorCall e+   hasPatErrorCall (Tick _ e) = hasPatErrorCall e    -- otherwise    hasPatErrorCall _ = False++   unTick (Tick _ e) = unTick e+   unTick e = e   qualifiedNameFS :: Name -> FastString
src-ghc/Liquid/GHC/API/StableModule.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}  {-# OPTIONS_GHC -Wno-orphans #-} @@ -16,6 +17,7 @@ import qualified GHC import qualified GHC.Unit.Types as GHC import qualified GHC.Unit.Module as GHC+import           Data.Data (Data) import           Data.Hashable import           GHC.Generics            hiding (to, moduleName) import           Data.Binary@@ -27,7 +29,7 @@ -- newtype StableModule =   StableModule { unStableModule :: GHC.Module }-  deriving Generic+  deriving (Data, Generic)  -- | Converts a 'Module' into a 'StableModule'. toStableModule :: GHC.Module -> StableModule
src/Language/Haskell/Liquid/Bare.hs view
@@ -1,1320 +1,1417 @@ {-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE PartialTypeSignatures     #-}-{-# LANGUAGE OverloadedStrings         #-}---- | This module contains the functions that convert /from/ descriptions of---   symbols, names and types (over freshly parsed /bare/ Strings),---   /to/ representations connected to GHC 'Var's, 'Name's, and 'Type's.---   The actual /representations/ of bare and real (refinement) types are all---   in 'RefType' -- they are different instances of 'RType'.--module Language.Haskell.Liquid.Bare (-  -- * Creating a TargetSpec-  -- $creatingTargetSpecs-    makeTargetSpec--  -- * Loading and Saving lifted specs from/to disk-  , loadLiftedSpec-  , saveLiftedSpec-  ) where--import           Prelude                                    hiding (error)-import           Control.Monad                              (forM, mplus)-import           Control.Applicative                        ((<|>))-import qualified Control.Exception                          as Ex-import qualified Data.Binary                                as B-import qualified Data.Maybe                                 as Mb-import qualified Data.List                                  as L-import qualified Data.HashMap.Strict                        as M-import qualified Data.HashSet                               as S-import           Text.PrettyPrint.HughesPJ                  hiding (first, (<>)) -- (text, (<+>))-import           System.FilePath                            (dropExtension)-import           System.Directory                           (doesFileExist)-import           System.Console.CmdArgs.Verbosity           (whenLoud)-import           Language.Fixpoint.Utils.Files              as Files-import           Language.Fixpoint.Misc                     as Misc-import           Language.Fixpoint.Types                    hiding (dcFields, DataDecl, Error, panic)-import qualified Language.Fixpoint.Types                    as F-import qualified Language.Haskell.Liquid.Misc               as Misc -- (nubHashOn)-import qualified Language.Haskell.Liquid.GHC.Misc           as GM-import qualified Liquid.GHC.API            as Ghc-import           Language.Haskell.Liquid.GHC.Types          (StableName)-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.WiredIn-import qualified Language.Haskell.Liquid.Measure            as Ms-import qualified Language.Haskell.Liquid.Bare.Types         as Bare-import qualified Language.Haskell.Liquid.Bare.Resolve       as Bare-import qualified Language.Haskell.Liquid.Bare.DataType      as Bare-import           Language.Haskell.Liquid.Bare.Elaborate-import qualified Language.Haskell.Liquid.Bare.Expand        as Bare-import qualified Language.Haskell.Liquid.Bare.Measure       as Bare-import qualified Language.Haskell.Liquid.Bare.Plugged       as Bare-import qualified Language.Haskell.Liquid.Bare.Axiom         as Bare-import qualified Language.Haskell.Liquid.Bare.ToBare        as Bare-import qualified Language.Haskell.Liquid.Bare.Class         as Bare-import qualified Language.Haskell.Liquid.Bare.Check         as Bare-import qualified Language.Haskell.Liquid.Bare.Laws          as Bare-import qualified Language.Haskell.Liquid.Bare.Typeclass     as Bare-import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic-import           Control.Arrow                    (second)-import Data.Hashable (Hashable)-import qualified Language.Haskell.Liquid.Bare.Slice as Dg-import Data.Bifunctor (bimap)-import Data.Function (on)------------------------------------------------------------------------------------- | De/Serializing Spec files-----------------------------------------------------------------------------------loadLiftedSpec :: Config -> FilePath -> IO (Maybe Ms.BareSpec)-loadLiftedSpec cfg srcF-  | noLiftedImport cfg = putStrLn "No LIFTED Import" >> return Nothing-  | otherwise          = do-      let specF = extFileName BinSpec srcF-      ex  <- doesFileExist specF-      whenLoud $ putStrLn $ "Loading Binary Lifted Spec: " ++ specF ++ " " ++ "for source-file: " ++ show srcF ++ " " ++ show ex-      lSp <- if ex-               then Just <$> B.decodeFile specF-               else {- warnMissingLiftedSpec srcF specF >> -} return Nothing-      Ex.evaluate lSp---- warnMissingLiftedSpec :: FilePath -> FilePath -> IO ()--- warnMissingLiftedSpec srcF specF = do---   incDir <- Misc.getIncludeDir---   unless (Misc.isIncludeFile incDir srcF)---     $ Ex.throw (errMissingSpec srcF specF)--saveLiftedSpec :: FilePath -> Ms.BareSpec -> IO ()-saveLiftedSpec srcF lspec = do-  ensurePath specF-  B.encodeFile specF lspec-  -- print (errorP "DIE" "HERE" :: String)-  where-    specF = extFileName BinSpec srcF--{- $creatingTargetSpecs--/Liquid Haskell/ operates on 'TargetSpec's, so this module provides a single function called-'makeTargetSpec' to produce a 'TargetSpec', alongside the 'LiftedSpec'. The former will be used by-functions like 'liquid' or 'liquidOne' to verify our program is correct, the latter will be serialised-to disk so that we can retrieve it later without having to re-check the relevant Haskell file.--}---- | 'makeTargetSpec' constructs the 'TargetSpec' and then validates it. Upon success, the 'TargetSpec'--- and the 'LiftedSpec' are returned. We perform error checking in \"two phases\": during the first phase,--- we check for errors and warnings in the input 'BareSpec' and the dependencies. During this phase we ideally--- want to short-circuit in case the validation failure is found in one of the dependencies (to avoid--- printing potentially endless failures).--- The second phase involves creating the 'TargetSpec', and returning either the full list of diagnostics--- (errors and warnings) in case things went wrong, or the final 'TargetSpec' and 'LiftedSpec' together--- with a list of 'Warning's, which shouldn't abort the compilation (modulo explicit request from the user,--- to treat warnings and errors).-makeTargetSpec :: Config-               -> LogicMap-               -> TargetSrc-               -> BareSpec-               -> TargetDependencies-               -> Ghc.TcRn (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))-makeTargetSpec cfg lmap targetSrc bareSpec dependencies = do-  let targDiagnostics     = Bare.checkTargetSrc cfg targetSrc-  let depsDiagnostics     = mapM (uncurry Bare.checkBareSpec) legacyDependencies-  let bareSpecDiagnostics = Bare.checkBareSpec (giTargetMod targetSrc) legacyBareSpec-  case targDiagnostics >> depsDiagnostics >> bareSpecDiagnostics of-   Left d | noErrors d -> secondPhase (allWarnings d)-   Left d              -> return $ Left d-   Right ()            -> secondPhase mempty-  where-    secondPhase :: [Warning] -> Ghc.TcRn (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))-    secondPhase phaseOneWarns = do--      -- we should be able to setContext regardless of whether-      -- we use the ghc api. However, ghc will complain-      -- if the filename does not match the module name-      -- when (typeclass cfg) $ do-      --   Ghc.setContext [iimport |(modName, _) <- allSpecs legacyBareSpec,-      --                   let iimport = if isTarget modName-      --                                 then Ghc.IIModule (getModName modName)-      --                                 else Ghc.IIDecl (Ghc.simpleImportDecl (getModName modName))]-      --   void $ Ghc.execStmt-      --     "let {infixr 1 ==>; True ==> False = False; _ ==> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixr 1 <=>; True <=> False = False; _ <=> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 ==; (==) :: a -> a -> Bool; _ == _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {len :: [a] -> Int; len _ = undefined}"-      --     Ghc.execOptions--      diagOrSpec <- makeGhcSpec cfg (fromTargetSrc targetSrc) lmap (allSpecs legacyBareSpec)-      return $ do-        (warns, ghcSpec) <- diagOrSpec-        let (targetSpec, liftedSpec) = toTargetSpec ghcSpec-        pure (phaseOneWarns <> warns, targetSpec, liftedSpec)--    toLegacyDep :: (Ghc.StableModule, LiftedSpec) -> (ModName, Ms.BareSpec)-    toLegacyDep (sm, ls) = (ModName SrcImport (Ghc.moduleName . Ghc.unStableModule $ sm), unsafeFromLiftedSpec ls)--    toLegacyTarget :: Ms.BareSpec -> (ModName, Ms.BareSpec)-    toLegacyTarget validatedSpec = (giTargetMod targetSrc, validatedSpec)--    legacyDependencies :: [(ModName, Ms.BareSpec)]-    legacyDependencies = map toLegacyDep . M.toList . getDependencies $ dependencies--    allSpecs :: Ms.BareSpec -> [(ModName, Ms.BareSpec)]-    allSpecs validSpec = toLegacyTarget validSpec : legacyDependencies--    legacyBareSpec :: Spec LocBareType F.LocSymbol-    legacyBareSpec = fromBareSpec bareSpec------------------------------------------------------------------------------------------ | @makeGhcSpec@ invokes @makeGhcSpec0@ to construct the @GhcSpec@ and then---   validates it using @checkGhcSpec@.---------------------------------------------------------------------------------------makeGhcSpec :: Config-            -> GhcSrc-            -> LogicMap-            -> [(ModName, Ms.BareSpec)]-            -> Ghc.TcRn (Either Diagnostics ([Warning], GhcSpec))---------------------------------------------------------------------------------------makeGhcSpec cfg src lmap validatedSpecs = do-  (dg0, sp) <- makeGhcSpec0 cfg src lmap validatedSpecs-  let diagnostics = Bare.checkTargetSpec (map snd validatedSpecs)-                                         (toTargetSrc src)-                                         (ghcSpecEnv sp)-                                         (_giCbs src)-                                         (fst . toTargetSpec $ sp)-  pure $ if not (noErrors dg0) then Left dg0 else-           case diagnostics of-             Left dg1-               | noErrors dg1 -> pure (allWarnings dg1, sp)-               | otherwise    -> Left dg1-             Right ()         -> pure (mempty, sp)---ghcSpecEnv :: GhcSpec -> SEnv SortedReft-ghcSpecEnv sp = F.notracepp "RENV" $ fromListSEnv binds-  where-    emb       = gsTcEmbeds (_gsName sp)-    binds     = F.notracepp "binds" $ concat-                 [ [(x,        rSort t) | (x, Loc _ _ t)  <- gsMeas     (_gsData sp)]-                 , [(symbol v, rSort t) | (v, Loc _ _ t)  <- gsCtors    (_gsData sp)]-                 , [(symbol v, vSort v) | v               <- gsReflects (_gsRefl sp)]-                 , [(x,        vSort v) | (x, v)          <- gsFreeSyms (_gsName sp), Ghc.isConLikeId v ]-                 , [(x, RR s mempty)    | (x, s)          <- wiredSortedSyms       ]-                 , [(x, RR s mempty)    | (x, s)          <- _gsImps sp       ]-                 ]-    vSort     = rSort . classRFInfoType (typeclass $ getConfig sp) .-                (ofType :: Ghc.Type -> SpecType) . Ghc.varType-    rSort     = rTypeSortedReft    emb------------------------------------------------------------------------------------------- | @makeGhcSpec0@ slurps up all the relevant information needed to generate---   constraints for a target module and packages them into a @GhcSpec@---   See [NOTE] LIFTING-STAGES to see why we split into lSpec0, lSpec1, etc.---   essentially, to get to the `BareRTEnv` as soon as possible, as thats what---   lets us use aliases inside data-constructor definitions.---------------------------------------------------------------------------------------makeGhcSpec0 :: Config -> GhcSrc ->  LogicMap -> [(ModName, Ms.BareSpec)] ->-                Ghc.TcRn (Diagnostics, GhcSpec)-makeGhcSpec0 cfg src lmap mspecsNoCls = do-  -- build up environments-  tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg simplifier-  let tyi      = Bare.tcTyConMap   tycEnv-  let sigEnv   = makeSigEnv  embs tyi (_gsExports src) rtEnv-  let lSpec1   = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1-  let mySpec   = mySpec2 <> lSpec1-  let specs    = M.insert name mySpec iSpecs2-  let myRTE    = myRTEnv       src env sigEnv rtEnv-  let (dg5, measEnv) = withDiagnostics $ makeMeasEnv      env tycEnv sigEnv       specs-  let (dg4, sig) = withDiagnostics $ makeSpecSig cfg name specs env sigEnv   tycEnv measEnv (_giCbs src)-  elaboratedSig <--    if allowTC then Bare.makeClassAuxTypes (elaborateSpecType coreToLg simplifier) datacons instMethods-                              >>= elaborateSig sig-               else pure sig-  let qual     = makeSpecQual cfg env tycEnv measEnv rtEnv specs-  let sData    = makeSpecData  src env sigEnv measEnv elaboratedSig specs-  let (dg1, spcVars) = withDiagnostics $ makeSpecVars cfg src mySpec env measEnv-  let (dg2, spcTerm) = withDiagnostics $ makeSpecTerm cfg     mySpec env       name-  let (dg3, refl)    = withDiagnostics $ makeSpecRefl cfg src measEnv specs env name elaboratedSig tycEnv-  let laws     = makeSpecLaws env sigEnv (gsTySigs elaboratedSig ++ gsAsmSigs elaboratedSig) measEnv specs-  let finalLiftedSpec = makeLiftedSpec name src env refl sData elaboratedSig qual myRTE lSpec1-  let diags    = mconcat [dg0, dg1, dg2, dg3, dg4, dg5]--  pure (diags, SP-    { _gsConfig = cfg-    , _gsImps   = makeImports mspecs-    , _gsSig    = addReflSigs env name rtEnv refl elaboratedSig-    , _gsRefl   = refl-    , _gsLaws   = laws-    , _gsData   = sData-    , _gsQual   = qual-    , _gsName   = makeSpecName env     tycEnv measEnv   name-    , _gsVars   = spcVars-    , _gsTerm   = spcTerm--    , _gsLSpec  = finalLiftedSpec-                { impSigs   = makeImports mspecs-                , expSigs   = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ]-                , dataDecls = Bare.dataDeclSize mySpec $ dataDecls mySpec-                , measures  = Ms.measures mySpec-                  -- We want to export measures in a 'LiftedSpec', especially if they are-                  -- required to check termination of some 'liftedSigs' we export. Due to the fact-                  -- that 'lSpec1' doesn't contain the measures that we compute via 'makeHaskellMeasures',-                  -- we take them from 'mySpec', which has those.-                , asmSigs = Ms.asmSigs finalLiftedSpec ++ Ms.asmSigs mySpec-                  -- Export all the assumptions (not just the ones created out of reflection) in-                  -- a 'LiftedSpec'.-                , imeasures = Ms.imeasures finalLiftedSpec ++ Ms.imeasures mySpec-                  -- Preserve user-defined 'imeasures'.-                , dvariance = Ms.dvariance finalLiftedSpec ++ Ms.dvariance mySpec-                  -- Preserve user-defined 'dvariance'.-                , rinstance = Ms.rinstance finalLiftedSpec ++ Ms.rinstance mySpec-                  -- Preserve rinstances.-                , asmReflectSigs = Ms.asmReflectSigs mySpec-                }-    })-  where-    -- typeclass elaboration--    coreToLg ce =-      case CoreToLogic.runToLogic-             embs-             lmap-             dm-             (\x -> todo Nothing ("coreToLogic not working " ++ x))-             (CoreToLogic.coreToLogic allowTC ce) of-        Left msg -> panic Nothing (F.showpp msg)-        Right e -> e-    elaborateSig si auxsig = do-      tySigs <--        forM (gsTySigs si) $ \(x, t) ->-          if GM.isFromGHCReal x then-            pure (x, t)-          else do t' <- traverse (elaborateSpecType coreToLg simplifier) t-                  pure (x, t')-      -- things like len breaks the code-      -- asmsigs should be elaborated only if they are from the current module-      -- asmSigs <- forM (gsAsmSigs si) $ \(x, t) -> do-      --   t' <- traverse (elaborateSpecType (pure ()) coreToLg) t-      --   pure (x, fst <$> t')-      pure-        si-          { gsTySigs = F.notracepp ("asmSigs" ++ F.showpp (gsAsmSigs si)) tySigs ++ auxsig  }--    simplifier :: Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr-    simplifier = pure -- no simplification-    allowTC  = typeclass cfg-    mySpec2  = Bare.qualifyExpand env name rtEnv l [] mySpec1    where l = F.dummyPos "expand-mySpec2"-    iSpecs2  = Bare.qualifyExpand env name rtEnv l [] iSpecs0    where l = F.dummyPos "expand-iSpecs2"-    rtEnv    = Bare.makeRTEnv env name mySpec1 iSpecs0 lmap-    mspecs   = if allowTC then M.toList $ M.insert name mySpec0 iSpecs0 else mspecsNoCls-    (mySpec0, instMethods)  = if allowTC-                              then Bare.compileClasses src env (name, mySpec0NoCls) (M.toList iSpecs0)-                              else (mySpec0NoCls, [])-    mySpec1  = mySpec0 <> lSpec0-    lSpec0   = makeLiftedSpec0 cfg src embs lmap mySpec0-    embs     = makeEmbeds          src env ((name, mySpec0) : M.toList iSpecs0)-    dm       = Bare.tcDataConMap tycEnv0-    (dg0, datacons, tycEnv0) = makeTycEnv0   cfg name env embs mySpec2 iSpecs2-    -- extract name and specs-    env      = Bare.makeEnv cfg src lmap mspecsNoCls-    (mySpec0NoCls, iSpecs0) = splitSpecs name src mspecsNoCls-    -- check barespecs-    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod  src-    zzz      = F.showpp (fst <$> mspecs)--splitSpecs :: ModName -> GhcSrc -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs)-splitSpecs name src specs = (mySpec, iSpecm)-  where-    iSpecm             = fmap mconcat . Misc.group $ iSpecs-    iSpecs             = Dg.sliceSpecs src mySpec iSpecs'-    mySpec             = mconcat (snd <$> mySpecs)-    (mySpecs, iSpecs') = L.partition ((name ==) . fst) specs---makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)]-makeImports specs = concatMap (expSigs . snd) specs'-  where specs' = filter (isSrcImport . fst) specs---makeEmbeds :: GhcSrc -> Bare.Env -> [(ModName, Ms.BareSpec)] -> F.TCEmb Ghc.TyCon-makeEmbeds src env-  = Bare.addClassEmbeds (_gsCls src) (_gsFiTcs src)-  . mconcat-  . map (makeTyConEmbeds env)--makeTyConEmbeds :: Bare.Env -> (ModName, Ms.BareSpec) -> F.TCEmb Ghc.TyCon-makeTyConEmbeds env (name, spec)-  = F.tceFromList [ (tc, t) | (c,t) <- F.tceToList (Ms.embeds spec), tc <- symTc c ]-    where-      symTc = Mb.maybeToList . Bare.maybeResolveSym env name "embed-tycon"------------------------------------------------------------------------------------- | [NOTE]: REFLECT-IMPORTS------ 1. MAKE the full LiftedSpec, which will eventually, contain:---      makeHaskell{Inlines, Measures, Axioms, Bounds}--- 2. SAVE the LiftedSpec, which will be reloaded------   This step creates the aliases and inlines etc. It must be done BEFORE---   we compute the `SpecType` for (all, including the reflected binders),---   as we need the inlines and aliases to properly `expand` the SpecTypes.----------------------------------------------------------------------------------makeLiftedSpec1 :: Config -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec-                -> Ms.BareSpec-makeLiftedSpec1 config src tycEnv lmap mySpec = mempty-  { Ms.measures  = Bare.makeHaskellMeasures (typeclass config) src tycEnv lmap mySpec }------------------------------------------------------------------------------------- | [NOTE]: LIFTING-STAGES------ We split the lifting up into stage:--- 0. Where we only lift inlines,--- 1. Where we lift reflects, measures, and normalized tySigs------ This is because we need the inlines to build the @BareRTEnv@ which then--- does the alias @expand@ business, that in turn, lets us build the DataConP,--- i.e. the refined datatypes and their associate selectors, projectors etc,--- that are needed for subsequent stages of the lifting.----------------------------------------------------------------------------------makeLiftedSpec0 :: Config -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec-                -> Ms.BareSpec-makeLiftedSpec0 cfg src embs lmap mySpec = mempty-  { Ms.ealiases  = lmapEAlias . snd <$> Bare.makeHaskellInlines (typeclass cfg) src embs lmap mySpec-  , Ms.reflects  = Ms.reflects mySpec-  , Ms.dataDecls = Bare.makeHaskellDataDecls cfg name mySpec tcs-  , Ms.embeds    = Ms.embeds mySpec-  -- We do want 'embeds' to survive and to be present into the final 'LiftedSpec'. The-  -- caveat is to decide which format is more appropriate. We obviously cannot store-  -- them as a 'TCEmb TyCon' as serialising a 'TyCon' would be fairly exponsive. This-  -- needs more thinking.-  , Ms.cmeasures = Ms.cmeasures mySpec-  -- We do want 'cmeasures' to survive and to be present into the final 'LiftedSpec'. The-  -- caveat is to decide which format is more appropriate. This needs more thinking.-  }-  where-    tcs          = uniqNub (_gsTcs src ++ refTcs)-    refTcs       = reflectedTyCons cfg embs cbs  mySpec-    cbs          = _giCbs       src-    name         = _giTargetMod src--uniqNub :: (Ghc.Uniquable a) => [a] -> [a]-uniqNub xs = M.elems $ M.fromList [ (index x, x) | x <- xs ]-  where-    index  = Ghc.getKey . Ghc.getUnique---- | 'reflectedTyCons' returns the list of `[TyCon]` that must be reflected but---   which are defined *outside* the current module e.g. in Base or somewhere---   that we don't have access to the code.--reflectedTyCons :: Config -> TCEmb Ghc.TyCon -> [Ghc.CoreBind] -> Ms.BareSpec -> [Ghc.TyCon]-reflectedTyCons cfg embs cbs spec-  | exactDCFlag cfg = filter (not . isEmbedded embs)-                    $ concatMap varTyCons-                    $ reflectedVars spec cbs ++ measureVars spec cbs-  | otherwise       = []---- | We cannot reflect embedded tycons (e.g. Bool) as that gives you a sort---   conflict: e.g. what is the type of is-True? does it take a GHC.Types.Bool---   or its embedding, a bool?-isEmbedded :: TCEmb Ghc.TyCon -> Ghc.TyCon -> Bool-isEmbedded embs c = F.tceMember c embs--varTyCons :: Ghc.Var -> [Ghc.TyCon]-varTyCons = specTypeCons . ofType . Ghc.varType--specTypeCons           :: SpecType -> [Ghc.TyCon]-specTypeCons         = foldRType tc []-  where-    tc acc t@RApp {} = rtc_tc (rt_tycon t) : acc-    tc acc _         = acc--reflectedVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]-reflectedVars spec cbs = fst <$> xDefs-  where-    xDefs              = Mb.mapMaybe (`GM.findVarDef` cbs) reflSyms-    reflSyms           = val <$> S.toList (Ms.reflects spec)--measureVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]-measureVars spec cbs = fst <$> xDefs-  where-    xDefs              = Mb.mapMaybe (`GM.findVarDef` cbs) measureSyms-    measureSyms        = val <$> S.toList (Ms.hmeas spec)---------------------------------------------------------------------------------------------makeSpecVars :: Config -> GhcSrc -> Ms.BareSpec -> Bare.Env -> Bare.MeasEnv-             -> Bare.Lookup GhcSpecVars--------------------------------------------------------------------------------------------makeSpecVars cfg src mySpec env measEnv = do-  tgtVars     <-   mapM (resolveStringVar  env name)              (checks     cfg)-  igVars      <-  sMapM (Bare.lookupGhcVar env name "gs-ignores") (Ms.ignores mySpec)-  lVars       <-  sMapM (Bare.lookupGhcVar env name "gs-lvars"  ) (Ms.lvars   mySpec)-  return (SpVar tgtVars igVars lVars cMethods)-  where-    name       = _giTargetMod src-    cMethods   = snd3 <$> Bare.meMethods measEnv--sMapM :: (Monad m, Eq b, Hashable b) => (a -> m b) -> S.HashSet a -> m (S.HashSet b)-sMapM f xSet = do- ys <- mapM f (S.toList xSet)- return (S.fromList ys)--sForM :: (Monad m, Eq b, Hashable b) =>S.HashSet a -> (a -> m b) -> m (S.HashSet b)-sForM xs f = sMapM f xs--qualifySymbolic :: (F.Symbolic a) => ModName -> a -> F.Symbol-qualifySymbolic name s = GM.qualifySymbol (F.symbol name) (F.symbol s)--resolveStringVar :: Bare.Env -> ModName -> String -> Bare.Lookup Ghc.Var-resolveStringVar env name s = Bare.lookupGhcVar env name "resolve-string-var" lx-  where-    lx                      = dummyLoc (qualifySymbolic name s)-----------------------------------------------------------------------------------------------makeSpecQual :: Config -> Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> BareRTEnv -> Bare.ModSpecs-             -> GhcSpecQual--------------------------------------------------------------------------------------------makeSpecQual _cfg env tycEnv measEnv _rtEnv specs = SpQual-  { gsQualifiers = filter okQual quals-  , gsRTAliases  = [] -- makeSpecRTAliases env rtEnv -- TODO-REBARE-  }-  where-    quals        = concatMap (makeQualifiers env tycEnv) (M.toList specs)-    -- mSyms        = F.tracepp "MSYMS" $ M.fromList (Bare.meSyms measEnv ++ Bare.meClassSyms measEnv)-    okQual q     = F.notracepp ("okQual: " ++ F.showpp q)-                   $ all (`S.member` mSyms) (F.syms q)-    mSyms        = F.notracepp "MSYMS" . S.fromList-                   $  (fst <$> wiredSortedSyms)-                   ++ (fst <$> Bare.meSyms measEnv)-                   ++ (fst <$> Bare.meClassSyms measEnv)--makeQualifiers :: Bare.Env -> Bare.TycEnv -> (ModName, Ms.Spec ty bndr) -> [F.Qualifier]-makeQualifiers env tycEnv (modn, spec)-  = fmap        (Bare.qualifyTopDummy env        modn)-  . Mb.mapMaybe (resolveQParams       env tycEnv modn)-  $ Ms.qualifiers spec----- | @resolveQualParams@ converts the sorts of parameters from, e.g.---     'Int' ===> 'GHC.Types.Int' or---     'Ptr' ===> 'GHC.Ptr.Ptr'---   It would not be required if _all_ qualifiers are scraped from---   function specs, but we're keeping it around for backwards compatibility.--resolveQParams :: Bare.Env -> Bare.TycEnv -> ModName -> F.Qualifier -> Maybe F.Qualifier-resolveQParams env tycEnv name q = do-     qps   <- mapM goQP (F.qParams q)-     return $ q { F.qParams = qps }-  where-    goQP qp          = do { s <- go (F.qpSort qp) ; return qp { F.qpSort = s } }-    go               :: F.Sort -> Maybe F.Sort-    go (FAbs i s)    = FAbs i <$> go s-    go (FFunc s1 s2) = FFunc  <$> go s1 <*> go s2-    go (FApp  s1 s2) = FApp   <$> go s1 <*> go s2-    go (FTC c)       = qualifyFTycon env tycEnv name c-    go s             = Just s--qualifyFTycon :: Bare.Env -> Bare.TycEnv -> ModName -> F.FTycon -> Maybe F.Sort-qualifyFTycon env tycEnv name c-  | isPrimFTC           = Just (FTC c)-  | otherwise           = tyConSort embs . F.atLoc tcs <$> ty-  where-    ty                  = Bare.maybeResolveSym env name "qualify-FTycon" tcs-    isPrimFTC           = F.val tcs `elem` F.prims-    tcs                 = F.fTyconSymbol c-    embs                = Bare.tcEmbs tycEnv--tyConSort :: F.TCEmb Ghc.TyCon -> F.Located Ghc.TyCon -> F.Sort-tyConSort embs lc = Mb.maybe s0 fst (F.tceLookup c embs)-  where-    c             = F.val lc-    s0            = tyConSortRaw lc--tyConSortRaw :: F.Located Ghc.TyCon -> F.Sort-tyConSortRaw = FTC . F.symbolFTycon . fmap F.symbol---------------------------------------------------------------------------------------------makeSpecTerm :: Config -> Ms.BareSpec -> Bare.Env -> ModName ->-                Bare.Lookup GhcSpecTerm--------------------------------------------------------------------------------------------makeSpecTerm cfg mySpec env name = do-  sizes  <- if structuralTerm cfg then pure mempty else makeSize env name mySpec-  lazies <- makeLazy     env name mySpec-  autos  <- makeAutoSize env name mySpec-  gfail  <- makeFail env name mySpec-  return  $ SpTerm-    { gsLazy       = S.insert dictionaryVar (lazies `mappend` sizes)-    , gsFail       = gfail-    , gsStTerm     = sizes-    , gsAutosize   = autos-    , gsNonStTerm  = mempty-    }--makeRelation :: Bare.Env -> ModName -> Bare.SigEnv ->-  [(LocSymbol, LocSymbol, LocBareType, LocBareType, RelExpr, RelExpr)] -> Bare.Lookup [(Ghc.Var, Ghc.Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]-makeRelation env name sigEnv = mapM go- where-  go (x, y, tx, ty, a, e) = do-    vx <- Bare.lookupGhcVar env name "Var" x-    vy <- Bare.lookupGhcVar env name "Var" y-    return-        ( vx-        , vy-        , Bare.cookSpecType env sigEnv name (Bare.HsTV vx) tx-        , Bare.cookSpecType env sigEnv name (Bare.HsTV vy) ty-        , a-        , e-        )---makeLazy :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var)-makeLazy env name spec =-  sMapM (Bare.lookupGhcVar env name "Var") (Ms.lazy spec)--makeFail :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))-makeFail env name spec =-  sForM (Ms.fails spec) $ \x -> do-    vx <- Bare.lookupGhcVar env name "Var" x-    return x { val = vx }--makeRewrite :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))-makeRewrite env name spec =-  sForM (Ms.rewrites spec) $ \x -> do-    vx <-  Bare.lookupGhcVar env name "Var" x-    return x { val = vx }--makeRewriteWith :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (M.HashMap Ghc.Var [Ghc.Var])-makeRewriteWith env name spec = M.fromList <$> makeRewriteWith' env name spec--makeRewriteWith' :: Bare.Env -> ModName -> Spec ty bndr -> Bare.Lookup [(Ghc.Var, [Ghc.Var])]-makeRewriteWith' env name spec =-  forM (M.toList $ Ms.rewriteWith spec) $ \(x, xs) -> do-    xv  <- Bare.lookupGhcVar env name "Var1" x-    xvs <- mapM (Bare.lookupGhcVar env name "Var2") xs-    return (xv, xvs)--makeAutoSize :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.TyCon)-makeAutoSize env name-  = fmap S.fromList-  . mapM (Bare.lookupGhcTyCon env name "TyCon")-  . S.toList-  . Ms.autosize--makeSize :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var)-makeSize env name-  = fmap S.fromList-  . mapM (Bare.lookupGhcVar env name "Var")-  . Mb.mapMaybe getSizeFuns-  . Ms.dataDecls--getSizeFuns :: DataDecl -> Maybe LocSymbol-getSizeFuns decl-  | Just x       <- tycSFun decl-  , SymSizeFun f <- x-  = Just f-  | otherwise-  = Nothing----------------------------------------------------------------------------------------------makeSpecLaws :: Bare.Env -> Bare.SigEnv -> [(Ghc.Var,LocSpecType)] -> Bare.MeasEnv -> Bare.ModSpecs-             -> GhcSpecLaws--------------------------------------------------------------------------------------------makeSpecLaws env sigEnv sigs menv specs = SpLaws-  { gsLawDefs = second (map (\(_,x,y) -> (x,y))) <$> Bare.meCLaws menv-  , gsLawInst = Bare.makeInstanceLaws env sigEnv sigs specs-  }---------------------------------------------------------------------------------------------makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv-             -> Bare.Lookup GhcSpecRefl--------------------------------------------------------------------------------------------makeSpecRefl cfg src menv specs env name sig tycEnv = do-  autoInst <- makeAutoInst env name mySpec-  rwr      <- makeRewrite env name mySpec-  rwrWith  <- makeRewriteWith env name mySpec-  wRefls   <- Bare.wiredReflects cfg env name sig-  xtes     <- Bare.makeHaskellAxioms cfg src env tycEnv name lmap sig mySpec-  asmReflAxioms <- Bare.makeAssumeReflectAxioms src env tycEnv name sig mySpec-  let otherAxioms = thd3 <$> asmReflAxioms-  let myAxioms =-        [ Bare.qualifyTop-            env-            name-            (F.loc lt)-            e {eqName = s, eqRec = S.member s (exprSymbolsSet (eqBody e))}-        | (x, lt, e) <- xtes-        , let s = symbol x-        ] ++ otherAxioms-  let asmReflEls = eqName <$> otherAxioms-  let impAxioms  = concatMap (filter ((`notElem` asmReflEls) . eqName) . Ms.axeqs . snd) (M.toList specs)-  let sigVars  = F.notracepp "SIGVARS" $ (fst3 <$> xtes)            -- reflects-                                      ++ (fst  <$> gsAsmSigs sig)   -- assumes-                                      ++ (fst  <$> gsRefSigs sig)-  case anyNonReflFn of-    Just (actSym , preSym) ->-      let preSym' = show (val preSym) in-      let errorMsg = preSym' ++ " must be reflected first using {-@ reflect " ++ preSym' ++ " @-}" in-      let error = ErrHMeas (GM.sourcePosSrcSpan $ loc actSym) (pprint $ val actSym) (text errorMsg) :: Error-      in Ex.throw error-    Nothing -> return SpRefl-      { gsLogicMap   = lmap-      , gsAutoInst   = autoInst-      , gsImpAxioms  = impAxioms-      , gsMyAxioms   = myAxioms-      , gsReflects   = lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ (fst <$> gsAsmReflects sig) ++ wRefls-      , gsHAxioms    = F.notracepp "gsHAxioms" $ xtes ++ asmReflAxioms-      , gsWiredReft  = wRefls-      , gsRewrites   = rwr-      , gsRewritesWith = rwrWith-      }-  where-    lawMethods   = F.notracepp "Law Methods" $ concatMap Ghc.classMethods (fst <$> Bare.meCLaws menv)-    mySpec       = M.lookupDefault mempty name specs-    rflSyms      = S.fromList (getReflects specs)-    lmap         = Bare.reLMap env-    notInReflOnes (_, a) = not $ a `S.member` Ms.reflects mySpec-    anyNonReflFn = L.find notInReflOnes (Ms.asmReflectSigs mySpec)--isReflectVar :: S.HashSet F.Symbol -> Ghc.Var -> Bool-isReflectVar reflSyms v = S.member vx reflSyms-  where-    vx                  = GM.dropModuleNames (symbol v)--getReflects :: Bare.ModSpecs -> [Symbol]-getReflects  = fmap val . S.toList . S.unions . fmap (names . snd) . M.toList-  where-    names  z = S.unions [ Ms.reflects z, S.fromList (snd <$> Ms.asmReflectSigs z), S.fromList (fst <$> Ms.asmReflectSigs z), Ms.inlines z, Ms.hmeas z ]----------------------------------------------------------------------------------------------- | @updateReflSpecSig@ uses the information about reflected functions to update the---   "assumed" signatures.--------------------------------------------------------------------------------------------addReflSigs :: Bare.Env -> ModName -> BareRTEnv -> GhcSpecRefl -> GhcSpecSig -> GhcSpecSig--------------------------------------------------------------------------------------------addReflSigs env name rtEnv refl sig =-  sig { gsRefSigs = F.notracepp ("gsRefSigs for " ++ F.showpp name) $ map expandReflectedSignature reflSigs-      -- We make sure that the reflected functions are excluded from `gsAsmSigs`, except for the signatures of-      -- actual functions in assume-reflect. The latter are added here because 1. it's what makes tests work-      -- and 2. so that we probably "shadow" the old signatures of the actual function correctly. Note that even if the-      -- signature of the actual function was asserted and not assumed, we do not put our new signature for the actual function-      -- in `gsTySigs` (which is for asserted signatures). Indeed, the new signature will *always* be an assumption since we-      -- add the extra post-condition that the actual and pretended function behave in the same way.-      , gsAsmSigs = F.notracepp ("gsAsmSigs for " ++ F.showpp name) (wreflSigs ++ filter notReflected (gsAsmSigs sig))-      }-  where--    -- See T1738. We need to expand and qualify any reflected signature /here/, after any-    -- relevant binder has been detected and \"promoted\". The problem stems from the fact that any input-    -- 'BareSpec' will have a 'reflects' list of binders to reflect under the form of an opaque 'Var', that-    -- qualifyExpand can't touch when we do a first pass in 'makeGhcSpec0'. However, once we reflected all-    -- the functions, we are left with a pair (Var, LocSpecType). The latter /needs/ to be qualified and-    -- expanded again, for example in case it has expression aliases derived from 'inlines'.-    expandReflectedSignature :: (Ghc.Var, LocSpecType) -> (Ghc.Var, LocSpecType)-    expandReflectedSignature = fmap (Bare.qualifyExpand env name rtEnv (F.dummyPos "expand-refSigs") [])--    (wreflSigs, reflSigs)   = L.partition ((`elem` gsWiredReft refl) . fst)-                                 [ (x, t) | (x, t, _) <- gsHAxioms refl ]-    -- Get the set of all the actual functions (in assume-reflects)-    actualFnsInAssmRefl     = S.fromList $ fst <$> gsAsmReflects sig-    isActualFn           x  = S.member x actualFnsInAssmRefl-    -- Get all the variables from the axioms that are not actual functions (in assume-reflects)-    notReflActualTySigs     = L.filter (not . isActualFn . fst) reflSigs-    -- Get the list of reflected elements. We do not count actual functions in assume reflect as reflected-    reflected               = S.fromList $ fst <$> (wreflSigs ++ notReflActualTySigs)-    notReflected xt         = fst xt `notElem` reflected--makeAutoInst :: Bare.Env -> ModName -> Ms.BareSpec ->-                Bare.Lookup (M.HashMap Ghc.Var (Maybe Int))-makeAutoInst env name spec = M.fromList <$> kvs-  where-    kvs = forM (M.toList (Ms.autois spec)) $ \(k, val) -> do-            vk <- Bare.lookupGhcVar env name "Var" k-            return (vk, val)--------------------------------------------------------------------------------------------makeSpecSig :: Config -> ModName -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]-            -> Bare.Lookup GhcSpecSig------------------------------------------------------------------------------------------makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = do-  mySigs     <- makeTySigs  env sigEnv name mySpec-  aSigs      <- F.notracepp ("makeSpecSig aSigs " ++ F.showpp name) $ makeAsmSigs env sigEnv name specs-  let asmSigs =  Bare.tcSelVars tycEnv-              ++ aSigs-              ++ [ (x,t) | (_, x, t) <- concatMap snd (Bare.meCLaws measEnv) ]-  let tySigs  = strengthenSigs . concat $-                  [ [(v, (0, t)) | (v, t,_) <- mySigs                         ]   -- NOTE: these weights are to priortize-                  , [(v, (1, t)) | (v, t  ) <- makeMthSigs measEnv            ]   -- user defined sigs OVER auto-generated-                  , [(v, (2, t)) | (v, t  ) <- makeInlSigs env rtEnv allSpecs ]   -- during the strengthening, i.e. to KEEP-                  , [(v, (3, t)) | (v, t  ) <- makeMsrSigs env rtEnv allSpecs ]   -- the binders used in USER-defined sigs-                  ]                                                               -- as they appear in termination metrics-  newTys     <-  makeNewTypes env sigEnv allSpecs-  relation   <-  makeRelation env name sigEnv (Ms.relational mySpec)-  asmRel     <-  makeRelation env name sigEnv (Ms.asmRel mySpec)-  return SpSig-    { gsTySigs   = tySigs-    , gsAsmSigs  = asmSigs-    , gsAsmReflects = bimap getVar getVar <$> concatMap (asmReflectSigs . snd) (M.toList specs)-    , gsRefSigs  = []-    , gsDicts    = dicts-    -- , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses  measEnv) cbs-    , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes (typeclass cfg) dicts (Bare.meClasses  measEnv) cbs-    , gsInSigs   = mempty-    , gsNewTypes = newTys-    , gsTexprs   = [ (v, t, es) | (v, t, Just es) <- mySigs ]-    , gsRelation = relation-    , gsAsmRel   = asmRel-  }-  where-    dicts      = Bare.makeSpecDictionaries env sigEnv specs-    mySpec     = M.lookupDefault mempty name specs-    allSpecs   = M.toList specs-    rtEnv      = Bare.sigRTEnv sigEnv-    getVar sym = case Bare.lookupGhcVar env name "wiredAxioms" sym of-      Right x -> x-      Left _ -> Ex.throw $ mkError sym $ "Not in scope: " ++ show (val sym)--    mkError :: LocSymbol -> String -> Error-    mkError x str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)-    -- hmeas      = makeHMeas    env allSpecs--strengthenSigs :: [(Ghc.Var, (Int, LocSpecType))] ->[(Ghc.Var, LocSpecType)]-strengthenSigs sigs = go <$> Misc.groupList sigs-  where-    go (v, ixs)     = (v,) $ L.foldl1' (flip meetLoc) (F.notracepp ("STRENGTHEN-SIGS: " ++ F.showpp v) (prio ixs))-    prio            = fmap snd . Misc.sortOn fst-    meetLoc         :: LocSpecType -> LocSpecType -> LocSpecType-    meetLoc t1 t2   = t1 {val = val t1 `F.meet` val t2}--makeMthSigs :: Bare.MeasEnv -> [(Ghc.Var, LocSpecType)]-makeMthSigs measEnv = [ (v, t) | (_, v, t) <- Bare.meMethods measEnv ]--makeInlSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]-makeInlSigs env rtEnv-  = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))-  . makeFromSet "hinlines" Ms.inlines env--makeMsrSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]-makeMsrSigs env rtEnv-  = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))-  . makeFromSet "hmeas" Ms.hmeas env--makeLiftedSigs :: BareRTEnv -> (Ghc.Var -> SpecType) -> [Ghc.Var] -> [(Ghc.Var, LocSpecType)]-makeLiftedSigs rtEnv f xs-  = [(x, lt) | x <- xs-             , let lx = GM.locNamedThing x-             , let lt = expand $ lx {val = f x}-    ]-  where-    expand   = Bare.specExpandType rtEnv--makeFromSet :: String -> (Ms.BareSpec -> S.HashSet LocSymbol) -> Bare.Env -> [(ModName, Ms.BareSpec)]-            -> [Ghc.Var]-makeFromSet msg f env specs = concat [ mk n xs | (n, s) <- specs, let xs = S.toList (f s)]-  where-    mk name                 = Mb.mapMaybe (Bare.maybeResolveSym env name msg)--makeTySigs :: Bare.Env -> Bare.SigEnv -> ModName -> Ms.BareSpec-           -> Bare.Lookup [(Ghc.Var, LocSpecType, Maybe [Located F.Expr])]-makeTySigs env sigEnv name spec = do-  bareSigs   <- bareTySigs env name                spec-  expSigs    <- makeTExpr  env name bareSigs rtEnv spec-  let rawSigs = Bare.resolveLocalBinds env expSigs-  return [ (x, cook x bt, z) | (x, bt, z) <- rawSigs ]-  where-    rtEnv     = Bare.sigRTEnv sigEnv-    cook x bt = Bare.cookSpecType env sigEnv name (Bare.HsTV x) bt--bareTySigs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, LocBareType)]-bareTySigs env name spec = checkDuplicateSigs <$> vts-  where-    vts = forM ( Ms.sigs spec ++ Ms.localSigs spec ) $ \ (x, t) -> do-            v <- F.notracepp "LOOKUP-GHC-VAR" $ Bare.lookupGhcVar env name "rawTySigs" x-            return (v, t)---- checkDuplicateSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]-checkDuplicateSigs :: (Symbolic x) => [(x, F.Located t)] -> [(x, F.Located t)]-checkDuplicateSigs xts = case Misc.uniqueByKey symXs  of-  Left (k, ls) -> uError (errDupSpecs (pprint k) (GM.sourcePosSrcSpan <$> ls))-  Right _      -> xts-  where-    symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]---makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs -> Bare.Lookup [(Ghc.Var, LocSpecType)]-makeAsmSigs env sigEnv myName specs = do-  raSigs <- rawAsmSigs env myName specs-  return [ (x, t) | (name, x, bt) <- raSigs, let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt ]--rawAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> Bare.Lookup [(ModName, Ghc.Var, LocBareType)]-rawAsmSigs env myName specs = do-  aSigs <- allAsmSigs env myName specs-  return [ (m, v, t) | (v, sigs) <- aSigs, let (m, t) = myAsmSig v sigs ]--myAsmSig :: Ghc.Var -> [(Bool, ModName, LocBareType)] -> (ModName, LocBareType)-myAsmSig v sigs = Mb.fromMaybe errImp (mbHome `mplus` mbImp)-  where-    mbHome      = takeUnique mkErr                  sigsHome-    -- In case we import multiple specifications for the same function stemming from `assume-reflect` from different modules, we want-    -- to follow the same convention as in other places and so take the last one in alphabetical order and shadow the others-    mbImp       = takeBiggest   fst (Misc.firstGroup sigsImp) -- see [NOTE:Prioritize-Home-Spec]-    sigsHome    = [(m, t)      | (True,  m, t) <- sigs ]-    sigsImp     = F.notracepp ("SIGS-IMP: " ++ F.showpp v)-                  [(d, (m, t)) | (False, m, t) <- sigs, let d = nameDistance vName m]-    mkErr ts    = ErrDupSpecs (Ghc.getSrcSpan v) (F.pprint v) (GM.sourcePosSrcSpan . F.loc . snd <$> ts) :: UserError-    errImp      = impossible Nothing "myAsmSig: cannot happen as sigs is non-null"-    vName       = GM.takeModuleNames (F.symbol v)--makeTExpr :: Bare.Env -> ModName -> [(Ghc.Var, LocBareType)] -> BareRTEnv -> Ms.BareSpec-          -> Bare.Lookup [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]-makeTExpr env name tySigs rtEnv spec = do-  vExprs       <- M.fromList <$> makeVarTExprs env name spec-  let vSigExprs = Misc.hashMapMapWithKey (\v t -> (t, M.lookup v vExprs)) vSigs-  return [ (v, t, qual t <$> es) | (v, (t, es)) <- M.toList vSigExprs ]-  where-    qual t es   = qualifyTermExpr env name rtEnv t <$> es-    vSigs       = M.fromList tySigs--qualifyTermExpr :: Bare.Env -> ModName -> BareRTEnv -> LocBareType -> Located F.Expr-                -> Located F.Expr-qualifyTermExpr env name rtEnv t le-        = F.atLoc le (Bare.qualifyExpand env name rtEnv l bs e)-  where-    l   = F.loc le-    e   = F.val le-    bs  = ty_binds . toRTypeRep . val $ t--makeVarTExprs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, [Located F.Expr])]-makeVarTExprs env name spec =-  forM (Ms.termexprs spec) $ \(x, es) -> do-    vx <- Bare.lookupGhcVar env name "Var" x-    return (vx, es)--------------------------------------------------------------------------------------------- [NOTE:Prioritize-Home-Spec] Prioritize spec for THING defined in--- `Foo.Bar.Baz.Quux.x` over any other specification, IF GHC's--- fully qualified name for THING is `Foo.Bar.Baz.Quux.x`.------ For example, see tests/names/neg/T1078.hs for example,--- which assumes a spec for `head` defined in both------   (1) Data/ByteString.spec---   (2) Data/ByteString/Char8.spec------ We end up resolving the `head` in (1) to the @Var@ `Data.ByteString.Char8.head`--- even though there is no exact match, just to account for re-exports of "internal"--- modules and such (see `Resolve.matchMod`). However, we should pick the closer name--- if its available.------------------------------------------------------------------------------------------nameDistance :: F.Symbol -> ModName -> Int-nameDistance vName tName-  | vName == F.symbol tName = 0-  | otherwise               = 1--takeUnique :: Ex.Exception e => ([a] -> e) -> [a] -> Maybe a-takeUnique _ []  = Nothing-takeUnique _ [x] = Just x-takeUnique f xs  = Ex.throw (f xs)--takeBiggest :: (Ord b) => (a -> b) -> [a] -> Maybe a-takeBiggest _ []  = Nothing-takeBiggest f xs  = Just $ L.maximumBy (compare `on` f) xs--allAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs ->-              Bare.Lookup [(Ghc.Var, [(Bool, ModName, LocBareType)])]-allAsmSigs env myName specs = do-  let aSigs = [ (name, locallyDefined, x, t) | (name, spec) <- M.toList specs-                                   , (locallyDefined, x, t) <- getAsmSigs myName name spec ]-  vSigs    <- forM aSigs $ \(name, locallyDefined, x, t) -> do-                -- Qualified assumes that refer to module aliases import declarations-                -- are resolved looking at import declarations-                let (mm, s) = Bare.unQualifySymbol (val x)-                vMb <- if not (isAbsoluteQualifiedSym mm) then resolveAsmVar env name locallyDefined x-                       else if locallyDefined then-                         -- Fully qualified assumes that are locally defined produce an error if they aren't found-                         lookupImportedSym x (mm, s)-                       else-                         -- Imported fully qualified assumes do not produce an error if they-                         -- aren't found, and we looked them anyway without considering-                         -- import declarations.-                         -- LH seems to send here assumes for data constructors that-                         -- yield Nothing, like for GHC.Types.W#-                         return $ lookupImportedSymMaybe (mm, s)-                return (vMb, (locallyDefined, name, t))-  return    $ Misc.groupList [ (v, z) | (Just v, z) <- vSigs ]-  where-    lookupImportedSym x qp =-      let errRes = Left [Bare.errResolve "variable" "Var" x]-       in maybe errRes (Right . Just) $-            lookupImportedSymMaybe qp-    lookupImportedSymMaybe (mm, s) = do-      mts <- M.lookup s (Bare._reTyThings env)-      m <- mm-      Mb.listToMaybe [ v | (k, Ghc.AnId v) <- mts, k == m ]--    isAbsoluteQualifiedSym (Just m) =-       not $ M.member m $ qiNames (Bare.reQualImps env)-    isAbsoluteQualifiedSym Nothing =-       False--resolveAsmVar :: Bare.Env -> ModName -> Bool -> LocSymbol -> Bare.Lookup (Maybe Ghc.Var)-resolveAsmVar env name True  lx = Just  <$> Bare.lookupGhcVar env name "resolveAsmVar-True"  lx-resolveAsmVar env name False lx = return $  Bare.maybeResolveSym     env name "resolveAsmVar-False" lx  <|> GM.maybeAuxVar (F.val lx)---getAsmSigs :: ModName -> ModName -> Ms.BareSpec -> [(Bool, LocSymbol, LocBareType)]-getAsmSigs myName name spec-  | myName == name = [ (True,  x,  t) | (x, t) <- Ms.asmSigs spec ] -- MUST    resolve, or error-  | otherwise      = [ (False, x', t) | (x, t) <- Ms.asmSigs spec-                                                  ++ Ms.sigs spec-                                      , let x' = qSym x           ]  -- MAY-NOT resolve-  where-    qSym           = fmap (GM.qualifySymbol ns)-    ns             = F.symbol name---- TODO-REBARE: grepClassAssumes-_grepClassAssumes :: [RInstance t] -> [(Located F.Symbol, t)]-_grepClassAssumes  = concatMap go-  where-    go    xts              = Mb.mapMaybe goOne (risigs xts)-    goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)-    goOne (_, RISig _)     = Nothing--makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv-makeSigEnv embs tyi exports rtEnv = Bare.SigEnv-  { sigEmbs     = embs-  , sigTyRTyMap = tyi-  , sigExports  = exports-  , sigRTEnv    = rtEnv-  }--makeNewTypes :: Bare.Env -> Bare.SigEnv -> [(ModName, Ms.BareSpec)] ->-                Bare.Lookup [(Ghc.TyCon, LocSpecType)]-makeNewTypes env sigEnv specs = do-  fmap concat $-    forM nameDecls $ uncurry (makeNewType env sigEnv)-  where-    nameDecls = [(name, d) | (name, spec) <- specs, d <- Ms.newtyDecls spec]--makeNewType :: Bare.Env -> Bare.SigEnv -> ModName -> DataDecl ->-               Bare.Lookup [(Ghc.TyCon, LocSpecType)]-makeNewType env sigEnv name d = do-  tcMb <- Bare.lookupGhcDnTyCon env name "makeNewType" tcName-  case tcMb of-    Just tc -> return [(tc, lst)]-    _       -> return []-  where-    tcName                    = tycName d-    lst                       = Bare.cookSpecType env sigEnv name Bare.GenTV bt-    bt                        = getTy tcName (tycSrcPos d) (Mb.fromMaybe [] (tycDCons d))-    getTy _ l [c]-      | [(_, t)] <- dcFields c = Loc l l t-    getTy n l _                = Ex.throw (mkErr n l)-    mkErr n l                  = ErrOther (GM.sourcePosSrcSpan l) ("Bad new type declaration:" <+> F.pprint n) :: UserError---------------------------------------------------------------------------------------------makeSpecData :: GhcSrc -> Bare.Env -> Bare.SigEnv -> Bare.MeasEnv -> GhcSpecSig -> Bare.ModSpecs-             -> GhcSpecData--------------------------------------------------------------------------------------------makeSpecData src env sigEnv measEnv sig specs = SpData-  { gsCtors      = F.notracepp "GS-CTORS"-                   [ (x, if allowTC then t else tt)-                       | (x, t) <- Bare.meDataCons measEnv-                       , let tt  = Bare.plugHoles (typeclass $ getConfig env) sigEnv name (Bare.LqTV x) t-                   ]-  , gsMeas       = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ]-  , gsMeasures   = Bare.qualifyTopDummy env name <$> (ms1 ++ ms2)-  , gsInvariants = Misc.nubHashOn (F.loc . snd) invs-  , gsIaliases   = concatMap (makeIAliases env sigEnv) (M.toList specs)-  , gsUnsorted   = usI ++ concatMap msUnSorted (concatMap measures specs)-  }-  where-    allowTC      = typeclass (getConfig env)-    measVars     = Bare.meSyms      measEnv -- ms'-                ++ Bare.meClassSyms measEnv -- cms'-                ++ Bare.varMeasures env-    measuresSp   = Bare.meMeasureSpec measEnv-    ms1          = M.elems (Ms.measMap measuresSp)-    ms2          = Ms.imeas   measuresSp-    mySpec       = M.lookupDefault mempty name specs-    name         = _giTargetMod      src-    (minvs,usI)  = makeMeasureInvariants env name sig mySpec-    invs         = minvs ++ concatMap (makeInvariants env sigEnv) (M.toList specs)--makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(LocSpecType, LocSpecType)]-makeIAliases env sigEnv (name, spec)-  = [ z | Right z <- mkIA <$> Ms.ialiases spec ]-  where-    -- mkIA :: (LocBareType, LocBareType) -> Either _ (LocSpecType, LocSpecType)-    mkIA (t1, t2) = (,) <$> mkI' t1 <*> mkI' t2-    mkI'          = Bare.cookSpecTypeE env sigEnv name Bare.GenTV--makeInvariants :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(Maybe Ghc.Var, Located SpecType)]-makeInvariants env sigEnv (name, spec) =-  [ (Nothing, t)-    | (_, bt) <- Ms.invariants spec-    , Bare.knownGhcType env name bt-    , let t = Bare.cookSpecType env sigEnv name Bare.GenTV bt-  ] ++-  concat [ (Nothing,) . makeSizeInv l <$>  ts-    | (bts, l) <- Ms.dsize spec-    , all (Bare.knownGhcType env name) bts-    , let ts = Bare.cookSpecType env sigEnv name Bare.GenTV <$> bts-  ]--makeSizeInv :: F.LocSymbol -> Located SpecType -> Located SpecType-makeSizeInv s lst = lst{val = go (val lst)}-  where go (RApp c ts rs r) = RApp c ts rs (r `meet` nat)-        go (RAllT a t r)    = RAllT a (go t) r-        go t = t-        nat  = MkUReft (Reft (vv_, PAtom Le (ECon $ I 0) (EApp (EVar $ val s) (eVar vv_))))-                       mempty--makeMeasureInvariants :: Bare.Env -> ModName -> GhcSpecSig -> Ms.BareSpec-                      -> ([(Maybe Ghc.Var, LocSpecType)], [UnSortedExpr])-makeMeasureInvariants env name sig mySpec-  = mapSnd Mb.catMaybes $-    unzip (measureTypeToInv env name <$> [(x, (y, ty)) | x <- xs, (y, ty) <- sigs-                                         , isSymbolOfVar (val x) y ])-  where-    sigs = gsTySigs sig-    xs   = S.toList (Ms.hmeas  mySpec)--isSymbolOfVar :: Symbol -> Ghc.Var -> Bool-isSymbolOfVar x v = x == symbol' v-  where-    symbol' :: Ghc.Var -> Symbol-    symbol' = GM.dropModuleNames . symbol . Ghc.getName--measureTypeToInv :: Bare.Env -> ModName -> (LocSymbol, (Ghc.Var, LocSpecType)) -> ((Maybe Ghc.Var, LocSpecType), Maybe UnSortedExpr)-measureTypeToInv env name (x, (v, t))-  = notracepp "measureTypeToInv" ((Just v, t {val = Bare.qualifyTop env name (F.loc x) mtype}), usorted)-  where-    trep = toRTypeRep (val t)-    rts  = ty_args  trep-    args = ty_binds trep-    res  = ty_res   trep-    z    = last args-    tz   = last rts-    usorted = if isSimpleADT tz then Nothing else mapFst (:[]) <$> mkReft (dummyLoc $ F.symbol v) z tz res-    mtype-      | null rts-      = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x) "Measure has no arguments!"-      | otherwise-      = mkInvariant x z tz res-    isSimpleADT (RApp _ ts _ _) = all isRVar ts-    isSimpleADT _               = False--mkInvariant :: LocSymbol -> Symbol -> SpecType -> SpecType -> SpecType-mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft' mempty)-      where-        reft' = Mb.maybe mempty Reft mreft-        mreft = mkReft x z t tr---mkReft :: LocSymbol -> Symbol -> SpecType -> SpecType -> Maybe (Symbol, Expr)-mkReft x z _t tr-  | Just q <- stripRTypeBase tr-  = let Reft (v, p) = toReft q-        su          = mkSubst [(v, mkEApp x [EVar v]), (z,EVar v)]-        -- p'          = pAnd $ filter (\e -> z `notElem` syms e) $ conjuncts p-    in  Just (v, subst su p)-mkReft _ _ _ _-  = Nothing----- REBARE: formerly, makeGhcSpec3---------------------------------------------------------------------------------------------makeSpecName :: Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> ModName -> GhcSpecNames---------------------------------------------------------------------------------------------makeSpecName env tycEnv measEnv name = SpNames-  { gsFreeSyms = Bare.reSyms env-  , gsDconsP   = [ F.atLoc dc (dcpCon dc) | dc <- datacons ++ cls ]-  , gsTconsP   = Bare.qualifyTopDummy env name <$> tycons-  -- , gsLits = mempty                                              -- TODO-REBARE, redundant with gsMeas-  , gsTcEmbeds = Bare.tcEmbs     tycEnv-  , gsADTs     = Bare.tcAdts     tycEnv-  , gsTyconEnv = Bare.tcTyConMap tycEnv-  }-  where-    datacons, cls :: [DataConP]-    datacons   = Bare.tcDataCons tycEnv-    cls        = F.notracepp "meClasses" $ Bare.meClasses measEnv-    tycons     = Bare.tcTyCons   tycEnv----- REBARE: formerly, makeGhcCHOP1--- split into two to break circular dependency. we need dataconmap for core2logic---------------------------------------------------------------------------------------------makeTycEnv0 :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs-           -> (Diagnostics,  [Located DataConP], Bare.TycEnv)---------------------------------------------------------------------------------------------makeTycEnv0 cfg myName env embs mySpec iSpecs = (diag0 <> diag1, datacons, Bare.TycEnv-  { tcTyCons      = tycons-  , tcDataCons    = mempty -- val <$> datacons-  , tcSelMeasures = dcSelectors-  , tcSelVars     = mempty -- recSelectors-  , tcTyConMap    = tyi-  , tcAdts        = adts-  , tcDataConMap  = dm-  , tcEmbs        = embs-  , tcName        = myName-  })-  where-    (tcDds, dcs)   = conTys-    (diag0, conTys) = withDiagnostics $ Bare.makeConTypes myName env specs-    specs         = (myName, mySpec) : M.toList iSpecs-    tcs           = Misc.snd3 <$> tcDds-    tyi           = Bare.qualifyTopDummy env myName (makeTyConInfo embs fiTcs tycons)-    -- tycons        = F.tracepp "TYCONS" $ Misc.replaceWith tcpCon tcs wiredTyCons-    -- datacons      =  Bare.makePluggedDataCons embs tyi (Misc.replaceWith (dcpCon . val) (F.tracepp "DATACONS" $ concat dcs) wiredDataCons)-    tycons        = tcs ++ knownWiredTyCons env myName-    datacons      = Bare.makePluggedDataCon (typeclass cfg) embs tyi <$> (concat dcs ++ knownWiredDataCons env myName)-    tds           = [(name, tcpCon tcp, dd) | (name, tcp, Just dd) <- tcDds]-    (diag1, adts) = Bare.makeDataDecls cfg embs myName tds       datacons-    dm            = Bare.dataConMap adts-    dcSelectors   = concatMap (Bare.makeMeasureSelectors cfg dm) (if reflection cfg then charDataCon:datacons else datacons)-    fiTcs         = _gsFiTcs (Bare.reSrc env)----makeTycEnv1 ::-     ModName-  -> Bare.Env-  -> (Bare.TycEnv, [Located DataConP])-  -> (Ghc.CoreExpr -> F.Expr)-  -> (Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr)-  -> Ghc.TcRn Bare.TycEnv-makeTycEnv1 myName env (tycEnv, datacons) coreToLg simplifier = do-  -- fst for selector generation, snd for dataconsig generation-  lclassdcs <- forM classdcs $ traverse (Bare.elaborateClassDcp coreToLg simplifier)-  let recSelectors = Bare.makeRecordSelectorSigs env myName (dcs ++ (fmap . fmap) snd lclassdcs)-  pure $-    tycEnv {Bare.tcSelVars = recSelectors, Bare.tcDataCons = F.val <$> ((fmap . fmap) fst lclassdcs ++ dcs )}-  where-    (classdcs, dcs) =-      L.partition-        (Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon . F.val) datacons---knownWiredDataCons :: Bare.Env -> ModName -> [Located DataConP]-knownWiredDataCons env name = filter isKnown wiredDataCons-  where-    isKnown                 = Bare.knownGhcDataCon env name . GM.namedLocSymbol . dcpCon . val--knownWiredTyCons :: Bare.Env -> ModName -> [TyConP]-knownWiredTyCons env name = filter isKnown wiredTyCons-  where-    isKnown               = Bare.knownGhcTyCon env name . GM.namedLocSymbol . tcpCon----- REBARE: formerly, makeGhcCHOP2---------------------------------------------------------------------------------------------makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs ->-               Bare.Lookup Bare.MeasEnv---------------------------------------------------------------------------------------------makeMeasEnv env tycEnv sigEnv specs = do-  laws        <- Bare.makeCLaws env sigEnv name specs-  (cls, mts)  <- Bare.makeClasses        env sigEnv name specs-  let dms      = Bare.makeDefaultMethods env mts-  measures0   <- mapM (Bare.makeMeasureSpec env sigEnv name) (M.toList specs)-  let measures = mconcat (Ms.mkMSpec' dcSelectors : measures0)-  let (cs, ms) = Bare.makeMeasureSpec'  (typeclass $ getConfig env)   measures-  let cms      = Bare.makeClassMeasureSpec measures-  let cms'     = [ (x, Loc l l' $ cSort t)  | (Loc l l' x, t) <- cms ]-  let ms'      = [ (F.val lx, F.atLoc lx t) | (lx, t) <- ms-                                            , Mb.isNothing (lookup (val lx) cms') ]-  let cs'      = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec (typeclass (getConfig env)) embs cs (datacons ++ cls)]-  return Bare.MeasEnv-    { meMeasureSpec = measures-    , meClassSyms   = cms'-    , meSyms        = ms'-    , meDataCons    = cs'-    , meClasses     = cls-    , meMethods     = mts ++ dms-    , meCLaws       = laws-    }-  where-    txRefs v t    = Bare.txRefSort tyi embs (t <$ GM.locNamedThing v)-    tyi           = Bare.tcTyConMap    tycEnv-    dcSelectors   = Bare.tcSelMeasures tycEnv-    datacons      = Bare.tcDataCons    tycEnv-    embs          = Bare.tcEmbs        tycEnv-    name          = Bare.tcName        tycEnv---------------------------------------------------------------------------------------------- | @makeLiftedSpec@ is used to generate the BareSpec object that should be serialized---   so that downstream files that import this target can access the lifted definitions,---   e.g. for measures, reflected functions etc.-------------------------------------------------------------------------------------------makeLiftedSpec :: ModName -> GhcSrc -> Bare.Env-               -> GhcSpecRefl -> GhcSpecData -> GhcSpecSig -> GhcSpecQual -> BareRTEnv-               -> Ms.BareSpec -> Ms.BareSpec-------------------------------------------------------------------------------------------makeLiftedSpec name src _env refl sData sig qual myRTE lSpec0 = lSpec0-  { Ms.asmSigs    = F.notracepp   ("makeLiftedSpec : ASSUMED-SIGS " ++ F.showpp name ) (xbs ++ myDCs)-  , Ms.reflSigs   = F.notracepp "REFL-SIGS"         xbs-  , Ms.sigs       = F.notracepp   ("makeLiftedSpec : LIFTED-SIGS " ++ F.showpp name )  $ mkSigs (gsTySigs sig)-  , Ms.invariants = [ (varLocSym <$> x, Bare.specToBare <$> t)-                       | (x, t) <- gsInvariants sData-                       , isLocInFile srcF t-                    ]-  , Ms.axeqs      = gsMyAxioms refl-  , Ms.aliases    = F.notracepp "MY-ALIASES" $ M.elems . typeAliases $ myRTE-  , Ms.ealiases   = M.elems . exprAliases $ myRTE-  , Ms.qualifiers = filter (isLocInFile srcF) (gsQualifiers qual)-  }-  where-    myDCs         = [(x,t) | (x,t) <- mkSigs (gsCtors sData)-                           , F.symbol name == fst (GM.splitModuleName $ val x)]-    mkSigs xts    = [ toBare (x, t) | (x, t) <- xts-                    ,  S.member x sigVars && isExportedVar (toTargetSrc src) x-                    ]-    toBare (x, t) = (varLocSym x, Bare.specToBare <$> t)-    xbs           = toBare <$> reflTySigs-    sigVars       = S.difference defVars reflVars-    defVars       = S.fromList (_giDefVars src)-    reflTySigs    = [(x, t) | (x,t,_) <- gsHAxioms refl, x `notElem` gsWiredReft refl]-    reflVars      = S.fromList (fst <$> reflTySigs)-    -- myAliases fld = M.elems . fld $ myRTE-    srcF          = _giTarget src---- | Returns 'True' if the input determines a location within the input file. Due to the fact we might have--- Haskell sources which have \"companion\" specs defined alongside them, we also need to account for this--- case, by stripping out the extensions and check that the LHS is a Haskell source and the RHS a spec file.-isLocInFile :: (F.Loc a) => FilePath -> a ->  Bool-isLocInFile f lx = f == lifted || isCompanion-  where-    lifted :: FilePath-    lifted = locFile lx--    isCompanion :: Bool-    isCompanion =-      (==) (dropExtension f) (dropExtension lifted)-       &&  isExtFile Hs f-       &&  isExtFile Files.Spec lifted--locFile :: (F.Loc a) => a -> FilePath-locFile = Misc.fst3 . F.sourcePosElts . F.sp_start . F.srcSpan--varLocSym :: Ghc.Var -> LocSymbol-varLocSym v = F.symbol <$> GM.locNamedThing v+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE OverloadedStrings         #-}++-- | This module contains the functions that convert /from/ descriptions of+--   symbols, names and types (over freshly parsed /bare/ Strings),+--   /to/ representations connected to GHC 'Var's, 'Name's, and 'Type's.+--   The actual /representations/ of bare and real (refinement) types are all+--   in 'RefType' -- they are different instances of 'RType'.++module Language.Haskell.Liquid.Bare (+  -- * Creating a TargetSpec+  -- $creatingTargetSpecs+    makeTargetSpec+  ) where++import           Control.Monad                              (forM, mplus, when)+import qualified Control.Exception                          as Ex+import qualified Data.Maybe                                 as Mb+import qualified Data.List                                  as L+import qualified Data.HashMap.Strict                        as M+import qualified Data.HashSet                               as S+import           Text.PrettyPrint.HughesPJ                  hiding (first, (<>)) -- (text, (<+>))+import           System.FilePath                            (dropExtension)+import           Language.Fixpoint.Utils.Files              as Files+import           Language.Fixpoint.Misc                     as Misc+import           Language.Fixpoint.Types                    hiding (dcFields, DataDecl, Error, panic)+import qualified Language.Fixpoint.Types                    as F+import qualified Language.Haskell.Liquid.Misc               as Misc -- (nubHashOn)+import qualified Language.Haskell.Liquid.GHC.Misc           as GM+import qualified Liquid.GHC.API            as Ghc+import           Language.Haskell.Liquid.GHC.Types          (StableName)+import           Language.Haskell.Liquid.LHNameResolution+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.PredType+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Visitors+import           Language.Haskell.Liquid.WiredIn+import qualified Language.Haskell.Liquid.Measure            as Ms+import qualified Language.Haskell.Liquid.Bare.Types         as Bare+import qualified Language.Haskell.Liquid.Bare.Resolve       as Bare+import qualified Language.Haskell.Liquid.Bare.DataType      as Bare+import           Language.Haskell.Liquid.Bare.Elaborate+import qualified Language.Haskell.Liquid.Bare.Expand        as Bare+import qualified Language.Haskell.Liquid.Bare.Measure       as Bare+import qualified Language.Haskell.Liquid.Bare.Plugged       as Bare+import qualified Language.Haskell.Liquid.Bare.Axiom         as Bare+import qualified Language.Haskell.Liquid.Bare.ToBare        as Bare+import qualified Language.Haskell.Liquid.Bare.Class         as Bare+import qualified Language.Haskell.Liquid.Bare.Check         as Bare+import qualified Language.Haskell.Liquid.Bare.Resolve       as Resolve+import qualified Language.Haskell.Liquid.Bare.Typeclass     as Bare+import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic+import           Language.Haskell.Liquid.UX.Config+import Data.Hashable (Hashable)+import Data.Bifunctor (bimap, first)+import Data.Function (on)+++{- $creatingTargetSpecs++/Liquid Haskell/ operates on 'TargetSpec's, so this module provides a single function called+'makeTargetSpec' to produce a 'TargetSpec', alongside the 'LiftedSpec'. The former will be used by+functions like 'liquid' or 'liquidOne' to verify our program is correct, the latter will be serialised+to disk so that we can retrieve it later without having to re-check the relevant Haskell file.+-}++-- | 'makeTargetSpec' constructs the 'TargetSpec' and then validates it. Upon success, the 'TargetSpec'+-- and the 'LiftedSpec' are returned. We perform error checking in \"two phases\": during the first phase,+-- we check for errors and warnings in the input 'BareSpec' and the dependencies. During this phase we ideally+-- want to short-circuit in case the validation failure is found in one of the dependencies (to avoid+-- printing potentially endless failures).+-- The second phase involves creating the 'TargetSpec', and returning either the full list of diagnostics+-- (errors and warnings) in case things went wrong, or the final 'TargetSpec' and 'LiftedSpec' together+-- with a list of 'Warning's, which shouldn't abort the compilation (modulo explicit request from the user,+-- to treat warnings and errors).+makeTargetSpec :: Config+               -> Bare.LocalVars+               -> LogicNameEnv+               -> LogicMap+               -> TargetSrc+               -> BareSpec+               -> TargetDependencies+               -> Ghc.TcRn (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))+makeTargetSpec cfg localVars lnameEnv lmap targetSrc bareSpec dependencies = do+  let targDiagnostics     = Bare.checkTargetSrc cfg targetSrc+  let depsDiagnostics     = mapM (Bare.checkBareSpec . snd) legacyDependencies+  let bareSpecDiagnostics = Bare.checkBareSpec bareSpec+  case targDiagnostics >> depsDiagnostics >> bareSpecDiagnostics of+   Left d | noErrors d -> secondPhase (allWarnings d)+   Left d              -> return $ Left d+   Right ()            -> secondPhase mempty+  where+    secondPhase :: [Warning] -> Ghc.TcRn (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))+    secondPhase phaseOneWarns = do+      diagOrSpec <- makeGhcSpec cfg lnameEnv localVars (fromTargetSrc targetSrc) lmap bareSpec legacyDependencies+      case diagOrSpec of+        Left d -> return $ Left d+        Right (warns, ghcSpec) -> do+          let targetSpec = toTargetSpec ghcSpec+              liftedSpec = ghcSpecToLiftedSpec ghcSpec+          liftedSpec' <- removeUnexportedLocalAssumptions liftedSpec+          return $ Right (phaseOneWarns <> warns, targetSpec, liftedSpec')++    toLegacyDep :: (Ghc.StableModule, LiftedSpec) -> (ModName, BareSpec)+    toLegacyDep (sm, ls) = (ModName SrcImport (Ghc.moduleName . Ghc.unStableModule $ sm), fromBareSpecLHName $ unsafeFromLiftedSpec ls)++    legacyDependencies :: [(ModName, BareSpec)]+    legacyDependencies =+      -- Dependencies are sorted lexicographically to make predictable which+      -- logic names will have preference when exporting conflicting measures.+      --+      -- At the moment it is the measure from the last module after sorting.+      -- But if there is a local conflicting measure, that one is used.+      L.sortOn fst $ map toLegacyDep $ M.toList $ getDependencies dependencies++    -- Assumptions about local functions that are not exported aren't useful for+    -- other modules.+    removeUnexportedLocalAssumptions :: LiftedSpec -> Ghc.TcRn LiftedSpec+    removeUnexportedLocalAssumptions lspec = do+      tcg <- Ghc.getGblEnv+      let exportedNames = Ghc.availsToNameSet (Ghc.tcg_exports tcg)+          exportedAssumption (LHNResolved (LHRGHC n) _) =+            case Ghc.nameModule_maybe n of+              Nothing -> Ghc.elemNameSet n exportedNames+              Just m -> m /= Ghc.tcg_mod tcg || Ghc.elemNameSet n exportedNames+          exportedAssumption _ = True+      return lspec { liftedAsmSigs = S.filter (exportedAssumption . val . fst) (liftedAsmSigs lspec) }++    ghcSpecToLiftedSpec = toLiftedSpec . toBareSpecLHName cfg lnameEnv . _gsLSpec+++-------------------------------------------------------------------------------------+-- | @makeGhcSpec@ invokes @makeGhcSpec0@ to construct the @GhcSpec@ and then+--   validates it using @checkGhcSpec@.+-------------------------------------------------------------------------------------+makeGhcSpec :: Config+            -> LogicNameEnv+            -> Bare.LocalVars+            -> GhcSrc+            -> LogicMap+            -> Ms.BareSpec+            -> [(ModName, Ms.BareSpec)]+            -> Ghc.TcRn (Either Diagnostics ([Warning], GhcSpec))+-------------------------------------------------------------------------------------+makeGhcSpec cfg lenv localVars src lmap targetSpec dependencySpecs = do+  ghcTyLookupEnv <- Bare.makeGHCTyLookupEnv (_giCbs src)+  tcg <- Ghc.getGblEnv+  instEnvs <- Ghc.tcGetInstEnvs+  (dg0, sp) <- makeGhcSpec0 cfg ghcTyLookupEnv tcg instEnvs lenv localVars src lmap targetSpec dependencySpecs+  let diagnostics = Bare.checkTargetSpec (targetSpec : map snd dependencySpecs)+                                         (toTargetSrc src)+                                         (ghcSpecEnv sp)+                                         (_giCbs src)+                                         (toTargetSpec sp)+  pure $ if not (noErrors dg0) then Left dg0 else+           case diagnostics of+             Left dg1+               | noErrors dg1 -> pure (allWarnings dg1, sp)+               | otherwise    -> Left dg1+             Right ()         -> pure (mempty, sp)+++ghcSpecEnv :: GhcSpec -> SEnv SortedReft+ghcSpecEnv sp = F.notracepp "RENV" $ fromListSEnv binds+  where+    emb       = gsTcEmbeds (_gsName sp)+    binds     = F.notracepp "binds" $ concat+                 [ [(x,        rSort t) | (x, Loc _ _ t)  <- gsMeas     (_gsData sp)]+                 , [(symbol v, rSort t) | (v, Loc _ _ t)  <- gsCtors    (_gsData sp)]+                 , [(symbol v, vSort v) | v               <- gsReflects (_gsRefl sp)]+                 , [(x, RR s mempty)    | (x, s)          <- wiredSortedSyms       ]+                 , [(x, RR s mempty)    | (x, s)          <- _gsImps sp       ]+                 ]+    vSort     = rSort . classRFInfoType (typeclass $ getConfig sp) .+                (ofType :: Ghc.Type -> SpecType) . Ghc.varType+    rSort     = rTypeSortedReft    emb+++-------------------------------------------------------------------------------------+-- | @makeGhcSpec0@ slurps up all the relevant information needed to generate+--   constraints for a target module and packages them into a @GhcSpec@+--   See [NOTE] LIFTING-STAGES to see why we split into lSpec0, lSpec1, etc.+--   essentially, to get to the `BareRTEnv` as soon as possible, as thats what+--   lets us use aliases inside data-constructor definitions.+-------------------------------------------------------------------------------------+makeGhcSpec0+  :: Config+  -> Bare.GHCTyLookupEnv+  -> Ghc.TcGblEnv+  -> Ghc.InstEnvs+  -> LogicNameEnv+  -> Bare.LocalVars+  -> GhcSrc+  -> LogicMap+  -> Ms.BareSpec+  -> [(ModName, Ms.BareSpec)]+  -> Ghc.TcRn (Diagnostics, GhcSpec)+makeGhcSpec0 cfg ghcTyLookupEnv tcg instEnvs lenv localVars src lmap targetSpec dependencySpecs = do+  globalRdrEnv <- Ghc.tcg_rdr_env <$> Ghc.getGblEnv+  -- build up environments+  tycEnv <- makeTycEnv1 env (tycEnv0, datacons) coreToLg simplifier+  let tyi      = Bare.tcTyConMap   tycEnv+  let sigEnv   = makeSigEnv  embs tyi (_gsExports src) rtEnv+  let lSpec1   = makeLiftedSpec1 cfg src tycEnv lmap mySpec1+  let mySpec   = mySpec2 <> lSpec1+  let specs    = M.insert name mySpec iSpecs2+  let myRTE    = myRTEnv       src env sigEnv rtEnv+  -- NB: we first compute a measure environment w/o the opaque reflections, so that we can bootstrap+  -- the signature `sig`. Then we'll add the opaque reflections before we compute `sData` and al.+  let (dg1, measEnv0) = withDiagnostics $ makeMeasEnv      env tycEnv sigEnv       specs+  let (dg2, (specInstances, sig)) = withDiagnostics $ makeSpecSig cfg name mySpec iSpecs2 env sigEnv tycEnv measEnv0 (_giCbs src)+  elaboratedSig <-+    if allowTC then Bare.makeClassAuxTypes (elaborateSpecType coreToLg simplifier) datacons instMethods+                              >>= elaborateSig sig+               else pure sig+  let (dg3, refl)    = withDiagnostics $ makeSpecRefl src specs env name elaboratedSig tycEnv+  let eqs            = gsHAxioms refl+  let (dg4, measEnv) = withDiagnostics $ addOpaqueReflMeas cfg tycEnv env mySpec measEnv0 specs eqs+  let qual = makeSpecQual cfg env globalRdrEnv tycEnv measEnv rtEnv mySpec iSpecs2+  let (dg5, spcVars) = withDiagnostics $ makeSpecVars cfg src mySpec env measEnv+  let (dg6, spcTerm) = withDiagnostics $ makeSpecTerm cfg     mySpec lenv env+  let sData    = makeSpecData  src env sigEnv measEnv elaboratedSig specs+  let finalLiftedSpec = makeLiftedSpec name src env refl sData elaboratedSig qual myRTE (lSpec0 <> lSpec1)+  let diags    = mconcat [dg0, dg1, dg2, dg3, dg4, dg5, dg6]++  -- Dump reflections, if requested+  when (dumpOpaqueReflections cfg) . Ghc.liftIO $ do+    putStrLn ""+    if L.null (Bare.meOpaqueRefl measEnv) then do+      putStrLn "No opaque reflection was generated."+    else do+      putStrLn "Opaque reflections: "+      let sortedRefls = L.sort $ fst <$> Bare.meOpaqueRefl measEnv+      mapM_ (putStrLn . ("- " ++) . show) sortedRefls+    putStrLn ""++  pure (diags, SP+    { _gsConfig = cfg+    , _gsImps   = makeImports mspecs+    , _gsSig    = addReflSigs env name rtEnv measEnv refl elaboratedSig+    , _gsRefl   = refl+    , _gsData   = sData+    , _gsQual   = qual+    , _gsName   = makeSpecName tycEnv measEnv dataConIds+    , _gsVars   = spcVars+    , _gsTerm   = spcTerm++    , _gsLSpec  = finalLiftedSpec+                { expSigs   =+                    [ (lhNameToResolvedSymbol $ reflectGHCName thisModule $ Ghc.getName v, F.sr_sort $ Bare.varSortedReft embs v)+                    | v <- gsReflects refl+                    ]+                , dataDecls = Bare.dataDeclSize mySpec $ dataDecls mySpec+                  -- Placing mySpec at the end causes local measures to take precedence over+                  -- imported measures when their names clash.+                , measures  = mconcat $ map Ms.measures $ map snd dependencySpecs ++ [mySpec]+                  -- We want to export measures in a 'LiftedSpec', especially if they are+                  -- required to check termination of some 'liftedSigs' we export. Due to the fact+                  -- that 'lSpec1' doesn't contain the measures that we compute via 'makeHaskellMeasures',+                  -- we take them from 'mySpec', which has those.+                , asmSigs = Ms.asmSigs finalLiftedSpec ++ Ms.asmSigs mySpec+                  -- Export all the assumptions (not just the ones created out of reflection) in+                  -- a 'LiftedSpec'.+                , omeasures = Ms.omeasures finalLiftedSpec ++ (snd <$> Bare.meOpaqueRefl measEnv)+                  -- Preserve 'o-measures': they are the opaque reflections+                , imeasures = Ms.imeasures finalLiftedSpec ++ Ms.imeasures mySpec+                  -- Preserve user-defined 'imeasures'.+                , dvariance = Ms.dvariance finalLiftedSpec ++ Ms.dvariance mySpec+                  -- Preserve user-defined 'dvariance'.+                , rinstance = specInstances+                  -- Preserve rinstances.+                , asmReflectSigs = Ms.asmReflectSigs mySpec+                , reflects = Ms.reflects mySpec0+                , cmeasures  = mconcat $ map Ms.cmeasures $ map snd dependencySpecs ++ [targetSpec]+                , embeds = Ms.embeds targetSpec+                , privateReflects = mconcat $ map (privateReflects . snd) mspecs+                , defines = Ms.defines targetSpec+                , usedDataCons = usedDcs+                }+    })+  where+    thisModule = Ghc.tcg_mod tcg+    -- typeclass elaboration++    coreToLg ce =+      case CoreToLogic.runToLogic+             embs+             lmap+             dm+             cfg+             (\x -> todo Nothing ("coreToLogic not working " ++ x))+             (CoreToLogic.coreToLogic ce) of+        Left msg -> panic Nothing (F.showpp msg)+        Right e -> e+    elaborateSig si auxsig = do+      tySigs <-+        forM (gsTySigs si) $ \(x, t) ->+          if GM.isFromGHCReal x then+            pure (x, t)+          else do t' <- traverse (elaborateSpecType coreToLg simplifier) t+                  pure (x, t')+      -- things like len breaks the code+      -- asmsigs should be elaborated only if they are from the current module+      -- asmSigs <- forM (gsAsmSigs si) $ \(x, t) -> do+      --   t' <- traverse (elaborateSpecType (pure ()) coreToLg) t+      --   pure (x, fst <$> t')+      pure+        si+          { gsTySigs = F.notracepp ("asmSigs" ++ F.showpp (gsAsmSigs si)) tySigs ++ auxsig  }++    simplifier :: Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr+    simplifier = pure -- no simplification+    allowTC  = typeclass cfg+    mySpec2  = Bare.expand rtEnv (F.dummyPos "expand-mySpec2") mySpec1+    iSpecs2  = Bare.expand rtEnv (F.dummyPos "expand-iSpecs2") (M.fromList dependencySpecs)+    rtEnv    = Bare.makeRTEnv env name mySpec1 dependencySpecs lmap+    mspecs   = (name, mySpec0) : dependencySpecs+    (mySpec0, instMethods)  = if allowTC+                              then Bare.compileClasses src env (name, targetSpec) dependencySpecs+                              else (targetSpec, [])+    mySpec1  = mySpec0 <> lSpec0+    lSpec0   = makeLiftedSpec0 cfg src embs lmap mySpec0+    embs     = makeEmbeds          src ghcTyLookupEnv (mySpec0 : map snd dependencySpecs)+    dm       = Bare.tcDataConMap tycEnv0+    (dg0, datacons, tycEnv0) = makeTycEnv0   cfg name env embs mySpec2 iSpecs2+    env      = Bare.makeEnv cfg ghcTyLookupEnv dataConIds tcg instEnvs localVars src lmap ((name, targetSpec) : dependencySpecs)+    -- check barespecs+    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod  src+    zzz      = F.showpp (fst <$> mspecs)++    usedDcs  = collectAllDataCons (_giCbs src) $ targetSpec : map snd dependencySpecs+    dataConIds =+      [ Ghc.dataConWorkId dc+      | lhn <- S.toList usedDcs+      , Just (Ghc.AConLike (Ghc.RealDataCon dc)) <-+          [maybeReflectedLHName lhn >>= Resolve.lookupGhcTyThingFromName ghcTyLookupEnv]+      ]+++collectAllDataCons :: Ghc.CoreProgram -> [BareSpec] -> S.HashSet LHName+collectAllDataCons cbs =+    S.unions .  (castDCs :) . (usedInCoreDCs :) . map usedDataCons+  where+    -- Constraint generation might inserts data constructors which are not+    -- present in the original program.+    -- See Note [Type classes with a single method] in+    -- Haskell.Liquid.Constraint.Generate+    castDCs =+      S.fromList $+      map makeLogicLHNameFromDC $+      Mb.mapMaybe isClassConCoDC $+      collectCastCoercions cbs++    makeLogicLHNameFromDC dc =+      let n = Ghc.getName dc+          s = symbol (Ghc.getOccString dc)+       in makeLogicLHName+            s+            (Mb.fromMaybe (error "expected module") $ Ghc.nameModule_maybe n)+            (Just n)++    usedInCoreDCs =+      S.fromList $+      map makeLogicLHNameFromDC $+      [ dc+      | v <- freeVars S.empty cbs+      , dc <- case Ghc.idDetails v of+          Ghc.DataConWrapId dc -> [dc]+          Ghc.DataConWorkId dc -> [dc]+          _ -> []+      ]++    isClassConCoDC :: Ghc.Coercion -> Maybe Ghc.DataCon+    -- See Note [Type classes with a single method] in+    -- Haskell.Liquid.Constraint.Generate+    isClassConCoDC co+      | Ghc.Pair _t1 t2 <- Ghc.coercionKind co+      , Ghc.isClassPred t2+      , (tc,_ts) <- Ghc.splitTyConApp t2+      , [dc]    <- Ghc.tyConDataCons tc+      = Just dc+      | otherwise+      = Nothing++    collectCastCoercions :: [Ghc.CoreBind] -> [Ghc.Coercion]+    collectCastCoercions = gos [] . concatMap Ghc.rhssOfBind+      where+        go acc e = case e of+          Ghc.Var{} -> acc+          Ghc.Lit{} -> acc+          Ghc.Type{} -> acc+          Ghc.Coercion{} -> acc+          Ghc.App e1 e2 -> go (go acc e1) e2+          Ghc.Cast e1 c -> go (c:acc) e1+          Ghc.Tick _ e1 -> go acc e1+          Ghc.Lam _ e1 -> go acc e1+          Ghc.Let b e1 -> go (gos acc (Ghc.rhssOfBind b)) e1+          Ghc.Case e1 _ _ alts -> go (gos acc (Ghc.rhssOfAlts alts)) e1++        gos acc = foldr ($) acc . map (flip go)+++makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)]+makeImports specs = concatMap (expSigs . snd) specs'+  where specs' = filter (isSrcImport . fst) specs+++makeEmbeds :: GhcSrc -> Bare.GHCTyLookupEnv -> [Ms.BareSpec] -> F.TCEmb Ghc.TyCon+makeEmbeds src env+  = Bare.addClassEmbeds (_gsCls src) (_gsFiTcs src)+  . mconcat+  . map (makeTyConEmbeds env)++makeTyConEmbeds :: Bare.GHCTyLookupEnv -> Ms.BareSpec -> F.TCEmb Ghc.TyCon+makeTyConEmbeds env spec+  = F.tceFromList [ (tc, t) | (c,t) <- F.tceToList (Ms.embeds spec), tc <- symTc c ]+    where+      symTc = Mb.maybeToList . either (const Nothing) Just . Bare.lookupGhcTyConLHName env++--------------------------------------------------------------------------------+-- | [NOTE]: REFLECT-IMPORTS+--+-- 1. MAKE the full LiftedSpec, which will eventually, contain:+--      makeHaskell{Inlines, Measures, Axioms, Bounds}+-- 2. SAVE the LiftedSpec, which will be reloaded+--+--   This step creates the aliases and inlines etc. It must be done BEFORE+--   we compute the `SpecType` for (all, including the reflected binders),+--   as we need the inlines and aliases to properly `expand` the SpecTypes.+--------------------------------------------------------------------------------+makeLiftedSpec1 :: Config -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec+                -> Ms.BareSpec+makeLiftedSpec1 config src tycEnv lmap mySpec = mempty+  { Ms.measures  = Bare.makeHaskellMeasures config src tycEnv lmap mySpec }++--------------------------------------------------------------------------------+-- | [NOTE]: LIFTING-STAGES+--+-- We split the lifting up into stage:+-- 0. Where we only lift inlines,+-- 1. Where we lift reflects, measures, and normalized tySigs+--+-- This is because we need the inlines to build the @BareRTEnv@ which then+-- does the alias @expand@ business, that in turn, lets us build the DataConP,+-- i.e. the refined datatypes and their associate selectors, projectors etc,+-- that are needed for subsequent stages of the lifting.+--------------------------------------------------------------------------------+makeLiftedSpec0 :: Config -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec+                -> Ms.BareSpec+makeLiftedSpec0 cfg src embs lmap mySpec = mempty+  { Ms.ealiases  = lmapEAlias . snd <$> Bare.makeHaskellInlines cfg src embs lmap mySpec+  , Ms.dataDecls = Bare.makeHaskellDataDecls cfg mySpec tcs+  }+  where+    tcs          = uniqNub (_gsTcs src ++ refTcs)+    refTcs       = reflectedTyCons cfg embs cbs  mySpec+    cbs          = _giCbs       src++uniqNub :: (Ghc.Uniquable a) => [a] -> [a]+uniqNub xs = M.elems $ M.fromList [ (index x, x) | x <- xs ]+  where+    index  = Ghc.getKey . Ghc.getUnique++-- | 'reflectedTyCons' returns the list of `[TyCon]` that must be reflected but+--   which are defined *outside* the current module e.g. in Base or somewhere+--   that we don't have access to the code.++reflectedTyCons :: Config -> TCEmb Ghc.TyCon -> [Ghc.CoreBind] -> Ms.BareSpec -> [Ghc.TyCon]+reflectedTyCons cfg embs cbs spec+  | exactDCFlag cfg = filter (not . isEmbedded embs)+                    $ concatMap varTyCons+                    $ reflectedVars spec cbs ++ measureVars spec cbs+  | otherwise       = []++-- | We cannot reflect embedded tycons (e.g. Bool) as that gives you a sort+--   conflict: e.g. what is the type of is-True? does it take a GHC.Types.Bool+--   or its embedding, a bool?+isEmbedded :: TCEmb Ghc.TyCon -> Ghc.TyCon -> Bool+isEmbedded embs c = F.tceMember c embs++varTyCons :: Ghc.Var -> [Ghc.TyCon]+varTyCons = specTypeCons . ofType . Ghc.varType++specTypeCons           :: SpecType -> [Ghc.TyCon]+specTypeCons         = foldRType tc []+  where+    tc acc t@RApp {} = rtc_tc (rt_tycon t) : acc+    tc acc _         = acc++reflectedVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]+reflectedVars spec cbs =+    filter+      (isReflSym . makeGHCLHNameLocatedFromId)+      (Ghc.bindersOfBinds cbs)+  where+    isReflSym x =+      S.member x (Ms.reflects spec) ||+      S.member (fmap lhNameToResolvedSymbol x) (Ms.privateReflects spec)++measureVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]+measureVars spec cbs =+    filter+      ((`S.member` measureSyms) . makeGHCLHNameLocatedFromId)+      (Ghc.bindersOfBinds cbs)+  where+    measureSyms = Ms.hmeas spec++------------------------------------------------------------------------------------------+makeSpecVars :: Config -> GhcSrc -> Ms.BareSpec -> Bare.Env -> Bare.MeasEnv+             -> Bare.Lookup GhcSpecVars+------------------------------------------------------------------------------------------+makeSpecVars cfg src mySpec env measEnv = do+  let tgtVars = Mb.mapMaybe (`M.lookup` hvars) (checks     cfg)+  igVars      <-  sMapM (Bare.lookupGhcIdLHName env) (Ms.ignores mySpec)+  lVars       <-  sMapM (Bare.lookupGhcIdLHName env) (Ms.lvars   mySpec)+  return (SpVar tgtVars igVars lVars cMethods)+  where+    cMethods   = snd3 <$> Bare.meMethods measEnv+    hvars = M.fromList+      [ (Ghc.occNameString $ Ghc.getOccName b, b)+      | b <- Ghc.bindersOfBinds (_giCbs src)+      ]++sMapM :: (Monad m, Eq b, Hashable b) => (a -> m b) -> S.HashSet a -> m (S.HashSet b)+sMapM f xSet = do+ ys <- mapM f (S.toList xSet)+ return (S.fromList ys)++sForM :: (Monad m, Eq b, Hashable b) =>S.HashSet a -> (a -> m b) -> m (S.HashSet b)+sForM xs f = sMapM f xs++------------------------------------------------------------------------------------------+makeSpecQual+  :: Config+  -> Bare.Env+  -> Ghc.GlobalRdrEnv+  -> Bare.TycEnv+  -> Bare.MeasEnv+  -> BareRTEnv+  -> BareSpec+  -> Bare.ModSpecs+  -> GhcSpecQual+------------------------------------------------------------------------------------------+makeSpecQual _cfg env globalRdrEnv tycEnv measEnv _rtEnv mySpec depSpecs = SpQual+  { gsQualifiers = filter okQual quals+  , gsRTAliases  = [] -- makeSpecRTAliases env rtEnv -- TODO-REBARE+  }+  where+    quals =+      makeQualifiers env globalRdrEnv tycEnv mySpec +++      concatMap qualifiers (M.elems depSpecs)+    -- mSyms        = F.tracepp "MSYMS" $ M.fromList (Bare.meSyms measEnv ++ Bare.meClassSyms measEnv)+    okQual q     = F.notracepp ("okQual: " ++ F.showpp q)+                   $ all (`S.member` mSyms) (F.syms q)+    mSyms        = F.notracepp "MSYMS" . S.fromList+                   $  (fst <$> wiredSortedSyms)+                   ++ (fst <$> Bare.meSyms measEnv)+                   ++ (fst <$> Bare.meClassSyms measEnv)++makeQualifiers+  :: Bare.Env+  -> Ghc.GlobalRdrEnv+  -> Bare.TycEnv+  -> Ms.Spec F.Symbol ty+  -> [F.Qualifier]+makeQualifiers env globalRdrEnv tycEnv spec =+    Mb.mapMaybe (resolveQParams env globalRdrEnv tycEnv) $ Ms.qualifiers spec+++-- | @resolveQualParams@ converts the sorts of parameters from, e.g.+--     'Int' ===> 'GHC.Types.Int' or+--     'Ptr' ===> 'GHC.Ptr.Ptr'+--   It would not be required if _all_ qualifiers are scraped from+--   function specs, but we're keeping it around for backwards compatibility.++resolveQParams+  :: Bare.Env+  -> Ghc.GlobalRdrEnv+  -> Bare.TycEnv+  -> F.Qualifier+  -> Maybe F.Qualifier+resolveQParams env globalRdrEnv tycEnv q = do+     qps   <- mapM goQP (F.qParams q)+     return $ q { F.qParams = qps }+  where+    goQP qp          = do { s <- go (F.qpSort qp) ; return qp { F.qpSort = s } }+    go               :: F.Sort -> Maybe F.Sort+    go (FAbs i s)    = FAbs i <$> go s+    go (FFunc s1 s2) = FFunc  <$> go s1 <*> go s2+    go (FApp  s1 s2) = FApp   <$> go s1 <*> go s2+    go (FTC c)       = qualifyFTycon env globalRdrEnv tycEnv c+    go s             = Just s++qualifyFTycon+  :: Bare.Env+  -> Ghc.GlobalRdrEnv+  -> Bare.TycEnv+  -> F.FTycon+  -> Maybe F.Sort+qualifyFTycon env globalRdrEnv tycEnv c+  | isPrimFTC           = Just (FTC c)+  | otherwise           = tyConSort embs . F.atLoc tcs <$> ty+  where+    ty                  = case resolveSymbolToTcName globalRdrEnv tcs of+      Left e -> Ex.throw [e]+      Right lhname -> either Ex.throw Just $+                        Bare.lookupGhcTyConLHName (Bare.reTyLookupEnv env) lhname+    isPrimFTC           = F.val tcs `elem` F.prims+    tcs                 = F.fTyconSymbol c+    embs                = Bare.tcEmbs tycEnv++tyConSort :: F.TCEmb Ghc.TyCon -> F.Located Ghc.TyCon -> F.Sort+tyConSort embs lc = Mb.maybe s0 fst (F.tceLookup c embs)+  where+    c             = F.val lc+    s0            = tyConSortRaw lc++tyConSortRaw :: F.Located Ghc.TyCon -> F.Sort+tyConSortRaw = FTC . F.symbolFTycon . fmap F.symbol++------------------------------------------------------------------------------------------+makeSpecTerm :: Config -> Ms.BareSpec -> LogicNameEnv -> Bare.Env ->+                Bare.Lookup GhcSpecTerm+------------------------------------------------------------------------------------------+makeSpecTerm cfg mySpec lenv env = do+  sizes  <- if structuralTerm cfg then pure mempty else makeSize lenv env mySpec+  lazies <- makeLazy     env mySpec+  autos  <- makeAutoSize env mySpec+  gfail  <- makeFail env mySpec+  return  $ SpTerm+    { gsLazy       = S.insert dictionaryVar (lazies `mappend` sizes)+    , gsFail       = gfail+    , gsStTerm     = sizes+    , gsAutosize   = autos+    , gsNonStTerm  = mempty+    }++makeRelation :: Bare.Env -> ModName -> Bare.SigEnv ->+  [(Located LHName, Located LHName, LocBareType, LocBareType, RelExpr, RelExpr)] -> Bare.Lookup [(Ghc.Var, Ghc.Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]+makeRelation env name sigEnv = mapM go+ where+  go (x, y, tx, ty, a, e) = do+    vx <- Bare.lookupGhcIdLHName env x+    vy <- Bare.lookupGhcIdLHName env y+    return+        ( vx+        , vy+        , Bare.cookSpecType env sigEnv name (Bare.HsTV vx) tx+        , Bare.cookSpecType env sigEnv name (Bare.HsTV vy) ty+        , a+        , e+        )+++makeLazy :: Bare.Env -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var)+makeLazy env spec =+  sMapM (Bare.lookupGhcIdLHName env) (Ms.lazy spec)++makeFail :: Bare.Env -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))+makeFail env spec =+  sForM (Ms.fails spec) $ \x -> do+    vx <- Bare.lookupGhcIdLHName env x+    return x { val = vx }++makeRewrite :: Bare.Env -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))+makeRewrite env spec =+  sForM (Ms.rewrites spec) $ \x -> do+    vx <-  Bare.lookupGhcIdLHName env x+    return x { val = vx }++makeRewriteWith :: Bare.Env -> Ms.BareSpec -> Bare.Lookup (M.HashMap Ghc.Var [Ghc.Var])+makeRewriteWith env spec = M.fromList <$> makeRewriteWith' env spec++makeRewriteWith' :: Bare.Env -> Spec lname ty -> Bare.Lookup [(Ghc.Var, [Ghc.Var])]+makeRewriteWith' env spec =+  forM (M.toList $ Ms.rewriteWith spec) $ \(x, xs) -> do+    xv  <- Bare.lookupGhcIdLHName env x+    xvs <- mapM (Bare.lookupGhcIdLHName env) xs+    return (xv, xvs)++makeAutoSize :: Bare.Env -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.TyCon)+makeAutoSize env+  = fmap S.fromList+  . mapM (Bare.lookupGhcTyConLHName (Bare.reTyLookupEnv env))+  . S.toList+  . Ms.autosize++makeSize :: LogicNameEnv -> Bare.Env -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var)+makeSize lenv env+  = fmap S.fromList+  . mapM lookupGhcSize+  . Mb.mapMaybe getSizeFuns+  . Ms.dataDecls+  where+    lookupGhcSize :: LocSymbol -> Bare.Lookup Ghc.Var+    lookupGhcSize s =+      case lookupSEnv (val s) (lneLHName lenv) of+        Nothing -> panic (Just $ GM.fSrcSpan s) $ "symbol not in scope: " ++ show (val s)+        Just n -> case maybeReflectedLHName n of+          Nothing -> panic (Just $ GM.fSrcSpan s) $ "symbol not reflected: " ++ show (val s)+          Just rn -> Bare.lookupGhcIdLHName env (makeGHCLHName rn (symbol rn) <$ s)++getSizeFuns :: DataDecl -> Maybe LocSymbol+getSizeFuns decl+  | Just x       <- tycSFun decl+  , SymSizeFun f <- x+  = Just f+  | otherwise+  = Nothing+++------------------------------------------------------------------------------------------+makeSpecRefl :: GhcSrc -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv+             -> Bare.Lookup GhcSpecRefl+------------------------------------------------------------------------------------------+makeSpecRefl src specs env name sig tycEnv = do+  autoInst <- makeAutoInst env mySpec+  rwr      <- makeRewrite env mySpec+  rwrWith  <- makeRewriteWith env mySpec+  xtes     <- Bare.makeHaskellAxioms src env tycEnv lmap sig mySpec+  asmReflAxioms <- Bare.makeAssumeReflectAxioms src env tycEnv sig mySpec+  let otherAxioms = thd3 <$> asmReflAxioms+  let myAxioms =+        [ e {eqRec = S.member (eqName e) (exprSymbolsSet (eqBody e))}+        | (_, _, e) <- xtes+        ] ++ otherAxioms+  let asmReflEls = eqName <$> otherAxioms+  let impAxioms  = concatMap (filter ((`notElem` asmReflEls) . eqName) . Ms.axeqs . snd) (M.toList specs)+  case anyNonReflFn of+    Just (actSym , preSym) ->+      let preSym' = symbolString $ lhNameToUnqualifiedSymbol (val preSym) in+      let errorMsg = preSym' ++ " must be reflected first using {-@ reflect " ++ preSym' ++ " @-}"+      in Ex.throw+           (ErrHMeas+             (GM.sourcePosSrcSpan $ loc actSym)+             (pprint $ val actSym)+             (text errorMsg) :: Error)+    Nothing -> return SpRefl+      { gsLogicMap   = lmap+      , gsAutoInst   = autoInst+      , gsImpAxioms  = impAxioms+      , gsMyAxioms   = myAxioms+      , gsReflects   = (fst3 <$> xtes) ++ (fst <$> gsAsmReflects sig)+      , gsHAxioms    = F.notracepp "gsHAxioms" $ xtes ++ asmReflAxioms+      , gsRewrites   = rwr+      , gsRewritesWith = rwrWith+      }+  where+    mySpec       = M.lookupDefault mempty name specs+    lmap         = Bare.reLMap env+    notInReflOnes (_, a) = not $+      a `S.member` Ms.reflects mySpec ||+      fmap lhNameToResolvedSymbol a `S.member` Ms.privateReflects mySpec+    anyNonReflFn = L.find notInReflOnes (Ms.asmReflectSigs mySpec)++------------------------------------------------------------------------------------------+-- | @updateReflSpecSig@ uses the information about reflected functions (included the opaque ones) to update the+--   "assumed" signatures.+------------------------------------------------------------------------------------------+addReflSigs :: Bare.Env -> ModName -> BareRTEnv -> Bare.MeasEnv -> GhcSpecRefl -> GhcSpecSig -> GhcSpecSig+------------------------------------------------------------------------------------------+addReflSigs env name rtEnv measEnv refl sig =+  sig { gsRefSigs = F.notracepp ("gsRefSigs for " ++ F.showpp name) $ map expandReflectedSignature reflSigs+      , gsAsmSigs = F.notracepp ("gsAsmSigs for " ++ F.showpp name) combinedOpaqueAndReflectedAsmSigs+      }+  where+    -- We make sure that the reflected functions are excluded from `gsAsmSigs`, except for the signatures of+    -- actual functions in assume-reflect. The latter are added here because 1. it's what makes tests work+    -- and 2. so that we probably "shadow" the old signatures of the actual function correctly. Note that even if the+    -- signature of the actual function was asserted and not assumed, we do not put our new signature for the actual function+    -- in `gsTySigs` (which is for asserted signatures). Indeed, the new signature will *always* be an assumption since we+    -- add the extra post-condition that the actual and pretended function behave in the same way.+    -- Also, we add here the strengthened post-conditions relative to opaque reflections.+    -- We may redefine assumptions because of opaque reflections, so we just take the union of maps and ignore duplicates.+    -- Based on `M.union`'s handling of duplicates, the leftmost elements in the chain of `M.union` will precede over those+    -- after, which is why we put the opaque reflection first in the chain. The signatures for opaque reflections are created+    -- by strengthening the post-conditions, as in (assume-)reflection.+    combinedOpaqueAndReflectedAsmSigs = M.toList $+        M.fromList (createUpdatedSpecs . fst <$> Bare.meOpaqueRefl measEnv)+        `M.union` M.fromList (filter notReflected (gsAsmSigs sig))+    -- Strengthen the post-condition of each of the opaque reflections.+    createUpdatedSpecs var = (var, Bare.aty <$> Bare.strengthenSpecWithMeasure sig env var (Bare.varLocSym var))+    -- See T1738. We need to expand and qualify any reflected signature /here/, after any+    -- relevant binder has been detected and \"promoted\". The problem stems from the fact that any input+    -- 'BareSpec' will have a 'reflects' list of binders to reflect under the form of an opaque 'Var', that+    -- qualifyExpand can't touch when we do a first pass in 'makeGhcSpec0'. However, once we reflected all+    -- the functions, we are left with a pair (Var, LocSpecType). The latter /needs/ to be qualified and+    -- expanded again, for example in case it has expression aliases derived from 'inlines'.+    expandReflectedSignature :: (Ghc.Var, LocSpecType) -> (Ghc.Var, LocSpecType)+    expandReflectedSignature = fmap (Bare.expand rtEnv (F.dummyPos "expand-refSigs"))++    reflSigs = [ (x, t) | (x, t, _) <- gsHAxioms refl ]+    -- Get the set of all the actual functions (in assume-reflects)+    actualFnsInAssmRefl     = S.fromList $ fst <$> gsAsmReflects sig+    isActualFn           x  = S.member x actualFnsInAssmRefl+    -- Get all the variables from the axioms that are not actual functions (in assume-reflects)+    notReflActualTySigs     = L.filter (not . isActualFn . fst) reflSigs+    -- Get the list of reflected elements. We do not count actual functions in assume reflect as reflected+    reflected               = S.fromList $ fst <$> notReflActualTySigs+    notReflected xt         = fst xt `notElem` reflected++makeAutoInst :: Bare.Env -> Ms.BareSpec ->+                Bare.Lookup (S.HashSet Ghc.Var)+makeAutoInst env spec = S.fromList <$> kvs+  where+    kvs = forM (S.toList (Ms.autois spec)) $+            Bare.lookupGhcIdLHName env+++----------------------------------------------------------------------------------------+makeSpecSig :: Config -> ModName -> Ms.BareSpec -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]+            -> Bare.Lookup ([RInstance LocBareType], GhcSpecSig)+----------------------------------------------------------------------------------------+makeSpecSig cfg name mySpec specs env sigEnv tycEnv measEnv cbs = do+  mySigs     <- makeTySigs  env sigEnv name mySpec+  aSigs      <- F.notracepp ("makeSpecSig aSigs " ++ F.showpp name) $ makeAsmSigs env sigEnv name allSpecs+  let asmSigs =  Bare.tcSelVars tycEnv ++ aSigs+  let tySigs  = strengthenSigs . concat $+                  [ [(v, (0, t)) | (v, t,_) <- mySigs                         ]   -- NOTE: these weights are to priortize+                  , [(v, (1, t)) | (v, t  ) <- makeMthSigs measEnv            ]   -- user defined sigs OVER auto-generated+                  , [(v, (2, t)) | (v, t  ) <- makeInlSigs env rtEnv allSpecs ]   -- during the strengthening, i.e. to KEEP+                  , [(v, (3, t)) | (v, t  ) <- makeMsrSigs env rtEnv allSpecs ]   -- the binders used in USER-defined sigs+                  ]                                                               -- as they appear in termination metrics+  newTys     <-  makeNewTypes env sigEnv allSpecs+  relation   <-  makeRelation env name sigEnv (Ms.relational mySpec)+  asmRel     <-  makeRelation env name sigEnv (Ms.asmRel mySpec)+  return (instances, SpSig+    { gsTySigs   = tySigs+    , gsAsmSigs  = asmSigs+    , gsAsmReflects = bimap getVar getVar <$> concatMap (asmReflectSigs . snd) allSpecs+    , gsRefSigs  = []+    , gsDicts    = dicts+    -- , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses  measEnv) cbs+    , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes (typeclass cfg) dicts (Bare.meClasses  measEnv) cbs+    , gsInSigs   = mempty+    , gsNewTypes = newTys+    , gsTexprs   = [ (v, t, es) | (v, t, Just es) <- mySigs ]+    , gsRelation = relation+    , gsAsmRel   = asmRel+    })+  where+    (instances, dicts) = Bare.makeSpecDictionaries env sigEnv (name, mySpec) (M.toList specs)+    allSpecs   = (name, mySpec) : M.toList specs+    rtEnv      = Bare.sigRTEnv sigEnv+    getVar sym = case Bare.lookupGhcIdLHName env sym of+      Right x -> x+      Left _ -> panic (Just $ GM.fSrcSpan sym) "function to reflect not in scope"++strengthenSigs :: [(Ghc.Var, (Int, LocSpecType))] ->[(Ghc.Var, LocSpecType)]+strengthenSigs sigs = go <$> Misc.groupList sigs+  where+    go (v, ixs)     = (v,) $ L.foldl1' (flip meetLoc) (F.notracepp ("STRENGTHEN-SIGS: " ++ F.showpp v) (prio ixs))+    prio            = fmap snd . Misc.sortOn fst+    meetLoc         :: LocSpecType -> LocSpecType -> LocSpecType+    meetLoc t1 t2   = t1 {val = val t1 `meet` val t2}++makeMthSigs :: Bare.MeasEnv -> [(Ghc.Var, LocSpecType)]+makeMthSigs measEnv = [ (v, t) | (_, v, t) <- Bare.meMethods measEnv ]++makeInlSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]+makeInlSigs env rtEnv+  = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))+  . concatMap (map (lookupFunctionId env) . S.toList . Ms.inlines . snd)++makeMsrSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]+makeMsrSigs env rtEnv+  = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))+  . concatMap (map (lookupFunctionId env) . S.toList . Ms.hmeas . snd)++lookupFunctionId :: Bare.Env -> Located LHName -> Ghc.Id+lookupFunctionId env x =+    either (panic (Just $ GM.fSrcSpan x) "function not found") id $+    Bare.lookupGhcIdLHName env x++makeLiftedSigs :: BareRTEnv -> (Ghc.Var -> SpecType) -> [Ghc.Var] -> [(Ghc.Var, LocSpecType)]+makeLiftedSigs rtEnv f xs+  = [(x, lt) | x <- xs+             , let lx = GM.locNamedThing x+             , let lt = expand $ lx {val = f x}+    ]+  where+    expand   = Bare.specExpandType rtEnv++makeTySigs :: Bare.Env -> Bare.SigEnv -> ModName -> Ms.BareSpec+           -> Bare.Lookup [(Ghc.Var, LocSpecType, Maybe [Located F.Expr])]+makeTySigs env sigEnv name spec = do+  bareSigs   <- bareTySigs env                     spec+  expSigs    <- makeTExpr  env bareSigs rtEnv spec+  let rawSigs = Bare.resolveLocalBinds env expSigs+  return [ (x, cook x bt, z) | (x, bt, z) <- rawSigs ]+  where+    rtEnv     = Bare.sigRTEnv sigEnv+    cook x bt = Bare.cookSpecType env sigEnv name (Bare.HsTV x) bt++bareTySigs :: Bare.Env -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, LocBareType)]+bareTySigs env spec = checkDuplicateSigs <$> vts+  where+    vts = forM ( Ms.sigs spec ) $ \ (x, t) -> do+            v <- F.notracepp "LOOKUP-GHC-VAR" $ Bare.lookupGhcIdLHName env x+            return (v, t)++-- checkDuplicateSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]+checkDuplicateSigs :: (Symbolic x) => [(x, F.Located t)] -> [(x, F.Located t)]+checkDuplicateSigs xts = case Misc.uniqueByKey symXs  of+  Left (k, ls) -> uError (errDupSpecs (pprint k) (GM.sourcePosSrcSpan <$> ls))+  Right _      -> xts+  where+    symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]+++makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> [(ModName, Ms.BareSpec)] -> Bare.Lookup [(Ghc.Var, LocSpecType)]+makeAsmSigs env sigEnv myName specs = do+  raSigs <- rawAsmSigs env myName specs+  return [ (x, t) | (name, x, bt) <- raSigs, let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt ]++rawAsmSigs :: Bare.Env -> ModName -> [(ModName, Ms.BareSpec)] -> Bare.Lookup [(ModName, Ghc.Var, LocBareType)]+rawAsmSigs env myName specs = do+  aSigs <- allAsmSigs env myName specs+  return [ (m, v, t) | (v, sigs) <- aSigs, let (m, t) = myAsmSig v sigs ]++myAsmSig :: Ghc.Var -> [(Bool, ModName, LocBareType)] -> (ModName, LocBareType)+myAsmSig v sigs = Mb.fromMaybe errImp (mbHome `mplus` mbImp)+  where+    mbHome      = takeUnique mkErr                  sigsHome+    -- In case we import multiple specifications for the same function stemming from `assume-reflect` from different modules, we want+    -- to follow the same convention as in other places and so take the last one in alphabetical order and shadow the others+    mbImp       = takeBiggest   fst (Misc.firstGroup sigsImp) -- see [NOTE:Prioritize-Home-Spec]+    sigsHome    = [(m, t)      | (True,  m, t) <- sigs ]+    sigsImp     = F.notracepp ("SIGS-IMP: " ++ F.showpp v)+                  [(d, (m, t)) | (False, m, t) <- sigs, let d = nameDistance vName m]+    mkErr ts    = ErrDupSpecs (Ghc.getSrcSpan v) (F.pprint v) (GM.sourcePosSrcSpan . F.loc . snd <$> ts) :: UserError+    errImp      = impossible Nothing "myAsmSig: cannot happen as sigs is non-null"+    vName       = GM.takeModuleNames (F.symbol v)++makeTExpr :: Bare.Env -> [(Ghc.Var, LocBareType)] -> BareRTEnv -> Ms.BareSpec+          -> Bare.Lookup [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]+makeTExpr env tySigs rtEnv spec = do+  vExprs       <- M.fromList <$> makeVarTExprs env spec+  let vSigExprs = Misc.hashMapMapWithKey (\v t -> (t, M.lookup v vExprs)) vSigs+  return [ (v, t, qual <$> es) | (v, (t, es)) <- M.toList vSigExprs ]+  where+    qual es = expandTermExpr rtEnv <$> es+    vSigs = M.fromList tySigs++expandTermExpr :: BareRTEnv -> Located F.Expr -> Located F.Expr+expandTermExpr rtEnv le+        = F.atLoc le (Bare.expand rtEnv l e)+  where+    l   = F.loc le+    e   = F.val le++makeVarTExprs :: Bare.Env -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, [Located F.Expr])]+makeVarTExprs env spec =+  forM (Ms.termexprs spec) $ \(x, es) -> do+    vx <- Bare.lookupGhcIdLHName env x+    return (vx, es)++----------------------------------------------------------------------------------------+-- [NOTE:Prioritize-Home-Spec] Prioritize spec for THING defined in+-- `Foo.Bar.Baz.Quux.x` over any other specification, IF GHC's+-- fully qualified name for THING is `Foo.Bar.Baz.Quux.x`.+--+-- For example, see tests/names/neg/T1078.hs for example,+-- which assumes a spec for `head` defined in both+--+--   (1) Data/ByteString_LHAssumptions.hs+--   (2) Data/ByteString/Char8_LHAssumptions.hs+--+-- We end up resolving the `head` in (1) to the @Var@ `Data.ByteString.Char8.head`+-- even though there is no exact match, just to account for re-exports of "internal"+-- modules and such (see `Resolve.matchMod`). However, we should pick the closer name+-- if its available.+----------------------------------------------------------------------------------------+nameDistance :: F.Symbol -> ModName -> Int+nameDistance vName tName+  | vName == F.symbol tName = 0+  | otherwise               = 1++takeUnique :: Ex.Exception e => ([a] -> e) -> [a] -> Maybe a+takeUnique _ []  = Nothing+takeUnique _ [x] = Just x+takeUnique f xs  = Ex.throw (f xs)++takeBiggest :: (Ord b) => (a -> b) -> [a] -> Maybe a+takeBiggest _ []  = Nothing+takeBiggest f xs  = Just $ L.maximumBy (compare `on` f) xs++allAsmSigs :: Bare.Env -> ModName -> [(ModName, Ms.BareSpec)] ->+              Bare.Lookup [(Ghc.Var, [(Bool, ModName, LocBareType)])]+allAsmSigs env myName specs = do+  let aSigs = [ (name, locallyDefined, x, t) | (name, spec) <- specs+                                   , (locallyDefined, x, t) <- getAsmSigs myName name spec ]+  vSigs    <- forM aSigs $ \(name, locallyDefined, x, t) -> do+                v <- Bare.lookupGhcIdLHName env x+                return (v, (locallyDefined, name, t))+  return $ Misc.groupList+    [ (v, z) | (v, z) <- vSigs+      -- TODO: we require signatures to be in scope because LH includes them in+      -- the environment of contraints sometimes. The criteria to add bindings to+      -- constraints should account instead for what logic functions are used in+      -- the constraints, which should be easier to do when precise renaming has+      -- been implemented for expressions and reflected functions.+    , isUsedExternalVar v ||+      isInScope v ||+      isNonTopLevelVar v -- Keep assumptions about non-top-level bindings+    ]+  where+    isUsedExternalVar :: Ghc.Var -> Bool+    isUsedExternalVar v = case Ghc.idDetails v of+      Ghc.DataConWrapId dc ->+        Ghc.getName v `Ghc.elemNameSet` Bare.reUsedExternals env+         ||+        Ghc.getName (Ghc.dataConWorkId dc) `Ghc.elemNameSet` Bare.reUsedExternals env+      _ ->+        Ghc.getName v `Ghc.elemNameSet` Bare.reUsedExternals env++    isInScope :: Ghc.Var -> Bool+    isInScope v0 =+      let inScope v = not $ null $+            Ghc.lookupGRE_Name+              (Ghc.tcg_rdr_env $ Bare.reTcGblEnv env)+              (Ghc.getName v)+       in -- Names of data constructors are not found in the variable namespace+          -- so we look them instead in the data constructor namespace.+          case Ghc.idDetails v0 of+            Ghc.DataConWrapId dc -> inScope dc+            Ghc.DataConWorkId dc -> inScope dc+            _ -> inScope v0++    isNonTopLevelVar = Mb.isNothing . Ghc.nameModule_maybe . Ghc.getName++getAsmSigs :: ModName -> ModName -> Ms.BareSpec -> [(Bool, Located LHName, LocBareType)]+getAsmSigs myName name spec+  | myName == name = [ (True, x,  t) | (x, t) <- Ms.asmSigs spec ] -- MUST    resolve, or error+  | otherwise      =+      [ (False, x, t)+      | (x, t) <- Ms.asmSigs spec+                  ++ Ms.sigs spec+      ]++makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv+makeSigEnv embs tyi exports rtEnv = Bare.SigEnv+  { sigEmbs     = embs+  , sigTyRTyMap = tyi+  , sigExports  = exports+  , sigRTEnv    = rtEnv+  }++makeNewTypes :: Bare.Env -> Bare.SigEnv -> [(ModName, Ms.BareSpec)] ->+                Bare.Lookup [(Ghc.TyCon, LocSpecType)]+makeNewTypes env sigEnv specs = do+  fmap concat $+    forM nameDecls $ uncurry (makeNewType env sigEnv)+  where+    nameDecls = [(name, d) | (name, spec) <- specs, d <- Ms.newtyDecls spec]++makeNewType :: Bare.Env -> Bare.SigEnv -> ModName -> DataDecl ->+               Bare.Lookup [(Ghc.TyCon, LocSpecType)]+makeNewType env sigEnv name d = do+  tcMb <- Bare.lookupGhcDnTyCon env name tcName+  case tcMb of+    Just tc -> return [(tc, lst)]+    _       -> return []+  where+    tcName                    = tycName d+    lst                       = Bare.cookSpecType env sigEnv name Bare.GenTV bt+    bt                        = getTy tcName (tycSrcPos d) (Mb.fromMaybe [] (tycDCons d))+    getTy _ l [c]+      | [(_, t)] <- dcFields c = Loc l l t+    getTy n l _                = Ex.throw (mkErr n l)+    mkErr n l                  = ErrOther (GM.sourcePosSrcSpan l) ("Bad new type declaration:" <+> F.pprint n) :: UserError++------------------------------------------------------------------------------------------+makeSpecData :: GhcSrc -> Bare.Env -> Bare.SigEnv -> Bare.MeasEnv -> GhcSpecSig -> Bare.ModSpecs+             -> GhcSpecData+------------------------------------------------------------------------------------------+makeSpecData src env sigEnv measEnv sig specs = SpData+  { gsCtors      = F.notracepp "GS-CTORS"+                   [ (x, if allowTC then t else tt)+                       | (x, t) <- Bare.meDataCons measEnv+                       , let tt  = Bare.plugHoles (typeclass $ getConfig env) sigEnv name (Bare.LqTV x) t+                   ]+  , gsMeas       = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ]+  , gsMeasures   = ms1 ++ ms2+  , gsOpaqueRefls = fst <$> Bare.meOpaqueRefl measEnv+  , gsInvariants = Misc.nubHashOn (F.loc . snd) invs+  , gsIaliases   = concatMap (makeIAliases env sigEnv) (M.toList specs)+  , gsUnsorted   = usI ++ concatMap msUnSorted (concatMap measures specs)+  }+  where+    allowTC      = typeclass (getConfig env)+    measVars     = Bare.getMeasVars env measEnv+    measuresSp   = Bare.meMeasureSpec measEnv+    ms1          = M.elems (Ms.measMap measuresSp)+    ms2          = Ms.imeas   measuresSp+    mySpec       = M.lookupDefault mempty name specs+    name         = _giTargetMod      src+    (minvs,usI)  = makeMeasureInvariants sig mySpec+    invs         = minvs ++ concatMap (makeInvariants env sigEnv) (M.toList specs)++makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(LocSpecType, LocSpecType)]+makeIAliases env sigEnv (name, spec)+  = [ z | Right z <- mkIA <$> Ms.ialiases spec ]+  where+    -- mkIA :: (LocBareType, LocBareType) -> Either _ (LocSpecType, LocSpecType)+    mkIA (t1, t2) = (,) <$> mkI' t1 <*> mkI' t2+    mkI'          = Bare.cookSpecTypeE env sigEnv name Bare.GenTV++makeInvariants :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(Maybe Ghc.Var, Located SpecType)]+makeInvariants env sigEnv (name, spec) =+  [ (Nothing, t)+    | (_, bt) <- Ms.invariants spec+    , Bare.knownGhcType env bt+    , let t = Bare.cookSpecType env sigEnv name Bare.GenTV bt+  ] +++  concat [ (Nothing,) . makeSizeInv l <$>  ts+    | (bts, l) <- Ms.dsize spec+    , all (Bare.knownGhcType env) bts+    , let ts = Bare.cookSpecType env sigEnv name Bare.GenTV <$> bts+  ]++makeSizeInv :: F.Symbol -> Located SpecType -> Located SpecType+makeSizeInv s lst = lst{val = go (val lst)}+  where go (RApp c ts rs r) = RApp c ts rs (r `meet` nat)+        go (RAllT a t r)    = RAllT a (go t) r+        go t = t+        nat  = MkUReft (Reft (vv_, PAtom Le (ECon $ I 0) (EApp (EVar s) (eVar vv_))))+                       mempty++makeMeasureInvariants :: GhcSpecSig -> Ms.BareSpec -> ([(Maybe Ghc.Var, LocSpecType)], [UnSortedExpr])+makeMeasureInvariants sig mySpec+  = Mb.catMaybes <$>+    unzip (measureTypeToInv <$> [(x, (y, ty)) | x <- xs, (y, ty) <- sigs+                                         , x == makeGHCLHNameLocatedFromId y ])+  where+    sigs = gsTySigs sig+    xs   = S.toList (Ms.hmeas  mySpec)++measureTypeToInv :: (Located LHName, (Ghc.Var, LocSpecType)) -> ((Maybe Ghc.Var, LocSpecType), Maybe UnSortedExpr)+measureTypeToInv (x, (v, t))+  = notracepp "measureTypeToInv" ((Just v, t {val = mtype}), usorted)+  where+    trep = toRTypeRep (val t)+    rts  = ty_args  trep+    args = ty_binds trep+    res  = ty_res   trep+    z    = last args+    tz   = last rts+    usorted =+      if isSimpleADT tz then+        Nothing+      else+        first (:[]) <$> mkReft (dummyLoc $ val $ makeGHCLHNameLocatedFromId v) z tz res+    mtype+      | null rts+      = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x) "Measure has no arguments!"+      | otherwise+      = mkInvariant x z tz res+    isSimpleADT (RApp _ ts _ _) = all isRVar ts+    isSimpleADT _               = False++mkInvariant :: Located LHName -> Symbol -> SpecType -> SpecType -> SpecType+mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft' mempty)+      where+        reft' = Mb.maybe mempty Reft mreft+        mreft = mkReft x z t tr+++mkReft :: Located LHName -> Symbol -> SpecType -> SpecType -> Maybe (Symbol, Expr)+mkReft x z _t tr+  | Just q <- stripRTypeBase tr+  = let Reft (v, p) = toReft q+        su          = mkSubst [(v, mkEApp (fmap lhNameToResolvedSymbol x) [EVar v]), (z,EVar v)]+        -- p'          = pAnd $ filter (\e -> z `notElem` syms e) $ conjuncts p+    in  Just (v, subst su p)+mkReft _ _ _ _+  = Nothing+++-- REBARE: formerly, makeGhcSpec3+-------------------------------------------------------------------------------------------+makeSpecName :: Bare.TycEnv -> Bare.MeasEnv -> [Ghc.Id] -> GhcSpecNames+-------------------------------------------------------------------------------------------+makeSpecName tycEnv measEnv dataConIds = SpNames+  { gsDconsP   = [ F.atLoc dc (dcpCon dc) | dc <- datacons ++ cls ]+  , gsTconsP   = tycons+  -- , gsLits = mempty                                              -- TODO-REBARE, redundant with gsMeas+  , gsTcEmbeds = Bare.tcEmbs     tycEnv+  , gsADTs     = Bare.tcAdts     tycEnv+  , gsTyconEnv = Bare.tcTyConMap tycEnv+  , gsDataConIds = dataConIds+  }+  where+    datacons, cls :: [DataConP]+    datacons   = Bare.tcDataCons tycEnv+    cls        = F.notracepp "meClasses" $ Bare.meClasses measEnv+    tycons     = Bare.tcTyCons   tycEnv+++-- REBARE: formerly, makeGhcCHOP1+-- split into two to break circular dependency. we need dataconmap for core2logic+-------------------------------------------------------------------------------------------+makeTycEnv0 :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs+           -> (Diagnostics,  [Located DataConP], Bare.TycEnv)+-------------------------------------------------------------------------------------------+makeTycEnv0 cfg myName env embs mySpec iSpecs = (diag0 <> diag1, datacons, Bare.TycEnv+  { tcTyCons      = tycons+  , tcDataCons    = mempty -- val <$> datacons+    -- See the documentation of @addOpaqueReflMeas@. The selectors here are only+    -- those belonging to types mentioned in the types of functions defined in+    -- the current module.+  , tcSelMeasures = dcSelectors+  , tcSelVars     = mempty -- recSelectors+  , tcTyConMap    = tyi+  , tcAdts        = adts+  , tcDataConMap  = dm+  , tcEmbs        = embs+  , tcName        = myName+  })+  where+    (tcDds, dcs)   = conTys+    (diag0, conTys) = withDiagnostics $ Bare.makeConTypes myName env specs+    specs         = (myName, mySpec) : M.toList iSpecs+    tcs           = Misc.snd3 <$> tcDds+    tyi           = makeTyConInfo embs fiTcs tycons+    -- tycons        = F.tracepp "TYCONS" $ Misc.replaceWith tcpCon tcs wiredTyCons+    -- datacons      =  Bare.makePluggedDataCons embs tyi (Misc.replaceWith (dcpCon . val) (F.tracepp "DATACONS" $ concat dcs) wiredDataCons)+    tycons        = tcs ++ wiredTyCons+    datacons      = Bare.makePluggedDataCon (typeclass cfg) embs tyi <$> (concat dcs ++ wiredDataCons)+    tds           = [(name, tcpCon tcp, dd) | (name, tcp, Just dd) <- tcDds]+    (diag1, adts) = Bare.makeDataDecls cfg embs myName tds       datacons+    dm            = Bare.dataConMap adts+    dcSelectors   = concatMap (Bare.makeMeasureSelectors cfg dm) (if reflection cfg then charDataCon:datacons else datacons)+    fiTcs         = _gsFiTcs (Bare.reSrc env)++++makeTycEnv1 ::+     Bare.Env+  -> (Bare.TycEnv, [Located DataConP])+  -> (Ghc.CoreExpr -> F.Expr)+  -> (Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr)+  -> Ghc.TcRn Bare.TycEnv+makeTycEnv1 env (tycEnv, datacons) coreToLg simplifier = do+  -- fst for selector generation, snd for dataconsig generation+  lclassdcs <- forM classdcs $ traverse (Bare.elaborateClassDcp coreToLg simplifier)+  let recSelectors = Bare.makeRecordSelectorSigs env (dcs ++ (fmap . fmap) snd lclassdcs)+  pure $+    tycEnv {Bare.tcSelVars = recSelectors, Bare.tcDataCons = F.val <$> ((fmap . fmap) fst lclassdcs ++ dcs )}+  where+    (classdcs, dcs) =+      L.partition+        (Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon . F.val) datacons++-- REBARE: formerly, makeGhcCHOP2+-------------------------------------------------------------------------------------------+makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs ->+               Bare.Lookup Bare.MeasEnv+-------------------------------------------------------------------------------------------+makeMeasEnv env tycEnv sigEnv specs = do+  (cls, mts)  <- Bare.makeClasses        env sigEnv name specs+  let dms      = Bare.makeDefaultMethods env mts+  measures0   <- mapM (Bare.makeMeasureSpec env sigEnv name) (M.toList specs)+  let measures = mconcat (Ms.mkMSpec' dcSelectors : measures0)+  let (cs, ms) = Bare.makeMeasureSpec'  (typeclass $ getConfig env)   measures+  let cms      = Bare.makeClassMeasureSpec measures+  let cms'     = [ (val l, cSort t <$ l)  | (l, t) <- cms ]+  let ms'      = [ (lhNameToResolvedSymbol (F.val lx), F.atLoc lx t)+                 | (lx, t) <- ms+                 , Mb.isNothing (lookup (val lx) cms')+                 ]+  let cs'      = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec (typeclass (getConfig env)) embs cs (datacons ++ cls)]+  return Bare.MeasEnv+    { meMeasureSpec = measures+    , meClassSyms   = map (first lhNameToResolvedSymbol) cms'+    , meSyms        = ms'+    , meDataCons    = cs'+    , meClasses     = cls+    , meMethods     = mts ++ dms+    , meOpaqueRefl  = mempty+    }+  where+    txRefs v t    = Bare.txRefSort tyi embs (t <$ GM.locNamedThing v)+    tyi           = Bare.tcTyConMap    tycEnv+    dcSelectors   = Bare.tcSelMeasures tycEnv+    datacons      = Bare.tcDataCons    tycEnv+    embs          = Bare.tcEmbs        tycEnv+    name          = Bare.tcName        tycEnv+++-- | Adds the opaque reflections to the measure environment+--+-- Returns a new environment that is the old one enhanced with the opaque+-- reflections.+--+-- At the moment this function also has the effect of adding selector and+-- checker measures for data constructors that are needed by reflected+-- functions. This even adds measures that are needed by functions reflected+-- from unfoldings (public and private), whose datatypes come from imported+-- modules. This overlaps a bit with 'makeTycEnv0', which also adds measures for+-- selectors and checkers, but only for datatypes mentioned in the type+-- signatures of functions defined in the current module.+-------------------------------------------------------------------------------------------+addOpaqueReflMeas :: Config -> Bare.TycEnv -> Bare.Env -> Ms.BareSpec -> Bare.MeasEnv -> Bare.ModSpecs ->+               [(Ghc.Var, LocSpecType, F.Equation)] ->+               Bare.Lookup Bare.MeasEnv+----------------------- --------------------------------------------------------------------+addOpaqueReflMeas cfg tycEnv env spec measEnv specs eqs = do+  dcs   <- snd <$> Bare.makeConTypes'' env name spec dataDecls []+  let datacons      = Bare.makePluggedDataCon (typeclass cfg) embs tyi <$> concat dcs+  let dcSelectors   = concatMap (Bare.makeMeasureSelectors cfg dm) datacons+  -- Rest of the code is the same idea as for makeMeasEnv, only we just care on how to get+  -- `meSyms` (no class, data constructor or other stuff here).+  let measures = mconcat (Ms.mkMSpec' dcSelectors : measures0)+  let (cs, ms) = Bare.makeMeasureSpec'  (typeclass $ getConfig env)   measures+  let ms'      = [ (lhNameToResolvedSymbol (F.val lx), F.atLoc lx t) | (lx, t) <- ms ]+  let cs'      = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec (typeclass (getConfig env)) embs cs (val <$> datacons)]+  return $ measEnv <> mempty+    { Bare.meMeasureSpec = measures+    , Bare.meSyms        = ms'+    , Bare.meDataCons    = cs'+    , Bare.meOpaqueRefl  = opaqueRefl+    }+  where+    -- We compute things in the same way as in makeMeasEnv+    txRefs v t    = Bare.txRefSort tyi embs (t <$ GM.locNamedThing v)+    (measures0, opaqueRefl) = Bare.makeOpaqueReflMeasures env measEnv specs eqs+    -- Note: it is important to do toList after applying `dataConTyCon` because+    -- obviously several data constructors can refer to the same `TyCon` so we+    -- could have duplicates+    -- We skip the variables from the axiom equations that correspond to the actual functions+    -- of opaque reflections, since we never need to look at the unfoldings of those+    actualFns = S.fromList $ val . fst <$> Ms.asmReflectSigs spec+    shouldBeUsedForScanning sym = not (sym `S.member` actualFns)+    varsUsedForTcScanning =+      [ v+      | (v, _, _) <- eqs+      , shouldBeUsedForScanning $ makeGHCLHName (Ghc.getName v) (symbol v)+      ]+    tcs           = S.toList $ Ghc.dataConTyCon `S.map` Bare.getReflDCs measEnv varsUsedForTcScanning+    dataDecls     = Bare.makeHaskellDataDecls cfg spec tcs+    tyi           = Bare.tcTyConMap    tycEnv+    embs          = Bare.tcEmbs        tycEnv+    dm            = Bare.tcDataConMap  tycEnv+    name          = Bare.tcName        tycEnv++-----------------------------------------------------------------------------------------+-- | @makeLiftedSpec@ is used to generate the BareSpec object that should be serialized+--   so that downstream files that import this target can access the lifted definitions,+--   e.g. for measures, reflected functions etc.+-----------------------------------------------------------------------------------------+makeLiftedSpec :: ModName -> GhcSrc -> Bare.Env+               -> GhcSpecRefl -> GhcSpecData -> GhcSpecSig -> GhcSpecQual -> BareRTEnv+               -> Ms.BareSpec -> Ms.BareSpec+-----------------------------------------------------------------------------------------+makeLiftedSpec name src env refl sData sig qual myRTE lSpec0 = lSpec0+  { Ms.asmSigs    = F.notracepp   ("makeLiftedSpec : ASSUMED-SIGS " ++ F.showpp name ) (xbs ++ myDCs)+  , Ms.sigs       = F.notracepp   ("makeLiftedSpec : LIFTED-SIGS " ++ F.showpp name ) $+                      mkSigs (gsTySigs sig)+  , Ms.invariants = [ (Bare.varLocSym <$> x, Bare.specToBare <$> t)+                       | (x, t) <- gsInvariants sData+                       , isLocInFile srcF t+                    ]+  , Ms.axeqs      = gsMyAxioms refl+  , Ms.aliases    = F.notracepp "MY-ALIASES" $ M.elems . typeAliases $ myRTE+  , Ms.ealiases   = M.elems . exprAliases $ myRTE+  , Ms.qualifiers = filter (isLocInFile srcF) (gsQualifiers qual)+  }+  where+    myDCs         = filter (isLocalName . val . fst) $ mkSigs (gsCtors sData)+    mkSigs xts    = [ toBare (x, t) | (x, t) <- xts+                    , not (S.member x reflVars) && isExportedVar (toTargetSrc src) x+                    ]+    toBare (x, t) = (makeGHCLHNameLocatedFromId x, Bare.specToBare <$> t)+    xbs           = toBare <$> reflTySigs+    reflTySigs    = [(x, t) | (x,t,_) <- gsHAxioms refl]+    reflVars      = S.fromList (fst <$> reflTySigs)+    -- myAliases fld = M.elems . fld $ myRTE+    srcF          = _giTarget src++    isLocalName = \case+      LHNResolved (LHRGHC n) _ ->+        Just (Ghc.tcg_mod (Bare.reTcGblEnv env)) == Ghc.nameModule_maybe n+      _ ->+        False++-- | Returns 'True' if the input determines a location within the input file. Due to the fact we might have+-- Haskell sources which have \"companion\" specs defined alongside them, we also need to account for this+-- case, by stripping out the extensions and check that the LHS is a Haskell source and the RHS a spec file.+isLocInFile :: (F.Loc a) => FilePath -> a ->  Bool+isLocInFile f lx = f == lifted || isCompanion+  where+    lifted :: FilePath+    lifted = locFile lx++    isCompanion :: Bool+    isCompanion =+      (==) (dropExtension f) (dropExtension lifted)+       &&  isExtFile Hs f+       &&  isExtFile Files.Spec lifted++locFile :: (F.Loc a) => a -> FilePath+locFile = Misc.fst3 . F.sourcePosElts . F.sp_start . F.srcSpan  -- makeSpecRTAliases :: Bare.Env -> BareRTEnv -> [Located SpecRTAlias] -- makeSpecRTAliases _env _rtEnv = [] -- TODO-REBARE
src/Language/Haskell/Liquid/Bare/Axiom.hs view
@@ -8,7 +8,7 @@ -- | This module contains the code that DOES reflection; i.e. converts Haskell --   definitions into refinements. -module Language.Haskell.Liquid.Bare.Axiom ( makeHaskellAxioms, makeAssumeReflectAxioms, wiredReflects ) where+module Language.Haskell.Liquid.Bare.Axiom ( makeHaskellAxioms, strengthenSpecWithMeasure, makeAssumeReflectAxioms, AxiomType(..) ) where  import Prelude hiding (error) import Prelude hiding (mapM)@@ -21,7 +21,6 @@ import qualified Data.Maybe                as Mb import Control.Monad.Trans.State.Lazy (runState, get, put) -import           Language.Fixpoint.Misc import qualified Language.Haskell.Liquid.Measure as Ms import qualified Language.Fixpoint.Types as F import qualified Liquid.GHC.API as Ghc@@ -29,15 +28,23 @@ import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Transforms.CoreToLogic import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types  import           Language.Haskell.Liquid.Bare.Resolve as Bare import           Language.Haskell.Liquid.Bare.Types   as Bare+import           Language.Haskell.Liquid.Bare.Measure as Bare+import           Language.Haskell.Liquid.UX.Config import qualified Data.List as L-import Language.Haskell.Liquid.Misc (fst4) import Control.Applicative+import Control.Arrow (second) import Data.Function (on) import qualified Data.Map as Map+import qualified Data.HashMap.Strict as M  findDuplicatePair :: Ord k => (a -> k) -> [a] -> Maybe (a, a) findDuplicatePair key xs =@@ -56,13 +63,12 @@       [ (x, y) | x <- l2', Just y <- [Map.lookup (key' x) seen]]  ------------------------------------------------------------------------------------------------makeHaskellAxioms :: Config -> GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec+makeHaskellAxioms :: GhcSrc -> Bare.Env -> Bare.TycEnv -> LogicMap -> GhcSpecSig -> Ms.BareSpec                   -> Bare.Lookup [(Ghc.Var, LocSpecType, F.Equation)] ------------------------------------------------------------------------------------------------makeHaskellAxioms cfg src env tycEnv name lmap spSig spec = do-  wiDefs     <- wiredDefs cfg env name spSig-  let refDefs = getReflectDefs src spSig spec-  return (makeAxiom env tycEnv name lmap <$> (wiDefs ++ refDefs))+makeHaskellAxioms src env tycEnv lmap spSig spec = do+  let refDefs = getReflectDefs src spSig spec env+  return (makeAxiom env tycEnv lmap <$> refDefs)  ----------------------------------------------------------------------------------------------- --          Returns a list of elements, one per assume reflect                               --@@ -72,63 +78,86 @@ --   ``VV == pretendedFn arg1 arg2 ...`                                                      -- -- * The assume reflect equation, linking the pretended and actual function:                 -- --   `actualFn arg1 arg 2 ... = pretendedFn arg1 arg2 ...`                                   ---makeAssumeReflectAxioms :: GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> GhcSpecSig -> Ms.BareSpec+makeAssumeReflectAxioms :: GhcSrc -> Bare.Env -> Bare.TycEnv -> GhcSpecSig -> Ms.BareSpec                   -> Bare.Lookup [(Ghc.Var, LocSpecType, F.Equation)] ------------------------------------------------------------------------------------------------makeAssumeReflectAxioms src env tycEnv name spSig spec = do+makeAssumeReflectAxioms src env tycEnv spSig spec = do   -- Send an error message if we're redefining a reflection   case findDuplicatePair val reflActSymbols <|> findDuplicateBetweenLists val refSymbols reflActSymbols of-    Just (x , y) -> Ex.throw $ mkError y $ "Duplicate reflection of " ++ show x ++ " and " ++ show y-    Nothing -> return $ makeAssumeReflectAxiom spSig env embs name <$> Ms.asmReflectSigs spec+    Just (x , y) -> Ex.throw $ mkError y $+                      "Duplicate reflection of " +++                      show (lhNameToUnqualifiedSymbol <$> x) +++                      " and " +++                      show (lhNameToUnqualifiedSymbol <$> y)+    Nothing -> return $ turnIntoAxiom <$> Ms.asmReflectSigs spec   where-    refDefs                 = getReflectDefs src spSig spec+    turnIntoAxiom (actual, pretended) = makeAssumeReflectAxiom spSig env embs (actual, pretended)+    refDefs                 = getReflectDefs src spSig spec env     embs                    = Bare.tcEmbs       tycEnv-    refSymbols              = fst4 <$> refDefs+    refSymbols              =+      (\(x, _, v, _) -> F.atLoc x $ makeGHCLHName (Ghc.getName v) (F.symbol v)) <$> refDefs     reflActSymbols          = fst <$> Ms.asmReflectSigs spec  ----------------------------------------------------------------------------------------------- -- Processes one `assume reflect` and returns its axiom element, as detailed in              ----- `makeAssumeReflectAxioms`                                                                 ---makeAssumeReflectAxiom :: GhcSpecSig -> Bare.Env -> F.TCEmb Ghc.TyCon -> ModName-                       -> (LocSymbol, LocSymbol) -- actual function and pretended function+-- `makeAssumeReflectAxioms`. Can also be used to compute the updated SpecType of            --+-- a type where we add the post-condition that actual and pretended are the same             --+makeAssumeReflectAxiom :: GhcSpecSig -> Bare.Env -> F.TCEmb Ghc.TyCon+                       -> (Located LHName, Located LHName) -- actual function and pretended function                        -> (Ghc.Var, LocSpecType, F.Equation) ------------------------------------------------------------------------------------------------makeAssumeReflectAxiom sig env tce name (actual, pretended) =-  -- The actual and pretended function must have the same type+makeAssumeReflectAxiom sig env tce (actual, pretended) =+   -- The actual and pretended function must have the same type   if pretendedTy == actualTy then-    (actualV, actual {val = aty_at `strengthenRes` F.subst su ref} , actualEq)+    (actualV, actual{val = aty at}, actualEq)   else     Ex.throw $ mkError actual $       show qPretended ++ " and " ++ show qActual ++ " should have the same type. But " ++       "types " ++ F.showpp pretendedTy ++ " and " ++ F.showpp actualTy  ++ " do not match."   where+    at = val $ strengthenSpecWithMeasure sig env actualV pretended{val=qPretended}+     -- Get the Ghc.Var's of the actual and pretended function names-    actualV = case Bare.lookupGhcVar env name "wiredAxioms" actual of+    actualV = case Bare.lookupGhcIdLHName env actual of       Right x -> x-      Left _ -> Ex.throw $ mkError actual $ "Not in scope: " ++ show (val actual)-    pretendedV = case Bare.lookupGhcVar env name "wiredAxioms" pretended of+      Left _ -> panic (Just $ GM.fSrcSpan actual) "function to reflect not in scope"+    pretendedV = case Bare.lookupGhcIdLHName env pretended of       Right x -> x-      Left _ -> Ex.throw $ mkError pretended $ "Not in scope: " ++ show (val pretended)+      Left _ -> panic (Just $ GM.fSrcSpan pretended) "function to reflect not in scope"     -- Get the qualified name symbols for the actual and pretended functions-    qActual = Bare.qualifyTop env name (F.loc actual) (val actual)-    qPretended = Bare.qualifyTop env name (F.loc pretended) (val pretended)+    lhNameToSymbol lx =+      F.symbol $+      Mb.fromMaybe (panic (Just $ GM.fSrcSpan lx) $ "expected a resolved Haskell name: " ++ show lx) $+      getLHGHCName $+      val lx+    qActual = lhNameToSymbol actual+    qPretended = lhNameToSymbol pretended     -- Get the GHC type of the actual and pretended functions     actualTy = Ghc.varType actualV     pretendedTy = Ghc.varType pretendedV-    -- Compute argument names for the actual/pretended functions-    -- The argument names are lq1, lq2, etc.-    -- These argument names will be used in the equation-    args = getArgs 1 actualTy-    -- Function types can be of multiple sorts. We are only interested in the Type -> Type (i.e., ->) ones,-    -- which correspond to flag Ghc.FTF_T_T. For (=>) Constraint -> Type (flag FTF_C_T), we just ignore the-    -- (constraint) argument. For the others kinds, we throw are error, as they are unsupported.-    getArgs :: Int -> Ghc.Type -> [(F.Symbol, F.Sort)]-    getArgs n Ghc.FunTy{ft_arg=ty0, ft_res=ty1, ft_af=Ghc.FTF_T_T} = (F.symbol . ("lq" ++) . show $ n, typeSort tce ty0) : getArgs (n+1) ty1-    getArgs n Ghc.FunTy{ft_res=ty1, ft_af=Ghc.FTF_C_T} = getArgs n ty1-    getArgs _ Ghc.FunTy{} = Ex.throw $ mkError actual "This function cannot be `assume reflect`'ed. Its signature is too complex for me."-    getArgs n (Ghc.ForAllTy _ ty) = getArgs n ty-    getArgs _ _ = [] +    -- The return type of the function+    out   = rTypeSort tce $ ares at+    -- The arguments names and types, as given by `AxiomType`+    xArgs = fmap (rTypeSort tce) <$> aargs at++    -- Expression of the equation. It is just saying that the actual and pretended functions are the same+    -- when applied to the same arguments+    le    = foldl F.EApp (F.EVar qPretended) (F.EVar . fst <$> xArgs)++    actualEq = F.mkEquation qActual xArgs le out++strengthenSpecWithMeasure :: GhcSpecSig -> Bare.Env+                       -> Ghc.Var -- var owning the spec+                       -> LocSymbol     -- measure name+                       -> Located AxiomType+-----------------------------------------------------------------------------------------------+strengthenSpecWithMeasure sig env actualV qPretended =+    qPretended{ val = addSingletonApp allowTC (val qPretended) rt}+  where+    -- Get the GHC type of the actual and pretended functions+    actualTy = Ghc.varType actualV+     -- Compute the refined type of the actual function. See `makeAssumeType` for details     sigs                    = gsTySigs sig ++ gsAsmSigs sig -- We also look into assumed signatures     -- Try to get the specification of the actual function from the signatures@@ -139,82 +168,214 @@             (\trep@RTypeRep{..} ->                 trep{ty_info = fmap (\i -> i{permitTC = Just allowTC}) ty_info}) .             toRTypeRep $ Mb.fromMaybe (ofType actualTy) mbT-    -- Decompose the function type into arguments and return types-    at    = axiomType allowTC actual rt-    aty_at = aty at-    -- The return type of the function-    out   = rTypeSort tce $ ares at-    -- The arguments names and types, as given by `AxiomType`-    xArgs = F.EVar . fst <$> aargs at     allowTC = typeclass (getConfig env)-    -- Expression of the equation. It is just saying that the actual and pretended functions are the same-    -- when applied to the same arguments-    le    = foldl F.EApp (F.EVar qPretended) (F.EVar . fst <$> args)-    ref   = F.Reft (F.vv_, F.PAtom F.Eq (F.EVar F.vv_) le)-    -- Substitute our argument names with the actual arguments given from `xArgs`-    -- in the final, refined type-    su         = F.mkSubst $ zip (fst <$> args) xArgs -    actualEq = F.mkEquation qActual args le out--getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec+-- Gets the definitions of all the symbols that `BareSpec` wants to reflect.+--+-- Because we allow to name private variables here, not all symbols can easily+-- be turned into `Ghc.Var`. Essentially, `findVarDefType` can initially only+-- fetch the definitions of public variables. We use a fixpoint so that for each+-- newly retrieved definition, we get the list of variables used inside it and+-- record them in a HashMap so that in the next round, we might be able to get+-- more definitions (because once you have a variable, it's easy to get its+-- unfolding).+--+-- Iterates until no new definition is found. In which case, we fail+-- if there are still symbols left which we failed to find the source for.+getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec -> Bare.Env                -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]-getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs+getReflectDefs src sig spec env =+  searchInTransitiveClosure symsToResolve initialDefinedMap []   where     sigs                    = gsTySigs sig-    xs                      = S.toList (Ms.reflects spec)-    cbs                     = _giCbs src+    symsToResolve =+      map Left (S.toList (Ms.reflects spec)) +++      map Right (S.toList (Ms.privateReflects spec))+    cbs = Ghc.flattenBinds $ _giCbs src+    initialDefinedMap          = M.empty -findVarDefType :: [Ghc.CoreBind] -> [(Ghc.Var, LocSpecType)] -> LocSymbol-               -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)-findVarDefType cbs sigs x = case findVarDefMethod (val x) cbs of+    -- First argument of the `searchInTransitiveClosure` function should always+    -- decrease.+    -- The second argument contains the Vars that appear free in the definitions+    -- of the symbols in the third argument.+    -- The third argument contains the symbols that have been resolved.+    --+    -- The set of symbols in the union of the first and third argument should+    -- remain constant in every recursive call. Moreover, both arguments are+    -- disjoint.+    --+    -- Base case: No symbols left to resolve - we're good+    searchInTransitiveClosure [] _ acc = acc+    -- Recursive case: there are some left.+    searchInTransitiveClosure toResolve fvMap acc = if null found+         then case newToResolve of+                -- No one newly found but no one left to process - we're good+                [] -> acc+                -- No one newly found but at least one symbol left - we throw+                -- an error+                x:_ -> Ex.throw . either mkError mkError x $+                  "Not found in scope nor in the amongst these variables: " +++                    foldr (\x1 acc1 -> acc1 ++ " , " ++ show x1) "" newFvMap+         else searchInTransitiveClosure newToResolve newFvMap newAcc+      where+        -- Try to get the definitions of the symbols that are left (`toResolve`)+        resolvedSyms = findVarDefType cbs sigs env fvMap <$> toResolve+        -- Collect the newly found definitions+        found     = Mb.catMaybes resolvedSyms+        -- Add them to the accumulator+        newAcc    = acc ++ found+        -- Add any variable occurrence in them to `fvMap`+        newFvMap = foldl addFreeVarsToMap fvMap found+        -- Collect all the symbols that still failed to be resolved in this+        -- iteration+        newToResolve = [x | (x, Nothing) <- zip toResolve resolvedSyms]++    -- Collects the free variables in an expression and inserts them to the+    -- provided map between symbols and variables. Especially useful to collect+    -- private variables, since it's the only way to reach them (seeing them in+    -- other unfoldings)+    addFreeVarsToMap fvMap (_, _, _, expr) =+      let freeVarsSet = getAllFreeVars expr+          newVars =+            M.fromList [(Bare.varLocSym var, var) | var <- freeVarsSet]+      in M.union fvMap newVars++    getAllFreeVars = Ghc.exprSomeFreeVarsList (const True)++-- | Names for functions that need to be reflected+--+-- > Left nameInScope | Right qualifiedPrivateName+type ToReflectName = Either (Located LHName) LocSymbol++-- Finds the definition of a variable in the given Core binds, or in the+-- unfoldings of a Var. Used for reflection. Returns the same+-- `LHName` given as argument, the SpecType of this symbol, its corresponding+-- variable and definition (the `CoreExpr`).+--+-- Takes as arguments:+-- - The list of bindings, usually taken from the GhcSrc+-- - A map of signatures, used to retrieve the `SpecType`+-- - The current environment, that can be used to resolve symbols+-- - An extra map between symbols and variables for those symbols that are hard+--   to resolve, especially if they are private symbols from foreign+--   dependencies. This map will be used as a fallback if the default resolving+--   mechanism fails.+--+-- Returns `Nothing` iff the symbol could not be resolved. No error is thrown in+-- this case since this function is used by the fixpoint mechanism of+-- `getReflectDefs`. Which will collect all the symbols that could (not) yet be+-- resolved.+--+-- Errors can be raised whenever the symbol was found but the rest of the+-- process failed (no unfoldings available, lifted functions not exported,+-- etc.).+findVarDefType :: [(Ghc.Id, Ghc.CoreExpr)] -> [(Ghc.Var, LocSpecType)] -> Bare.Env+               -> M.HashMap LocSymbol Ghc.Var -> ToReflectName+               -> Maybe (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)+findVarDefType cbs sigs env _defs (Left x) =+  case L.find ((val x ==) . makeGHCLHNameFromId . fst) cbs of   -- YL: probably ok even without checking typeclass flag since user cannot   -- manually reflect internal names-  Just (v, e) -> if GM.isExternalId v || isMethod (F.symbol x) || isDictionary (F.symbol x)-                   then (x, val <$> lookup v sigs, v, e)-                   else Ex.throw $ mkError x ("Lifted functions must be exported; please export " ++ show v)-  Nothing     -> Ex.throw $ mkError x $ show (val x) ++ " is not in scope"+  Just (v, e) ->+    Just (fmap getLHNameSymbol x, val <$> lookup v sigs, v, e)+  Nothing     -> do+    let ecall = panic (Just $ GM.fSrcSpan x) "function to reflect not found"+        var = either ecall id (Bare.lookupGhcIdLHName env x)+        info = Ghc.idInfo var+        unfolding = getExprFromUnfolding . Ghc.realUnfoldingInfo $ info+    case unfolding of+      Just e ->+        Just (fmap getLHNameSymbol x, val <$> lookup var sigs, var, e)+      _ ->+        Ex.throw $ mkError x $ unwords+          [ "Symbol exists but is not defined in the current file,"+          , "and no unfolding is available in the interface files"+          ] +findVarDefType _cbs sigs _env defs (Right x) = do+    var <- M.lookup x defs+    let info = Ghc.idInfo var+    let unfolding = getExprFromUnfolding . Ghc.realUnfoldingInfo $ info+    case unfolding of+      Just e ->+        Just (x, val <$> lookup var sigs, var, e)+      _ ->+        Ex.throw $ mkError x $ unwords+          [ "Symbol exists but is not defined in the current file,"+          , "and no unfolding is available in the interface files"+          ]++getExprFromUnfolding :: Ghc.Unfolding -> Maybe Ghc.CoreExpr+getExprFromUnfolding (Ghc.CoreUnfolding expr _ _ _ _) = Just expr+getExprFromUnfolding _ = Nothing+ ---------------------------------------------------------------------------------makeAxiom :: Bare.Env -> Bare.TycEnv -> ModName -> LogicMap+makeAxiom :: Bare.Env -> Bare.TycEnv -> LogicMap           -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)           -> (Ghc.Var, LocSpecType, F.Equation) ---------------------------------------------------------------------------------makeAxiom env tycEnv name lmap (x, mbT, v, def)+makeAxiom env tycEnv lmap (x, mbT, v, def)             = (v, t, e)   where-    t       = Bare.qualifyTop env name (F.loc t0) t0-    (t0, e) = makeAssumeType allowTC embs lmap dm x mbT v def+    (t, e)  = makeAssumeType (getConfig env) embs lmap dm x mbT v def     embs    = Bare.tcEmbs       tycEnv     dm      = Bare.tcDataConMap tycEnv-    allowTC = typeclass (getConfig env) -mkError :: LocSymbol -> String -> Error+mkError :: PPrint a => Located a -> String -> Error mkError x str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text str) +-- This function is uded to generate the fixpoint code for reflected functions makeAssumeType-  :: Bool -- ^ typeclass enabled+  :: Config   -> F.TCEmb Ghc.TyCon -> LogicMap -> DataConMap -> LocSymbol -> Maybe SpecType   -> Ghc.Var -> Ghc.CoreExpr   -> (LocSpecType, F.Equation)-makeAssumeType allowTC tce lmap dm sym mbT v def-  = (sym {val = aty at `strengthenRes` F.subst su ref},  F.mkEquation (val sym) xts (F.subst su le) out)+makeAssumeType cfg tce lmap dm sym mbT v def+  = ( sym {val = aty at `strengthenRes` F.subst su ref}+    , F.mkEquation +        symbolV +        (fmap (second $ F.sortSubst sortSub) xts)+        (F.sortSubstInExpr sortSub (F.subst su le))+        (F.sortSubst sortSub out)+    )   where+    allowTC = typeclass cfg+    symbolV = F.symbol v     rt    = fromRTypeRep .             (\trep@RTypeRep{..} ->                 trep{ty_info = fmap (\i -> i{permitTC = Just allowTC}) ty_info}) .             toRTypeRep $ Mb.fromMaybe (ofType τ) mbT     τ     = Ghc.varType v-    at    = axiomType allowTC sym rt+    at    = addSingletonApp allowTC symbolV rt     out   = rTypeSort tce $ ares at     xArgs = F.EVar . fst <$> aargs at     _msg  = unwords [showpp sym, showpp mbT]-    le    = case runToLogicWithBoolBinds bbs tce lmap dm mkErr (coreToLogic allowTC def') of+    le    = case runToLogicWithBoolBinds bbs tce lmap dm cfg mkErr (coreToLogic def') of               Right e -> e-              Left  e -> panic Nothing (show e)+              Left  e -> Ex.throw e     ref        = F.Reft (F.vv_, F.PAtom F.Eq (F.EVar F.vv_) le)     mkErr s    = ErrHMeas (sourcePosSrcSpan $ loc sym) (pprint $ val sym) (PJ.text s)     bbs        = filter isBoolBind xs++    -- rTypeSortExp produces monomorphic sorts from polymorphic types.+    -- As an example, for +    -- id :: a -> a ... id x = x +    -- we got: +    -- define id (x : a#foobar) : a#foobar = { (x : a#foobar) }+    -- Using FObj instead of a real type variable (FVar i) This code solves the+    -- issue by creating a sort substitution that replaces those "fake" type variables+    -- with actual ones.+    -- define id (x : @-1) : a@-1 = { (x : a@-1) }+    (tyVars, _) = Ghc.splitForAllTyCoVars τ+    sortSub     = F.mkSortSubst $ zip (fmap F.symbol tyVars) (F.FVar <$> freeSort)+    -- We need sorts that aren't polluted by rank-n types, we can't just look at+    -- the term to determine statically what is the "maximum" sort bound ex:+    -- freeSort = [1 + (maximum $ -1 : F.sortAbs out : fmap (F.sortAbs . snd) xts) ..] +    -- as some variable may be bound to something of rank-n type.  In+    -- SortCheck.hs in fixpoint they just start at 42 for some reason.  I think+    -- Negative Debruijn indices (levels :^)) are safer+    freeSort    = [-1, -2 ..]+     (xs, def') = GM.notracePpr "grabBody" $ grabBody allowTC (Ghc.expandTypeSynonyms τ) $ normalize allowTC def     su         = F.mkSubst  $ zip (F.symbol     <$> xs) xArgs                            ++ zip (simplesymbol <$> xs) xArgs@@ -260,7 +421,7 @@     go (RAllT a t r)   = RAllT a (go t) r     go (RAllP p t)     = RAllP p $ go t     go (RFun x i tx t r) = RFun x i tx (go t) r-    go t               =  t `strengthen` F.ofReft rf+    go t               =  t `strengthen` ofReft rf  class Subable a where   subst :: (Ghc.Var, Ghc.CoreExpr) -> a -> a@@ -281,7 +442,7 @@   subst su (Ghc.Case e x t alts)     = Ghc.Case (subst su e) x t (subst su <$> alts)   subst su (Ghc.Let (Ghc.Rec xes) e)-    = Ghc.Let (Ghc.Rec (mapSnd (subst su) <$> xes)) (subst su e)+    = Ghc.Let (Ghc.Rec (fmap (subst su) <$> xes)) (subst su e)   subst su (Ghc.Let (Ghc.NonRec x ex) e)     = Ghc.Let (Ghc.NonRec x (subst su ex)) (subst su e)   subst su (Ghc.Cast e t)@@ -295,10 +456,15 @@   subst su (Ghc.Alt c xs e) = Ghc.Alt c xs (subst su e)  data AxiomType = AT { aty :: SpecType, aargs :: [(F.Symbol, SpecType)], ares :: SpecType }+  deriving Show  -- | Specification for Haskell function-axiomType :: Bool -> LocSymbol -> SpecType -> AxiomType-axiomType allowTC s st = AT to (reverse xts) res+--+-- @addSingletonApp allowTC f (x:_ -> y: -> {v:_ | p}@ produces a type+-- @x:_ -> y:_ -> {v:_ | p && v = f x y}@+--+addSingletonApp :: Bool -> F.Symbol -> SpecType -> AxiomType+addSingletonApp allowTC s st = AT to (reverse xts) res   where     (to, (_,xts, Just res)) = runState (go st) (1,[], Nothing)     go (RAllT a t r) = RAllT a <$> go t <*> return r@@ -322,60 +488,7 @@   | x /= F.dummySymbol = x   | otherwise          = F.symbol ("lq" ++ show i) -singletonApp :: F.Symbolic a => LocSymbol -> [a] -> UReft F.Reft+singletonApp :: F.Symbolic a => F.Symbol -> [a] -> UReft F.Reft singletonApp s ys = MkUReft r mempty   where-    r             = F.exprReft (F.mkEApp s (F.eVar <$> ys))------------------------------------------------------------------------------------- | Hardcode imported reflected functions ----------------------------------------------------------------------------------------------------------------------wiredReflects :: Config -> Bare.Env -> ModName -> GhcSpecSig ->-                 Bare.Lookup [Ghc.Var]-wiredReflects cfg env name sigs = do-  vs <- wiredDefs cfg env name sigs-  return [v | (_, _, v, _) <- vs]--wiredDefs :: Config -> Bare.Env -> ModName -> GhcSpecSig-          -> Bare.Lookup [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]-wiredDefs cfg env name spSig-  | reflection cfg = do-    let x = F.dummyLoc functionComposisionSymbol-    v    <- Bare.lookupGhcVar env name "wiredAxioms" x-    return [ (x, F.val <$> lookup v (gsTySigs spSig), v, makeCompositionExpression v) ]-  | otherwise =-    return []------------------------------------------------------------------------------------ | Expression Definitions of Prelude Functions --------------------------------- | NV: Currently Just Hacking Composition       ----------------------------------------------------------------------------------------------------------------makeCompositionExpression :: Ghc.Id -> Ghc.CoreExpr-makeCompositionExpression gid-  =  go $ Ghc.varType $ F.notracepp ( -- tracing to find  the body of . from the inline spec,-                                      -- replace F.notrace with F.trace to print-      "\nv = " ++ GM.showPpr gid ++-      "\n realIdUnfolding = " ++ GM.showPpr (Ghc.realIdUnfolding gid) ++-      "\n maybeUnfoldingTemplate . realIdUnfolding = " ++ GM.showPpr (Ghc.maybeUnfoldingTemplate $ Ghc.realIdUnfolding gid ) ++-      "\n inl_src . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_src $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_inline . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_sat . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_sat $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_act . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_act $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_rule . inlinePragInfo . Ghc.idInfo = "   ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_rule rule = " ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inline spec = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo gid)-     ) gid-   where-    go (Ghc.ForAllTy a (Ghc.ForAllTy b (Ghc.ForAllTy c Ghc.FunTy{ Ghc.ft_arg = tf, Ghc.ft_res = Ghc.FunTy { Ghc.ft_arg = tg, Ghc.ft_res = tx}})))-      = let f = stringVar "f" tf-            g = stringVar "g" tg-            x = stringVar "x" tx-        in Ghc.Lam (Ghc.binderVar a) $-           Ghc.Lam (Ghc.binderVar b) $-           Ghc.Lam (Ghc.binderVar c) $-           Ghc.Lam f $ Ghc.Lam g $ Ghc.Lam x $ Ghc.App (Ghc.Var f) (Ghc.App (Ghc.Var g) (Ghc.Var x))-    go _ = error "Axioms.go"+    r             = F.exprReft (F.eApps (F.EVar s) (F.eVar <$> ys))
src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -23,7 +23,7 @@                                                                                  , empty                                                                                  ) import           Control.Applicative                       ((<|>))-import           Control.Arrow                             ((&&&))+import           Control.Monad.Reader import           Data.Maybe import           Data.Function                             (on) import           Text.PrettyPrint.HughesPJ                 hiding ((<>))@@ -32,18 +32,28 @@ import qualified Data.HashSet                              as S import           Data.Hashable import qualified Language.Fixpoint.Misc                    as Misc-import           Language.Fixpoint.SortCheck               (checkSorted, checkSortedReftFull, checkSortFull)+import           Language.Fixpoint.SortCheck               (ElabM, checkSorted, checkSortedReftFull, checkSortFull) import qualified Language.Fixpoint.Types                   as F import qualified Language.Haskell.Liquid.GHC.Misc          as GM import           Language.Haskell.Liquid.GHC.Play          (getNonPositivesTyCon)-import           Language.Haskell.Liquid.Misc              (condNull, thd5)-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Misc              (condNull, thd5, foldMapM)+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.PredType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Visitors import           Language.Haskell.Liquid.WiredIn-import           Language.Haskell.Liquid.LawInstances      (checkLawInstances)  import qualified Language.Haskell.Liquid.Measure           as Ms import qualified Language.Haskell.Liquid.Bare.Types        as Bare import qualified Language.Haskell.Liquid.Bare.Resolve      as Bare+import           Language.Haskell.Liquid.UX.Config+import Language.Fixpoint.Types.Config (ElabFlags (ElabFlags), solverFlags)   ----------------------------------------------------------------------------------------------@@ -69,8 +79,8 @@ ---------------------------------------------------------------------------------------------- -- | Checking BareSpec ------------------------------------------------------------------------ -----------------------------------------------------------------------------------------------checkBareSpec :: ModName -> Ms.BareSpec -> Either Diagnostics ()-checkBareSpec _ sp+checkBareSpec :: Ms.BareSpec -> Either Diagnostics ()+checkBareSpec sp   | allChecks == emptyDiagnostics = Right ()   | otherwise = Left allChecks   where@@ -83,20 +93,20 @@                                                      , S.fromList fields                                                      ]                         ]-    inlines   = Ms.inlines    sp-    hmeasures = Ms.hmeas      sp-    reflects  = Ms.reflects   sp-    measures  = msName    <$> Ms.measures sp-    fields    = concatMap dataDeclFields (Ms.dataDecls sp)+    inlines   = S.map (fmap getLHNameSymbol) (Ms.inlines sp)+    hmeasures = S.map (fmap getLHNameSymbol) (Ms.hmeas sp)+    reflects  = S.map (fmap getLHNameSymbol) (Ms.reflects sp)+    measures  = fmap getLHNameSymbol . msName <$> Ms.measures sp+    fields    = map (fmap getLHNameSymbol) $ concatMap dataDeclFields (Ms.dataDecls sp) -dataDeclFields :: DataDecl -> [F.LocSymbol]-dataDeclFields = filter (not . GM.isTmpSymbol . F.val)+dataDeclFields :: DataDecl -> [F.Located LHName]+dataDeclFields = filter (not . GM.isTmpSymbol . getLHNameSymbol . F.val)                . Misc.hashNubWith val                . concatMap dataCtorFields                . fromMaybe []                . tycDCons -dataCtorFields :: DataCtor -> [F.LocSymbol]+dataCtorFields :: DataCtor -> [F.Located LHName] dataCtorFields c   | isGadt c  = []   | otherwise = F.atLoc c <$> [ f | (f,_) <- dcFields c ]@@ -137,18 +147,18 @@   | otherwise                       = Left diagnostics   where     diagnostics      :: Diagnostics-    diagnostics      =  foldMap (checkBind allowHO bsc "measure"      emb tcEnv env) (gsMeas       (gsData tsp))+    diagnostics      =  runReader (foldMapM (checkBind allowHO bsc "measure"      emb tcEnv env) (gsMeas       (gsData tsp))) ef                      <> condNull noPrune-                        (foldMap (checkBind allowHO bsc "constructor"  emb tcEnv env) (txCtors $ gsCtors      (gsData tsp)))-                     <> foldMap (checkBind allowHO bsc "assume"       emb tcEnv env) (gsAsmSigs    (gsSig tsp))-                     <> foldMap (checkBind allowHO bsc "reflect"      emb tcEnv env . (\sig@(_,s) -> F.notracepp (show (ty_info (toRTypeRep (F.val s)))) sig)) (gsRefSigs (gsSig tsp))-                     <> checkTySigs allowHO bsc cbs            emb tcEnv env                (gsSig tsp)+                        (runReader (foldMapM (checkBind allowHO bsc "constructor"  emb tcEnv env) (txCtors $ gsCtors      (gsData tsp))) ef)+                     <> runReader (foldMapM (checkBind allowHO bsc "assume"       emb tcEnv env) (gsAsmSigs    (gsSig tsp))) ef+                     <> runReader (foldMapM (checkBind allowHO bsc "reflect"      emb tcEnv env . (\sig@(_,s) -> F.notracepp (show (ty_info (toRTypeRep (F.val s)))) sig)) (gsRefSigs (gsSig tsp))) ef+                     <> runReader (checkTySigs allowHO bsc cbs            emb tcEnv env                (gsSig tsp)) ef                      -- ++ mapMaybe (checkTerminationExpr             emb       env) (gsTexprs     (gsSig  sp))-                     <> foldMap (checkBind allowHO bsc "class method" emb tcEnv env) (clsSigs      (gsSig tsp))-                     <> foldMap (checkInv allowHO bsc emb tcEnv env)                 (gsInvariants (gsData tsp))-                     <> checkIAl allowHO bsc emb tcEnv env                            (gsIaliases   (gsData tsp))-                     <> checkMeasures emb env ms-                     <> checkClassMeasures                                        (gsMeasures (gsData tsp))+                     <> runReader (foldMapM (checkBind allowHO bsc "class method" emb tcEnv env) (clsSigs      (gsSig tsp))) ef+                     <> runReader (foldMapM (checkInv allowHO bsc emb tcEnv env)                 (gsInvariants (gsData tsp))) ef+                     <> runReader (checkIAl allowHO bsc emb tcEnv env                            (gsIaliases   (gsData tsp))) ef+                     <> runReader (checkMeasures emb env ms) ef+                     <> checkClassMeasures                                        ms                      <> checkClassMethods (gsCls src) (gsCMethods (gsVars tsp)) (gsTySigs     (gsSig tsp))                      -- <> foldMap checkMismatch sigs                      <> foldMap checkMismatch (L.filter (\(v,_) -> not (GM.isSCSel v || GM.isMethod v)) sigs)@@ -162,10 +172,12 @@                      -- NV TODO: allow instances of refined classes to be refined                      -- but make sure that all the specs are checked.                      -- ++ checkRefinedClasses                        rClasses rInsts-                     <> checkSizeFun emb env                                      (gsTconsP (gsName tsp))+                     <> runReader (checkSizeFun emb env                                      (gsTconsP (gsName tsp))) ef                      <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig tsp) ])-                     <> checkLawInstances (gsLaws tsp)                      <> checkRewrites tsp+                     <> if allowUnsafeConstructors $ getConfig tsp+                          then mempty+                          else checkConstructorRefinement (gsTySigs $ gsSig tsp)      _rClasses         = concatMap Ms.classes specs     _rInsts           = concatMap Ms.rinstance specs@@ -182,12 +194,46 @@     noPrune          = not (pruneFlag tsp)     txCtors ts       = [(v, fmap (fmap (fmap (F.filterUnMatched temps))) t) | (v, t) <- ts]     temps            = F.makeTemplates $ gsUnsorted $ gsData tsp+    ef               = maybe (ElabFlags False) solverFlags $ smtsolver $ getConfig tsp     -- env'             = L.foldl' (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms   +-- | Tests that the returned refinement type of data constructors has predicate @True@ or @prop v == e@.+--+-- > data T = T Int+-- > {-@ T :: x:Int -> { v:T | v = T x } @-} -- Should be rejected+-- > {-@ T :: x:Int -> { v:T | True } @-} -- Should be fine+-- > {-@ T :: x:Int -> { v:T | prop v = True } @-} -- Should be fine+--+checkConstructorRefinement :: [(Var, LocSpecType)] -> Diagnostics+checkConstructorRefinement = mconcat . map checkOne+  where+    checkOne (s, ty) | isCtorName s+                     , not $ validRef $ getRetTyRef $ val ty+                     = mkDiagnostics mempty [ ErrCtorRefinement (GM.sourcePosSrcSpan $ loc ty) (pprint s) ]+    checkOne _       = mempty +    getRetTyRef (RFun _ _ _ t _) = getRetTyRef t+    getRetTyRef (RAllT _ t _)    = getRetTyRef t+    getRetTyRef t                = ur_reft $ rt_reft t +    -- True refinement+    validRef (F.Reft (_, F.PTrue))+                      = True+    -- Prop foo from ProofCombinators+    validRef (F.Reft (v, F.PAtom F.Eq (F.EApp (F.EVar n) (F.EVar v')) _))+      | n == "Language.Haskell.Liquid.ProofCombinators.prop"+      , v == v'+      = True+    validRef _ = False++    isCtorName x = case idDetails x of+      DataConWorkId _ -> True+      DataConWrapId _ -> True+      _               -> False++ checkPlugged :: PPrint v => [(v, LocSpecType)] -> Diagnostics checkPlugged xs = mkDiagnostics mempty (map mkError (filter (hasHoleTy . val . snd) xs))   where@@ -203,56 +249,53 @@             -> Bare.TyConMap             -> F.SEnv F.SortedReft             -> GhcSpecSig-            -> Diagnostics+            -> ElabM Diagnostics ---------------------------------------------------------------------------------checkTySigs allowHO bsc cbs emb tcEnv senv sig-                   = mconcat (map (check senv) topTs)+checkTySigs allowHO bsc cbs emb tcEnv senv sig =+  do ef <- ask+     pure $ mconcat (runReader (traverse (check senv) topTs) ef)                    -- = concatMap (check env) topTs                    -- (mapMaybe   (checkT env) [ (x, t)     | (x, (t, _)) <- topTs])                    -- ++ (mapMaybe   (checkE env) [ (x, t, es) | (x, (t, Just es)) <- topTs])-                  <> coreVisitor checkVisitor senv emptyDiagnostics cbs+                     <> coreVisitor (checkVisitor ef) senv emptyDiagnostics cbs                    -- ++ coreVisitor checkVisitor env [] cbs   where-    check env      = checkSigTExpr allowHO bsc emb tcEnv env+    check :: F.SEnv F.SortedReft -> (Var, (LocSpecType, Maybe [Located F.Expr])) -> ElabM Diagnostics+    check          = checkSigTExpr allowHO bsc emb tcEnv     locTm          = M.fromList locTs     (locTs, topTs) = Bare.partitionLocalBinds vtes     vtes           = [ (x, (t, es)) | (x, t) <- gsTySigs sig, let es = M.lookup x vExprs]     vExprs         = M.fromList  [ (x, es) | (x, _, es) <- gsTexprs sig ] -    checkVisitor  :: CoreVisitor (F.SEnv F.SortedReft) Diagnostics-    checkVisitor   = CoreVisitor+    checkVisitor  :: ElabFlags -> CoreVisitor (F.SEnv F.SortedReft) Diagnostics+    checkVisitor ef = CoreVisitor                        { envF  = \env v     -> F.insertSEnv (F.symbol v) (vSort v) env-                       , bindF = \env acc v -> errs env v <> acc+                       , bindF = \env acc v -> runReader (errs env v) ef <> acc                        , exprF = \_   acc _ -> acc                        }     vSort            = Bare.varSortedReft emb+    errs :: F.SEnv F.SortedReft -> Var -> ElabM Diagnostics     errs env v       = case M.lookup v locTm of-                         Nothing -> emptyDiagnostics+                         Nothing -> pure emptyDiagnostics                          Just t  -> check env (v, t)  checkSigTExpr :: Bool -> BScope -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft               -> (Var, (LocSpecType, Maybe [Located F.Expr]))-              -> Diagnostics-checkSigTExpr allowHO bsc emb tcEnv env (x, (t, es))-           = mbErr1 <> mbErr2+              -> ElabM Diagnostics+checkSigTExpr allowHO bsc emb tcEnv env (x, (t, es)) =+  do ef <- ask+     pure $ runReader mbErr1 ef <> runReader mbErr2 ef    where     mbErr1 = checkBind allowHO bsc empty emb tcEnv env (x, t)-    mbErr2 = maybe emptyDiagnostics (checkTerminationExpr emb env . (x, t,)) es+    mbErr2 = maybe (pure emptyDiagnostics) (checkTerminationExpr emb env . (x, t,)) es     -- mbErr2 = checkTerminationExpr emb env . (x, t,) =<< es -_checkQualifiers :: F.SEnv F.SortedReft -> [F.Qualifier] -> [Error]-_checkQualifiers = mapMaybe . checkQualifier--checkQualifier       :: F.SEnv F.SortedReft -> F.Qualifier -> Maybe Error-checkQualifier env q =  mkE <$> checkSortFull (F.srcSpan q) γ F.boolSort  (F.qBody q)-  where-    γ                = L.foldl' (\e (x, s) -> F.insertSEnv x (F.RR s mempty) e) env (F.qualBinds q ++ wiredSortedSyms)-    mkE              = ErrBadQual (GM.fSrcSpan q) (pprint $ F.qName q)- -- | Used for termination checking. If we have no \"len\" defined /yet/ (for example we are checking -- 'GHC.Prim') then we want to skip this check.-checkSizeFun :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [TyConP] -> Diagnostics-checkSizeFun emb env tys = mkDiagnostics mempty (map mkError (mapMaybe go tys))+checkSizeFun :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [TyConP] -> ElabM Diagnostics+checkSizeFun emb env tys =+  do ef <- ask+     pure $ mkDiagnostics mempty (map mkError (mapMaybe (go ef) tys))   where     mkError ((f, tcp), msg)  = ErrTyCon (GM.sourcePosSrcSpan $ tcpLoc tcp)                                  (text "Size function" <+> pprint (f x)@@ -261,12 +304,14 @@                                                        <+> text "."                                                        $+$   msg)                                  (pprint (tcpCon tcp))-    go tcp = case tcpSizeFun tcp of++    go :: ElabFlags -> TyConP -> Maybe ((F.Symbol -> F.Expr, TyConP), Doc)+    go ef tcp = case tcpSizeFun tcp of                Nothing                   -> Nothing                Just f | isWiredInLenFn f -> Nothing -- Skip the check.-               Just f                    -> checkWFSize (szFun f) tcp+               Just f                    -> checkWFSize ef (szFun f) tcp -    checkWFSize f tcp = ((f, tcp),) <$> checkSortFull (F.srcSpan tcp) (F.insertSEnv x (mkTySort (tcpCon tcp)) env) F.intSort (f x)+    checkWFSize ef f tcp = ((f, tcp),) <$> runReader (checkSortFull (F.srcSpan tcp) (F.insertSEnv x (mkTySort (tcpCon tcp)) env) F.intSort (f x)) ef     x                 = "x" :: F.Symbol     mkTySort tc       = rTypeSortedReft emb (ofType $ TyConApp tc (TyVarTy <$> tyConTyVars tc) :: RRType ()) @@ -274,48 +319,13 @@     isWiredInLenFn IdSizeFun           = False     isWiredInLenFn (SymSizeFun locSym) = isWiredIn locSym -_checkRefinedClasses :: [RClass LocBareType] -> [RInstance LocBareType] -> [Error]-_checkRefinedClasses definitions instances-  = mkError <$> duplicates-  where-    duplicates-      = mapMaybe (checkCls . rcName) definitions-    checkCls cls-      = case findConflicts cls of-          []        -> Nothing-          conflicts -> Just (cls, conflicts)-    findConflicts cls-      = filter ((== cls) . riclass) instances-    mkError (cls, conflicts)-      = ErrRClass (GM.sourcePosSrcSpan $ loc $ btc_tc cls)-                  (pprint cls) (ofConflict <$> conflicts)-    ofConflict-      = GM.sourcePosSrcSpan . loc . btc_tc . riclass &&& pprint . ritype--_checkDuplicateFieldNames :: [(DataCon, DataConP)]  -> [Error]-_checkDuplicateFieldNames = mapMaybe go-  where-    go (d, dts)          = checkNoDups (dcpLoc dts) d (fst <$> dcpTyArgs dts)-    checkNoDups l d xs   = mkError l d <$> _firstDuplicate xs--    mkError l d x = ErrBadData (GM.sourcePosSrcSpan l)-                             (pprint d)-                             (text "Multiple declarations of record selector" <+> pprintSymbol x)--_firstDuplicate :: Ord a => [a] -> Maybe a-_firstDuplicate = go . L.sort-  where-    go (y:x:xs) | x == y    = Just x-                | otherwise = go (x:xs)-    go _                    = Nothing- checkInv :: Bool          -> BScope          -> F.TCEmb TyCon          -> Bare.TyConMap          -> F.SEnv F.SortedReft          -> (Maybe Var, LocSpecType)-         -> Diagnostics+         -> ElabM Diagnostics checkInv allowHO bsc emb tcEnv env (_, t) = checkTy allowHO bsc err emb tcEnv env t   where     err              = ErrInvt (GM.sourcePosSrcSpan $ loc t) (val t)@@ -326,8 +336,10 @@          -> Bare.TyConMap          -> F.SEnv F.SortedReft          -> [(LocSpecType, LocSpecType)]-         -> Diagnostics-checkIAl allowHO bsc emb tcEnv env = mconcat . map (checkIAlOne allowHO bsc emb tcEnv env)+         -> ElabM Diagnostics+checkIAl allowHO bsc emb tcEnv env ss =+  do ds <- traverse (checkIAlOne allowHO bsc emb tcEnv env) ss+     pure $ mconcat ds  checkIAlOne :: Bool             -> BScope@@ -335,10 +347,11 @@             -> Bare.TyConMap             -> F.SEnv F.SortedReft             -> (LocSpecType, LocSpecType)-            -> Diagnostics-checkIAlOne allowHO bsc emb tcEnv env (t1, t2) = mconcat $ checkEq : (tcheck <$> [t1, t2])+            -> ElabM Diagnostics+checkIAlOne allowHO bsc emb tcEnv env (t1, t2) =+  do cs <- traverse (\t -> checkTy allowHO bsc (err t) emb tcEnv env t) [t1, t2]+     pure $ mconcat $ checkEq : cs   where-    tcheck t = checkTy allowHO bsc (err t) emb tcEnv env t     err    t = ErrIAl (GM.sourcePosSrcSpan $ loc t) (val t)     t1'      :: RSort     t1'      = toRSort $ val t1@@ -363,7 +376,7 @@           -> Bare.TyConMap           -> F.SEnv F.SortedReft           -> (v, LocSpecType)-          -> Diagnostics+          -> ElabM Diagnostics checkBind allowHO bsc s emb tcEnv env (v, t) = checkTy allowHO bsc msg emb tcEnv env t   where     msg                      = ErrTySpec (GM.fSrcSpan t) (Just s) (pprint v) (val t)@@ -373,9 +386,10 @@                      => F.TCEmb TyCon                      -> F.SEnv F.SortedReft                      -> (v, LocSpecType, [F.Located F.Expr])-                     -> Diagnostics-checkTerminationExpr emb env (v, Loc l _ st, les)-            = mkError "ill-sorted" (go les) <> mkError "non-numeric" (go' les)+                     -> ElabM Diagnostics+checkTerminationExpr emb env (v, Loc l _ st, les) =+  do ef <- ask+     pure $ mkError "ill-sorted" (go ef les) <> mkError "non-numeric" (go' ef les)   where     -- es      = val <$> les     mkError :: Doc -> Maybe (F.Expr, Doc) -> Diagnostics@@ -385,11 +399,11 @@     -- mkErr   = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "ill-sorted" ) e t d)     -- mkErr'  = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "non-numeric") e t d) -    go :: [F.Located F.Expr] -> Maybe (F.Expr, Doc)-    go      = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (val e))     Nothing+    go :: ElabFlags -> [F.Located F.Expr] -> Maybe (F.Expr, Doc)+    go ef     = L.foldl' (\err e -> err <|> (val e,) <$> runReader (checkSorted (F.srcSpan e) env' (val e)) ef)     Nothing -    go' :: [F.Located F.Expr] -> Maybe (F.Expr, Doc)-    go'     = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (cmpZero e)) Nothing+    go' :: ElabFlags -> [F.Located F.Expr] -> Maybe (F.Expr, Doc)+    go' ef    = L.foldl' (\err e -> err <|> (val e,) <$> runReader (checkSorted (F.srcSpan e) env' (cmpZero e)) ef) Nothing      env'    = F.sr_sort <$> L.foldl' (\e (x,s) -> F.insertSEnv x s e) env xts     xts     = concatMap mkClss $ zip (ty_binds trep) (ty_args trep)@@ -408,11 +422,12 @@         -> Bare.TyConMap         -> F.SEnv F.SortedReft         -> LocSpecType-        -> Diagnostics+        -> ElabM Diagnostics checkTy allowHO bsc mkE emb tcEnv env t =-  case checkRType allowHO bsc emb env (Bare.txRefSort tcEnv emb t) of-    Nothing -> emptyDiagnostics-    Just d  -> mkDiagnostics mempty [mkE d]+  do me <- checkRType allowHO bsc emb env (Bare.txRefSort tcEnv emb t)+     pure $ case me of+              Nothing -> emptyDiagnostics+              Just d  -> mkDiagnostics mempty [mkE d]   where     _msg =  "CHECKTY: " ++ showpp (val t) @@ -449,8 +464,10 @@                                           (pprint . rtName . val $ x)                                           (GM.fSrcSpan <$> xs)     mkError []                = panic Nothing "mkError: called on empty list"-    dups                    = [z | z@(_:_:_) <- L.groupBy ((==) `on` (rtName . val)) tas]+    dups                    = [z | z@(_:_:_) <- groupDuplicatesOn (rtName . val) tas] +groupDuplicatesOn :: Ord b => (a -> b) -> [a] -> [[a]]+groupDuplicatesOn f = L.groupBy ((==) `on` f) . L.sortOn f  checkMismatch        :: (Var, LocSpecType) -> Diagnostics checkMismatch (x, t) = if ok then emptyDiagnostics else mkDiagnostics mempty [err]@@ -476,19 +493,21 @@ ------------------------------------------------------------------------------------------------ -- | @checkRType@ determines if a type is malformed in a given environment --------------------- -------------------------------------------------------------------------------------------------checkRType :: Bool -> BScope -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Doc+checkRType :: Bool -> BScope -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> ElabM (Maybe Doc) -------------------------------------------------------------------------------------------------checkRType allowHO bsc emb senv lt-  =   checkAppTys st-  <|> checkAbstractRefs st-  <|> efoldReft farg bsc cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv senv Nothing st+checkRType allowHO bsc emb senv lt =+  do ef <- ask+     let f env me r err = err <|> runReader (checkReft (F.srcSpan lt) env emb me r) ef+     pure $     checkAppTys st+            <|> checkAbstractRefs st+            <|> efoldReft farg bsc cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv senv Nothing st   where     -- isErasable         = if allowTC then isEmbeddedDict else isClass     st                 = val lt     cb c ts            = classBinds emb (rRCls c ts)     farg _ t           = allowHO || isBase t  -- NOTE: this check should be the same as the one in addCGEnv-    f env me r err     = err <|> checkReft (F.srcSpan lt) env emb me r-    insertPEnv p γ     = insertsSEnv γ (Misc.mapSnd (rTypeSortedReft emb) <$> pbinds p)++    insertPEnv p γ     = insertsSEnv γ (fmap (rTypeSortedReft emb) <$> pbinds p)     pbinds p           = (pname p, pvarRType p :: RSort) : [(x, tx) | (tx, x, _) <- pargs p]  tyToBind :: F.TCEmb TyCon -> RTVar RTyVar RSort  -> [(F.Symbol, F.SortedReft)]@@ -528,7 +547,7 @@   checkAbstractRefs-  :: (PPrint t, F.Reftable t, SubsTy RTyVar RSort t, F.Reftable (RTProp RTyCon RTyVar (UReft t))) =>+  :: (PPrint t, Reftable t, SubsTy RTyVar RSort t, Reftable (RTProp RTyCon RTyVar (UReft t))) =>      RType RTyCon RTyVar (UReft t) -> Maybe Doc checkAbstractRefs rt = go rt   where@@ -586,10 +605,11 @@     pvType' p          = Misc.safeHead (showpp p ++ " not in env of " ++ showpp rt) [pvType q | q <- penv, pname p == pname q]  -checkReft                    :: (PPrint r, F.Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, F.Reftable (RTProp RTyCon RTyVar (UReft r)))-                             => F.SrcSpan -> F.SEnv F.SortedReft -> F.TCEmb TyCon -> Maybe (RRType (UReft r)) -> UReft r -> Maybe Doc-checkReft _ _   _   Nothing _   = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.-checkReft sp env emb (Just t) _ = (\z -> dr $+$ z) <$> checkSortedReftFull sp env r+checkReft                    :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar (UReft r)))+                             => F.SrcSpan -> F.SEnv F.SortedReft -> F.TCEmb TyCon -> Maybe (RRType (UReft r)) -> UReft r -> ElabM (Maybe Doc)+checkReft _  _   _   Nothing  _ = pure Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.+checkReft sp env emb (Just t) _ = do me <- checkSortedReftFull sp env r+                                     pure $ (\z -> dr $+$ z) <$> me   where     r                           = rTypeSortedReft emb t     dr                          = text "Sort Error in Refinement:" <+> pprint r@@ -608,23 +628,24 @@ --------------------------------------------------------------------------------------------------- -- | @checkMeasures@ determines if a measure definition is wellformed ----------------------------- ----------------------------------------------------------------------------------------------------checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> Diagnostics+checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> ElabM Diagnostics ----------------------------------------------------------------------------------------------------checkMeasures emb env = foldMap (checkMeasure emb env)+checkMeasures emb env = foldMapM (checkMeasure emb env) -checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> Diagnostics+checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> ElabM Diagnostics checkMeasure emb γ (M name@(Loc src _ n) sort body _ _)-  = mkDiagnostics mempty [ txerror e | Just e <- checkMBody γ emb name sort <$> body ]+  = do me <- traverse (checkMBody γ emb name sort) body+       pure $ mkDiagnostics mempty [ txerror e | Just e <- me ]   where     txerror = ErrMeas (GM.sourcePosSrcSpan src) (pprint n) -checkMBody :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+checkMBody :: (PPrint r, Reftable r,SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))            => F.SEnv F.SortedReft            -> F.TCEmb TyCon            -> t            -> SpecType            -> Def (RRType r) DataCon-           -> Maybe Doc+           -> ElabM (Maybe Doc) checkMBody senv emb _ sort (Def m c _ bs body) = checkMBody' emb sort γ' sp body   where     sp    = F.srcSpan m@@ -648,14 +669,15 @@     go t@RApp{} t'@RApp{} = concat $ zipWith go (rt_args t) (rt_args t')     go _ _                = [] -checkMBody' :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+checkMBody' :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))             => F.TCEmb TyCon             -> RType RTyCon RTyVar r             -> F.SEnv F.SortedReft             -> F.SrcSpan             -> Body-            -> Maybe Doc-checkMBody' emb sort γ sp body = case body of+            -> ElabM (Maybe Doc)+checkMBody' emb sort γ sp body =+  case body of     E e   -> checkSortFull sp γ (rTypeSort emb sort') e     P p   -> checkSortFull sp γ F.boolSort  p     R s p -> checkSortFull sp (F.insertSEnv s sty γ) F.boolSort p@@ -706,12 +728,12 @@           ++ " contains an inner refinement."  -isRefined :: F.Reftable r => RType c tv r -> Bool+isRefined :: Reftable r => RType c tv r -> Bool isRefined ty-  | Just r <- stripRTypeBase ty = not $ F.isTauto r+  | Just r <- stripRTypeBase ty = not $ isTauto r   | otherwise = False -hasInnerRefinement :: F.Reftable r => RType c tv r -> Bool+hasInnerRefinement :: Reftable r => RType c tv r -> Bool hasInnerRefinement (RFun _ _ rIn rOut _) =   isRefined rIn || isRefined rOut hasInnerRefinement (RAllT _ ty  _) =@@ -744,9 +766,9 @@ checkClassMeasures :: [Measure SpecType DataCon] -> Diagnostics checkClassMeasures measures = mkDiagnostics mempty (mapMaybe checkOne byTyCon)   where-  byName = L.groupBy ((==) `on` (val . msName)) measures+  byName = groupDuplicatesOn (val . msName) measures -  byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . msEqns)))+  byTyCon = concatMap (groupDuplicatesOn (dataConTyCon . ctor . head . msEqns))                       byName    checkOne []     = impossible Nothing "checkClassMeasures.checkOne on empty measure group"
src/Language/Haskell/Liquid/Bare/Class.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns      #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp  #-}@@ -7,7 +8,6 @@  module Language.Haskell.Liquid.Bare.Class   ( makeClasses-  , makeCLaws   , makeSpecDictionaries   , makeDefaultMethods   , makeMethodTypes@@ -19,7 +19,6 @@ import qualified Data.List                                  as L import qualified Data.HashMap.Strict                        as M -import qualified Language.Fixpoint.Misc                     as Misc import qualified Language.Fixpoint.Types                    as F import qualified Language.Fixpoint.Types.Visitor            as F @@ -27,8 +26,14 @@ import qualified Language.Haskell.Liquid.GHC.Misc           as GM import qualified Liquid.GHC.API            as Ghc import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types              hiding (freeTyVars)+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Visitors  import qualified Language.Haskell.Liquid.Measure            as Ms import           Language.Haskell.Liquid.Bare.Types         as Bare@@ -56,7 +61,9 @@       classType Nothing _ = Nothing       classType (Just (d, ts, _)) x =         case filter ((==d) . Ghc.dataConWorkId . dcpCon) cls of-          (di:_) -> (dcpLoc di `F.atLoc`) . subst (zip (dcpFreeTyVars di) ts) <$> L.lookup (mkSymbol x) (dcpTyArgs di)+          (di:_) ->+            (dcpLoc di `F.atLoc`) . subst (zip (dcpFreeTyVars di) ts) <$>+            L.lookup (mkSymbol x) (map (first lhNameToResolvedSymbol) $ dcpTyArgs di)           _      -> Nothing        methodType d x m = ihastype (M.lookup d m) x@@ -129,28 +136,6 @@   --------------------------------------------------------------------------------makeCLaws :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs-          -> Bare.Lookup [(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]---------------------------------------------------------------------------------makeCLaws env sigEnv myName specs = do-  zMbs <- forM classTcs $ \(name, clss, tc) -> do-            clsMb <- mkClass env sigEnv myName name clss tc-            case clsMb of-              Nothing ->-                return Nothing-              Just cls -> do-                gcls <- Mb.maybe (err tc) Right (Ghc.tyConClass_maybe tc)-                return $ Just (gcls, snd cls)-  return (Mb.catMaybes zMbs)-  where-    err tc   = error ("Not a type class: " ++ F.showpp tc)-    classTc  = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName-    classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs-                                 , cls          <- Ms.claws spec-                                 , tc           <- Mb.maybeToList (classTc cls)-               ]--------------------------------------------------------------------------------- makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs             -> Bare.Lookup ([DataConP], [(ModName, Ghc.Var, LocSpecType)]) -------------------------------------------------------------------------------@@ -162,7 +147,7 @@     classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs                                  , cls          <- Ms.classes spec                                  , tc           <- Mb.maybeToList (classTc cls) ]-    classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName+    classTc = either (const Nothing) Just . Bare.lookupGhcTyConLHName (reTyLookupEnv env) . btc_tc . rcName  mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon         -> Bare.Lookup (Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)]))@@ -192,41 +177,47 @@  mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Bare.Lookup LocSpecType mkConstr env sigEnv name = fmap (fmap dropUniv) . Bare.cookSpecTypeE env sigEnv name Bare.GenTV-  where-    dropUniv t           = t' where (_, _, t') = bkUniv t     --FIXME: cleanup this code unClass :: SpecType -> SpecType unClass = snd . bkClass . thrd3 . bkUniv -makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType)+makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (Located LHName, LocBareType)            -> Bare.Lookup (ModName, PlugTV Ghc.Var, LocSpecType) makeMethod env sigEnv name (lx, bt) = (name, mbV,) <$> Bare.cookSpecTypeE env sigEnv name mbV bt   where-    mbV = maybe Bare.GenTV Bare.LqTV (Bare.maybeResolveSym env name "makeMethod" lx)+    mbV = either (const Bare.GenTV) Bare.LqTV (Bare.lookupGhcIdLHName env lx)  --------------------------------------------------------------------------------makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType+makeSpecDictionaries+  :: Bare.Env+  -> Bare.SigEnv+  -> (ModName, Ms.BareSpec)+  -> [(ModName, Ms.BareSpec)]+  -> ([RInstance LocBareType], DEnv Ghc.Var LocSpecType) --------------------------------------------------------------------------------makeSpecDictionaries env sigEnv specs-  = dfromList-  . concatMap (makeSpecDictionary env sigEnv)-  $ M.toList specs+makeSpecDictionaries env sigEnv spec0 specs+  = let (instances, specDicts) = makeSpecDictionary env sigEnv spec0+     in (instances, dfromList $ specDicts ++ concatMap (snd . makeSpecDictionary env sigEnv) specs)  makeSpecDictionary :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec)-                   -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]-makeSpecDictionary env sigEnv (name, spec)-  = Mb.catMaybes-  . resolveDictionaries env name-  . fmap (makeSpecDictionaryOne env sigEnv name)-  . Ms.rinstance-  $ spec+                   -> ([RInstance LocBareType], [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))])+makeSpecDictionary env sigEnv (name, spec) =+    let instances = Ms.rinstance spec+        resolved =+          resolveDictionaries env $+          map (makeSpecDictionaryOne env sigEnv name) instances+        updatedInstances =+          [ ri { riDictName = Just $ makeGHCLHNameLocatedFromId v }+          | (ri, (v, _)) <- zip instances resolved+          ]+     in (updatedInstances, resolved)  makeSpecDictionaryOne :: Bare.Env -> Bare.SigEnv -> ModName                       -> RInstance LocBareType-                      -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))-makeSpecDictionaryOne env sigEnv name (RI bt lbt xts)-         = makeDictionary $ F.notracepp "RI" $ RI bt ts [(x, mkLSpecIType t) | (x, t) <- xts ]+                      -> RInstance LocSpecType+makeSpecDictionaryOne env sigEnv name (RI bt mDictName lbt xts)+         = F.notracepp "RI" $ RI bt mDictName ts [(x, mkLSpecIType t) | (x, t) <- xts ]   where     ts      = mkTy' <$> lbt     rts     = concatMap (univs . val) ts@@ -245,36 +236,56 @@     mkLSpecIType :: RISig LocBareType -> RISig LocSpecType     mkLSpecIType t = fmap mkTy t -resolveDictionaries :: Bare.Env -> ModName -> [(F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))]-                    -> [Maybe (Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]-resolveDictionaries env name = fmap lookupVar-                             . concatMap addInstIndex-                             . Misc.groupList+resolveDictionaries :: Bare.Env -> [RInstance LocSpecType]+                    -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]+resolveDictionaries env = map $ \ri ->+    let !v = lookupDFun ri+     in (v, M.fromList $ first (getLHNameSymbol . val) <$> risigs ri)   where-    lookupVar (x, inst)      = (, inst) <$> Bare.maybeResolveSym env name "resolveDict" (F.dummyLoc x)+    lookupDFun (RI c (Just ldict) _ _) = do+       case Bare.lookupGhcIdLHName env ldict of+         Left e ->+           panic (Just $ GM.fSrcSpan $ btc_tc c) $+             "cannot find dictionary from name: " ++ show e+         Right v -> v+    lookupDFun (RI c _ ts _) = do+       let tys = map (toType False . dropUniv . val) ts+       case Bare.lookupGhcTyConLHName (reTyLookupEnv env) (btc_tc c) of+         Left _ ->+           panic (Just $ GM.fSrcSpan $ btc_tc c) "cannot find type class"+         Right tc -> case Ghc.tyConClass_maybe tc of+           Nothing ->+             panic (Just $ GM.fSrcSpan $ btc_tc c) "type constructor does not refer to a type class"+           Just cls ->+             case Ghc.lookupInstEnv False (Bare.reInstEnvs env) cls tys of+               -- Is it ok to pick the first match?+               ((clsInst, _) : _, _, _) ->+                 Ghc.is_dfun clsInst+               ([], _, _) ->+                 panic (Just $ GM.fSrcSpan $ btc_tc c) "cannot find class instance" --- formerly, addIndex--- GHC internal postfixed same name dictionaries with ints-addInstIndex            :: (F.Symbol, [a]) -> [(F.Symbol, a)]-addInstIndex (x, ks) = go (0::Int) (reverse ks)-  where-    go _ []          = []-    go _ [i]         = [(x, i)]-    go j (i:is)      = (F.symbol (F.symbolString x ++ show j),i) : go (j+1) is+dropUniv :: SpecType -> SpecType+dropUniv t = t' where (_,_,t') = bkUniv t + ---------------------------------------------------------------------------------- makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)]                    -> [(ModName, Ghc.Var, LocSpecType)] ---------------------------------------------------------------------------------- makeDefaultMethods env mts = [ (mname, dm, t)                                  | (mname, m, t) <- mts-                                 , dm            <- lookupDefaultVar env mname m ]+                                 , Just dm <- [lookupDefaultVar env m]+                             ] -lookupDefaultVar :: Bare.Env -> ModName -> Ghc.Var -> [Ghc.Var]-lookupDefaultVar env name v = Mb.maybeToList-                            . Bare.maybeResolveSym env name "default-method"-                            $ dmSym-  where-    dmSym                   = F.atLoc v (GM.qualifySymbol mSym dnSym)-    dnSym                   = F.mappendSym "$dm" nSym-    (mSym, nSym)            = GM.splitModuleName (F.symbol v)+lookupDefaultVar :: Bare.Env -> Ghc.Var -> Maybe Ghc.Var+lookupDefaultVar env v =+    case Ghc.idDetails v of+      Ghc.ClassOpId cls _ -> do+        mdm <- lookup v (Ghc.classOpItems cls)+        (n, dmspec) <- mdm+        case dmspec of+          Ghc.VanillaDM -> case lookupGhcIdLHName env (makeGHCLHNameLocated n) of+            Right x -> Just x+            _ -> Nothing+          _ -> Nothing+      _ -> Nothing
src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -13,6 +13,7 @@   -- * Constructors   , makeDataDecls   , makeConTypes+  , makeConTypes''   , makeRecordSelectorSigs   , meetDataConSpec   -- , makeTyConEmbeds@@ -31,20 +32,26 @@ import qualified Language.Fixpoint.Types                as F import qualified Language.Haskell.Liquid.GHC.Misc       as GM import qualified Liquid.GHC.API        as Ghc+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names import           Language.Haskell.Liquid.Types.PredType (dataConPSpecType) import qualified Language.Haskell.Liquid.Types.RefType  as RT+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.Meet import qualified Language.Fixpoint.Misc                 as Misc import qualified Language.Haskell.Liquid.Misc           as Misc import           Language.Haskell.Liquid.Types.Variance import           Language.Haskell.Liquid.WiredIn-import           Language.Haskell.Liquid.Types.Names (selfSymbol)  import qualified Language.Haskell.Liquid.Measure        as Ms  import qualified Language.Haskell.Liquid.Bare.Types     as Bare import qualified Language.Haskell.Liquid.Bare.Resolve   as Bare+import           Language.Haskell.Liquid.UX.Config+import qualified Text.PrettyPrint.HughesPJ as PJ import           Text.Printf                     (printf) import Text.PrettyPrint ((<+>)) @@ -215,7 +222,9 @@   | otherwise        = (mempty, [])   where     makeDecls        = exactDCFlag cfg && not (noADT cfg)-    warns            = (mkWarnDecl . fst . fst . snd <$> badTcs) ++ (mkWarnDecl <$> badDecs)+    warns            =+      (mkWarnDecl . fmap pprint . dataNameSymbol . tycName . fst . fst . snd <$> badTcs) +++      (mkWarnDecl . (\d -> F.atLoc d (pprint $ F.symbol d)) <$> badDecs)     tds'             = resolveTyCons name tds     tcDds            = filter ((/= Ghc.listTyCon) . fst)                      $ groupDataCons tds' ds@@ -233,8 +242,8 @@     badSyms         = {- F.notracepp "BAD-Data" . -} S.fromList . fmap F.symbol $ badDs     oks             = [ d |  d <- ds, not (S.member (F.symbol d) badSyms) ] -mkWarnDecl :: (F.Loc a, F.Symbolic a) => a -> Warning-mkWarnDecl d = mkWarning (GM.fSrcSpan d) ("Non-regular data declaration" <+> pprint (F.symbol d))+mkWarnDecl :: Located PJ.Doc -> Warning+mkWarnDecl d = mkWarning (GM.fSrcSpan d) ("Non-regular data declaration" <+> val d)   -- [NOTE:Orphan-TyCons]@@ -337,7 +346,7 @@   }   where     as          = dcpFreeTyVars dp-    xts         = [ (fld x, t) | (x, t) <- reverse (dcpTyArgs dp) ]+    xts         = [ (fld $ lhNameToResolvedSymbol x, t) | (x, t) <- reverse (dcpTyArgs dp) ]     fld         = F.atLoc dp . fieldName d dp  fieldName :: Ghc.DataCon -> DataConP -> F.Symbol -> F.Symbol@@ -371,7 +380,7 @@     upd dcm (x, t)           = M.insert x (Ghc.getSrcSpan x, tx') dcm                                 where                                   tx' = maybe t (meetX x t) (M.lookup x dcm)-    meetM (l,t) (_,t')       = (l, t `F.meet` t')+    meetM (l,t) (_,t')       = (l, t `meet` t')     meetX x t (sp', t')      = F.notracepp (_msg x t t') $ meetVarTypes emb (pprint x) (Ghc.getSrcSpan x, t) (sp', t')     _msg x t t'              = "MEET-VAR-TYPES: " ++ showpp (x, t, t') @@ -391,24 +400,32 @@   Misc.concatUnzip <$> mapM (makeConTypes' myName env) specs  +-- Essentially transforms the data declarations inside the specs+--- into LH's enhanced types for type constructors and data constructors makeConTypes' :: ModName -> Bare.Env -> (ModName, Ms.BareSpec)              -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])-makeConTypes' _myName env (name, spec) = do+makeConTypes' _myName env (name, spec) = makeConTypes'' env name spec dcs vdcs+  where+    dcs  = Ms.dataDecls spec+    vdcs = Ms.dvariance spec++-- Essentially transforms the data declarations into LH's enhanced types for type constructors and+-- data constructors+makeConTypes'' :: Bare.Env -> ModName -> Ms.BareSpec -> [DataDecl] -> [(F.Located LHName, [Variance])]+             -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])+makeConTypes'' env name spec dcs vdcs = do   dcs'   <- canonizeDecls env name dcs   let dcs'' = dataDeclSize spec dcs'   let gvs = groupVariances dcs'' vdcs   zong <- catLookups . map (uncurry (ofBDataDecl env name)) $ gvs   return (unzip zong)-  where-    dcs  = Ms.dataDecls spec-    vdcs = Ms.dvariance spec  -type DSizeMap = M.HashMap F.Symbol (F.Symbol, [F.Symbol])-normalizeDSize :: [([LocBareType], F.LocSymbol)] -> DSizeMap+type DSizeMap = M.HashMap LHName (F.Symbol, [LHName])+normalizeDSize :: [([LocBareType], F.Symbol)] -> DSizeMap normalizeDSize ds = M.fromList (concatMap go ds)   where go (ts,x) = let xs = Mb.mapMaybe (getTc . val) ts-                    in [(tc, (val x, xs)) | tc <- xs]+                    in [(tc, (x, xs)) | tc <- xs]         getTc (RAllT _ t _)  = getTc t         getTc (RApp c _ _ _) = Just (val $ btc_tc c)         getTc _ = Nothing@@ -420,16 +437,16 @@  makeSize :: DSizeMap -> DataDecl -> DataDecl makeSize smap d-  | Just p <- M.lookup (F.symbol $ tycName d) smap+  | Just p <- M.lookup (val $ dataNameSymbol $ tycName d) smap   = d {tycDCons = fmap (fmap (makeSizeCtor p)) (tycDCons d) }   | otherwise    = d -makeSizeCtor :: (F.Symbol, [F.Symbol]) -> DataCtor -> DataCtor-makeSizeCtor (s,xs) d = d {dcFields = Misc.mapSnd (mapBot go) <$> dcFields d}+makeSizeCtor :: (F.Symbol, [LHName]) -> DataCtor -> DataCtor+makeSizeCtor (s,xs) d = d {dcFields = fmap (mapBot go) <$> dcFields d}   where-    go (RApp c ts rs r) | F.symbol c `elem` xs-                        = RApp c ts rs (r `F.meet` rsz)+    go (RApp c ts rs r) | val (btc_tc c) `elem` xs+                        = RApp c ts rs (r `meet` rsz)     go t                = t     rsz  = MkUReft (F.Reft (F.vv_, F.PAtom F.Lt                                       (F.EApp (F.EVar s) (F.EVar F.vv_))@@ -478,7 +495,7 @@  dataDeclKey :: Bare.Env -> ModName -> DataDecl -> Bare.Lookup (Maybe F.Symbol) dataDeclKey env name d = do-  tcMb  <- Bare.lookupGhcDnTyCon env name "canonizeDecls" (tycName d)+  tcMb  <- Bare.lookupGhcDnTyCon env name (tycName d)   case tcMb of     Nothing ->       return Nothing@@ -506,11 +523,11 @@       dcs = S.fromList . fmap F.symbol . Ghc.tyConDataCons $ c    -- The data constructors in the spec (which we have to qualify for them to match the GHC data constructors)-  mbDcs <- mapM (Bare.failMaybe env name . Bare.lookupGhcDataCon env name "checkDataCtors" . dcName) cons+  mbDcs <- mapM (Bare.failMaybe env name . Bare.lookupGhcDataConLHName env . dcName) cons   let rdcs = S.fromList . fmap F.symbol . Mb.catMaybes $ mbDcs   if dcs == rdcs     then mapM checkDataCtorDupField cons-    else Left [errDataConMismatch (dataNameSymbol (tycName dd)) dcs rdcs]+    else Left [errDataConMismatch (getLHNameSymbol <$> dataNameSymbol (tycName dd)) dcs rdcs]  -- | Checks whether the given data constructor has duplicate fields. --@@ -531,17 +548,18 @@                      _   -> Left  ds  groupVariances :: [DataDecl]-               -> [(LocSymbol, [Variance])]-               -> [(Maybe DataDecl, Maybe (LocSymbol, [Variance]))]+               -> [(Located LHName, [Variance])]+               -> [(Maybe DataDecl, Maybe (Located LHName, [Variance]))] groupVariances dcs vdcs     =  merge (L.sort dcs) (L.sortBy (\x y -> compare (fst x) (fst y)) vdcs)   where     merge (d:ds) (v:vs)-      | F.symbol d == sym v = (Just d, Just v)  : merge ds vs-      | F.symbol d <  sym v = (Just d, Nothing) : merge ds (v:vs)+      | ddName d == sym v = (Just d, Just v)  : merge ds vs+      | ddName d <  sym v = (Just d, Nothing) : merge ds (v:vs)       | otherwise           = (Nothing, Just v) : merge (d:ds) vs     merge []     vs         = (Nothing,) . Just <$> vs     merge ds     []         = (,Nothing) . Just <$> ds     sym                     = val . fst+    ddName = val . dataNameSymbol . tycName   -- | 'checkDataDecl' checks that the supplied DataDecl is indeed a refinement@@ -559,7 +577,7 @@  getDnTyCon :: Bare.Env -> ModName -> DataName -> Bare.Lookup Ghc.TyCon getDnTyCon env name dn = do-  tcMb <- Bare.lookupGhcDnTyCon env name "ofBDataDecl-1" dn+  tcMb <- Bare.lookupGhcDnTyCon env name dn   case tcMb of     Just tc -> return tc     Nothing -> Left [ ErrBadData (GM.fSrcSpan dn) (pprint dn) "Unknown Type Constructor" ]@@ -567,18 +585,18 @@   -- FIXME: ES: why the maybes?-ofBDataDecl :: Bare.Env -> ModName -> Maybe DataDecl -> Maybe (LocSymbol, [Variance])+ofBDataDecl :: Bare.Env -> ModName -> Maybe DataDecl -> Maybe (Located LHName, [Variance])             -> Bare.Lookup ( (ModName, TyConP, Maybe DataPropDecl), [Located DataConP] ) ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invariance_info = do   let Loc lc lc' _ = dataNameSymbol tc-  let πs           = Bare.ofBPVar env name pos <$> ps+  let πs           = Bare.ofBPVar env pos <$> ps   let αs           = RTV . GM.symbolTyVar <$> as   let n            = length αs   let initmap      = zip (RT.uPVar <$> πs) [0..]   tc'             <- getDnTyCon env name tc   cts'            <- mapM (ofBDataCtor env name lc lc' tc' αs ps πs) (Mb.fromMaybe [] cts)   unless (checkDataDecl tc' dd) (Left [err])-  let pd           = Bare.ofBareType env name lc (Just []) <$> F.tracepp "ofBDataDecl-prop" pt+  let pd           = Bare.ofBareType env lc (Just []) <$> F.tracepp "ofBDataDecl-prop" pt   let tys          = [t | dcp <- cts', (_, t) <- dcpTyArgs dcp]   let varInfo      = L.nub $  concatMap (getPsSig initmap True) tys   let defPs        = varSignToVariance varInfo <$> [0 .. (length πs - 1)]@@ -592,7 +610,7 @@     err            = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables"  ofBDataDecl env name Nothing (Just (tc, is)) =-  case Bare.lookupGhcTyCon env name "ofBDataDecl-2" tc of+  case Bare.lookupGhcTyConLHName (Bare.reTyLookupEnv env) tc of     Left e    -> Left e     Right tc' -> Right ((name, TyConP srcpos tc' [] [] tcov tcontr Nothing, Nothing), [])   where@@ -614,7 +632,7 @@             -> DataCtor             -> Bare.Lookup DataConP ofBDataCtor env name l l' tc αs ps πs dc = do-  c' <- Bare.lookupGhcDataCon env name "ofBDataCtor" (dcName dc)+  c' <- Bare.lookupGhcDataConLHName env (dcName dc)   return (ofBDataCtorTc env name l l' tc αs ps πs dc c')  ofBDataCtorTc :: Bare.Env -> ModName -> F.SourcePos -> F.SourcePos ->@@ -634,11 +652,12 @@     , dcpLocE       = l'     }   where-    ts'           = Bare.ofBareType env name l (Just ps) <$> ts-    res'          = Bare.ofBareType env name l (Just ps) <$> res+    ts'           = Bare.ofBareType env l (Just ps) <$> ts+    res'          = Bare.ofBareType env l (Just ps) <$> res     t0'           = dataConResultTy c' αs t0 res'     _cfg          = getConfig env-    (yts, ot)     = qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0')+    yts           = zip xs ts'+    ot            = t0'     zts           = zipWith (normalizeField c') [1..] (reverse yts)     usedTvs       = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts'))     cs            = [ p | p <- RT.ofType <$> Ghc.dataConTheta c', keepPredType usedTvs p ]@@ -647,7 +666,6 @@                       Nothing -> RT.gApp tc αs πs                       Just ty -> RT.ofType ty     isGadt        = Mb.isJust res-    dLoc          = F.Loc l l' ()  errDataConMismatch :: LocSymbol -> S.HashSet F.Symbol -> S.HashSet F.Symbol -> Error errDataConMismatch d dcs rdcs = ErrDataConMismatch sp v (ppTicks <$> S.toList dcs) (ppTicks <$> S.toList rdcs)@@ -713,36 +731,13 @@   | rtc_tc c == Ghc.eqPrimTyCon = Just (a, t) eqSubst _                       = Nothing -normalizeField :: Ghc.DataCon -> Int -> (F.Symbol, a) -> (F.Symbol, a)+normalizeField :: Ghc.DataCon -> Int -> (LHName, a) -> (LHName, a) normalizeField c i (x, t)   | isTmp x   = (xi, t)   | otherwise = (x , t)   where-    isTmp     = F.isPrefixOfSym F.tempPrefix-    xi        = makeDataConSelector Nothing c i---- | `qualifyDataCtor` qualfies the field names for each `DataCtor` to---   ensure things work properly when exported.-type CtorType = ([(F.Symbol, SpecType)], SpecType)--qualifyDataCtor :: Bool -> ModName -> F.Located a -> CtorType -> CtorType-qualifyDataCtor qualFlag name l ct@(xts, st)- | qualFlag  = (xts', t')- | otherwise = ct- where-   t'        = F.subst su <$> st-   xts'      = [ (qx, F.subst su t)       | (qx, t, _) <- fields ]-   su        = F.mkSubst [ (x, F.eVar qx) | (qx, _, Just x) <- fields ]-   fields    = [ (qx, t, mbX) | (x, t) <- xts, let (mbX, qx) = qualifyField name (F.atLoc l x) ]--qualifyField :: ModName -> LocSymbol -> (Maybe F.Symbol, F.Symbol)-qualifyField name lx- | needsQual = (Just x, F.notracepp msg $ qualifyModName name x)- | otherwise = (Nothing, x)- where-   msg       = "QUALIFY-NAME: " ++ show x ++ " in module " ++ show (F.symbol name)-   x         = val lx-   needsQual = not (isWiredIn lx)+    isTmp     = F.isPrefixOfSym F.tempPrefix . lhNameToUnqualifiedSymbol+    xi        = makeGeneratedLogicLHName (makeDataConSelector Nothing c i)  checkRecordSelectorSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)] checkRecordSelectorSigs vts = [ (v, take1 v lspecTys) | (v, lspecTys) <- Misc.groupList vts ]@@ -768,7 +763,7 @@   go (RFun x i tx t r) = do     x' <- unDummy x <$> reader fst     r' <- singletonApp s <$> (L.reverse <$> reader snd)-    RFun x' i tx <$> local (extend x') (go t) <*> pure (F.meet r r')+    RFun x' i tx <$> local (extend x') (go t) <*> pure (meet r r')   go t = RT.strengthen t . singletonApp s . L.reverse <$> reader snd  singletonApp :: F.Symbolic a => F.LocSymbol -> [a] -> UReft F.Reft@@ -780,8 +775,8 @@ unDummy x i | x /= F.dummySymbol = x             | otherwise          = F.symbol ("_cls_lq" ++ show i) -makeRecordSelectorSigs :: Bare.Env -> ModName -> [Located DataConP] -> [(Ghc.Var, LocSpecType)]-makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne+makeRecordSelectorSigs :: Bare.Env -> [Located DataConP] -> [(Ghc.Var, LocSpecType)]+makeRecordSelectorSigs env = checkRecordSelectorSigs . concatMap makeOne   where   makeOne (Loc l l' dcp)     | Just cls <- maybe_cls@@ -798,7 +793,7 @@       maybe_cls = Ghc.tyConClass_maybe (Ghc.dataConTyCon dc)       dc  = dcpCon dcp       fls = Ghc.dataConFieldLabels dc-      fs  = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls+      fs  = Bare.lookupGhcId env . Ghc.flSelector <$> fls       ts :: [ LocSpecType ]       ts = [ Loc l l' (mkArrow (map (, mempty) (makeRTVar <$> dcpFreeTyVars dcp)) []                                  [(z, classRFInfo True, res, mempty)]@@ -806,10 +801,10 @@              | (x, t) <- reverse args -- NOTE: the reverse here is correct              , let vv = rTypeValueVar t                -- the measure singleton refinement, eg `v = getBar foo`-             , let mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))+             , let mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar $ lhNameToResolvedSymbol x) (F.EVar z)))              ] -      su   = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ]+      su   = F.mkSubst [ (lhNameToUnqualifiedSymbol x, F.EApp (F.EVar (lhNameToResolvedSymbol x)) (F.EVar z)) | x <- fst <$> args ]       args = dcpTyArgs dcp       z    = "lq$recSel"       res  = dropPreds (dcpTyRes dcp)
src/Language/Haskell/Liquid/Bare/Elaborate.hs view
@@ -2,10 +2,8 @@ {-# LANGUAGE ExplicitForAll            #-} {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE DeriveFunctor             #-}-{-# LANGUAGE TypeApplications          #-} {-# LANGUAGE LambdaCase                #-} {-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE CPP                       #-}  {-# OPTIONS_GHC -Wno-orphans #-} @@ -25,23 +23,20 @@ import           Liquid.GHC.API hiding (panic, varName) import qualified Language.Haskell.Liquid.GHC.Misc                                                as GM-import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.RefType                                                 ( ofType ) import qualified Data.List                     as L import qualified Data.HashMap.Strict           as M import qualified Data.HashSet                  as S import           Control.Monad.Free-#if MIN_VERSION_recursion_schemes(5,2,0)-import           Data.Fix                      hiding (hylo)-#endif  import           Data.Char                      ( isUpper )-import           Data.Functor.Foldable import           GHC.Types.Name.Occurrence import qualified Liquid.GHC.API as Ghc                                                 (noExtField)-import           Data.Default                   ( def ) import qualified Data.Maybe                    as Mb  -- TODO: make elaboration monadic so typeclass names are unified to something@@ -197,33 +192,31 @@ type SpecTypeF = RTypeF RTyCon RTyVar RReft type PartialSpecType = Free SpecTypeF () -type instance Base (RType c tv r) = RTypeF c tv r--instance Recursive (RType c tv r) where-  project (RVar var reft            ) = RVarF var reft-  project (RFun bind i tin tout reft) = RFunF  bind i tin tout reft-  project (RAllT tvbind ty ref      ) = RAllTF tvbind ty ref-  project (RAllP pvbind ty          ) = RAllPF pvbind ty-  project (RApp c args pargs reft   ) = RAppF c args pargs reft-  project (RAllE bind allarg ty     ) = RAllEF bind allarg ty-  project (REx   bind exarg  ty     ) = RExF bind exarg ty-  project (RExprArg e               ) = RExprArgF e-  project (RAppTy arg res reft      ) = RAppTyF arg res reft-  project (RRTy env ref obl ty      ) = RRTyF env ref obl ty-  project (RHole r                  ) = RHoleF r+project :: SpecType -> SpecTypeF SpecType+project (RVar var reft            ) = RVarF var reft+project (RFun bind i tin tout reft) = RFunF  bind i tin tout reft+project (RAllT tvbind ty ref      ) = RAllTF tvbind ty ref+project (RAllP pvbind ty          ) = RAllPF pvbind ty+project (RApp c args pargs reft   ) = RAppF c args pargs reft+project (RAllE bind allarg ty     ) = RAllEF bind allarg ty+project (REx   bind exarg  ty     ) = RExF bind exarg ty+project (RExprArg e               ) = RExprArgF e+project (RAppTy arg res reft      ) = RAppTyF arg res reft+project (RRTy env ref obl ty      ) = RRTyF env ref obl ty+project (RHole r                  ) = RHoleF r -instance Corecursive (RType c tv r) where-  embed (RVarF var reft            ) = RVar var reft-  embed (RFunF bind i tin tout reft) = RFun bind  i tin tout reft-  embed (RAllTF tvbind ty ref      ) = RAllT tvbind ty ref-  embed (RAllPF pvbind ty          ) = RAllP pvbind ty-  embed (RAppF c args pargs reft   ) = RApp c args pargs reft-  embed (RAllEF bind allarg ty     ) = RAllE bind allarg ty-  embed (RExF   bind exarg  ty     ) = REx bind exarg ty-  embed (RExprArgF e               ) = RExprArg e-  embed (RAppTyF arg res reft      ) = RAppTy arg res reft-  embed (RRTyF env ref obl ty      ) = RRTy env ref obl ty-  embed (RHoleF r                  ) = RHole r+embed :: SpecTypeF SpecType -> SpecType+embed (RVarF var reft            ) = RVar var reft+embed (RFunF bind i tin tout reft) = RFun bind  i tin tout reft+embed (RAllTF tvbind ty ref      ) = RAllT tvbind ty ref+embed (RAllPF pvbind ty          ) = RAllP pvbind ty+embed (RAppF c args pargs reft   ) = RApp c args pargs reft+embed (RAllEF bind allarg ty     ) = RAllE bind allarg ty+embed (RExF   bind exarg  ty     ) = REx bind exarg ty+embed (RExprArgF e               ) = RExprArg e+embed (RAppTyF arg res reft      ) = RAppTy arg res reft+embed (RRTyF env ref obl ty      ) = RRTy env ref obl ty+embed (RHoleF r                  ) = RHole r   -- specTypeToLHsType :: SpecType -> LHsType GhcPs@@ -234,15 +227,16 @@  -- A one-way function. Kind of like injecting something into Maybe specTypeToPartial :: forall a . SpecType -> SpecTypeF (Free SpecTypeF a)-specTypeToPartial = hylo (fmap wrap) project+specTypeToPartial = cata (fmap wrap)+  where+    cata g = g . fmap (cata g) . project --- probably should return spectype instead.. plugType :: SpecType -> PartialSpecType -> SpecType-plugType t = refix . f- where-  f = hylo Fix $ \case+plugType t = ana $ \case     Pure _   -> specTypeToPartial t     Free res -> res+  where+    ana g = embed . fmap (ana g) . g  -- build the expression we send to ghc for elaboration -- YL: tweak this function to see if ghc accepts explicit dictionary binders@@ -250,31 +244,40 @@  -- | returns (lambda binders, forall binders) collectSpecTypeBinders :: SpecType -> ([F.Symbol], [F.Symbol])-collectSpecTypeBinders = para $ \case-  RFunF bind _ (tin, _) (_, (bs, abs')) _ | isClassType tin -> (bs, abs')-                                       | otherwise       -> (bind : bs, abs')-  RAllEF b _ (_, (bs, abs'))  -> (b : bs, abs')-  RAllTF (RTVar (RTV ab) _) (_, (bs, abs')) _ -> (bs, F.symbol ab : abs')-  RExF b _ (_, (bs, abs'))    -> (b : bs, abs')-  RAppTyF _ (_, (bs, abs')) _ -> (bs, abs')-  RRTyF _ _ _ (_, (bs, abs')) -> (bs, abs')-  _                          -> ([], [])+collectSpecTypeBinders = \case+  RFun bind _ tin tout _+    | isClassType tin -> collectSpecTypeBinders tout+    | otherwise       -> let (bs, abs') = collectSpecTypeBinders tout+                          in (bind : bs, abs')+  RAllE b _ t ->+    let (bs, abs') = collectSpecTypeBinders t+     in (b : bs, abs')+  RAllT (RTVar (RTV ab) _) t _ ->+    let (bs, abs') = collectSpecTypeBinders t+     in (bs, F.symbol ab : abs')+  REx b _ t ->+    let (bs, abs') = collectSpecTypeBinders t+     in (b : bs, abs')+  RAppTy _ t _ -> collectSpecTypeBinders t+  RRTy _ _ _ t -> collectSpecTypeBinders t+  _ -> ([], [])  -- really should be fused with collectBinders. However, we need the binders -- to correctly convert fixpoint expressions to ghc expressions because of -- namespace related issues (whether the symbol denotes a varName or a datacon) buildHsExpr :: LHsExpr GhcPs -> SpecType -> LHsExpr GhcPs-buildHsExpr result = para $ \case-  RFunF bind _ (tin, _) (_, res) _-    | isClassType tin -> res-    | otherwise       -> mkHsLam [nlVarPat (varSymbolToRdrName bind)] res-  RAllEF  _ _        (_, res) -> res-  RAllTF  _ (_, res) _        -> res-  RExF    _ _        (_, res) -> res-  RAppTyF _ (_, res) _        -> res-  RRTyF _ _ _ (_, res)        -> res-  _                           -> result-+buildHsExpr result = go+  where+    go = \case+      RFun bind _ tin tout _+        | isClassType tin -> go tout+        | otherwise       -> mkHsLam [nlVarPat (varSymbolToRdrName bind)] (go tout)+      RAllE _ _ t -> go t+      RAllT _ t _ -> go t+      REx _ _ t -> go t+      RAppTy _ t _ -> go t+      RRTy _ _ _ t -> go t+      _ -> result   canonicalizeDictBinder@@ -447,7 +450,7 @@     RHole    _ -> impossible Nothing "RHole should not appear here"     RRTy{}     -> todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t)  where-  boolType = RApp (RTyCon boolTyCon [] def) [] [] mempty :: SpecType+  boolType = RApp (RTyCon boolTyCon [] defaultTyConInfo) [] [] mempty :: SpecType   elaborateReft     :: (F.PPrint a)     => (F.Reft, SpecType)@@ -562,9 +565,6 @@   rename (   F.FApp t0 t1 ) = F.FApp (rename t0) (rename t1)  -mkHsTyConApp ::  IdP GhcPs -> [LHsType GhcPs] -> LHsType GhcPs-mkHsTyConApp tyconId tyargs = nlHsTyConApp NotPromoted Prefix tyconId (map (HsValArg noExtField) tyargs)- -- | Embed fixpoint expressions into parsed haskell expressions. --   It allows us to bypass the GHC parser and use arbitrary symbols --   for identifiers (compared to using the string API)@@ -601,7 +601,7 @@ --   (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "and"))) --   (nlList $ fixExprToHsExpr env <$> es) fixExprToHsExpr env (F.POr es) = mkHsApp-  (nlHsVar (varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "or")))+  (nlHsVar (varQual_RDR foldableModule (fsLit "or")))   (nlList $ fixExprToHsExpr env <$> es) fixExprToHsExpr env (F.PIff e0 e1) = mkHsApp   (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "<=>"))) (fixExprToHsExpr env e0)@@ -623,9 +623,9 @@ constantToHsExpr :: F.Constant -> LHsExpr GhcPs -- constantToHsExpr (F.I c) = noLoc (HsLit NoExt (HsInt NoExt (mkIntegralLit c))) constantToHsExpr (F.I i) =-  noLocA (HsOverLit noExtField (mkHsIntegral (mkIntegralLit i)))+  noLocA $ mkHsOverLit (mkHsIntegral (mkIntegralLit i)) constantToHsExpr (F.R d) =-  noLocA (HsOverLit noExtField (mkHsFractional (mkTHFractionalLit (toRational d))))+  noLocA $ mkHsOverLit (mkHsFractional (mkTHFractionalLit (toRational d))) constantToHsExpr _ =   todo Nothing "constantToHsExpr: Not sure how to handle constructor L" @@ -680,34 +680,31 @@  specTypeToLHsType :: SpecType -> LHsType GhcPs -- surprised that the type application is necessary-specTypeToLHsType =-  flip (ghylo (distPara @SpecType) distAna) (fmap pure . project) $ \case-    RVarF (RTV tv) _ -> nlHsTyVar+specTypeToLHsType = \case+    RVar (RTV tv) _ -> nlHsTyVar       NotPromoted       -- (GM.notracePpr ("varRdr" ++ F.showpp (F.symbol tv)) $ getRdrName tv)       (symbolToRdrNameNs tvName (F.symbol tv))-    RFunF _ _ (tin, tin') (_, tout) _-      | isClassType tin -> noLocA $ HsQualTy Ghc.noExtField (noLocA [tin']) tout-      | otherwise       -> nlHsFunTy tin' tout-    RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> noLocA $ HsForAllTy+    RFun _ _ tin tout _+      | isClassType tin -> noLocA $ HsQualTy Ghc.noExtField (noLocA [specTypeToLHsType tin]) (specTypeToLHsType tout)+      | otherwise       -> nlHsFunTy (specTypeToLHsType tin) (specTypeToLHsType tout)+    RAllT (ty_var_value -> (RTV tv)) t _ -> noLocA $ HsForAllTy       Ghc.noExtField       (mkHsForAllInvisTele noAnn [noLocA $ UserTyVar noAnn SpecifiedSpec (noLocA $ symbolToRdrNameNs tvName (F.symbol tv))])-      t-    RAllPF _ (_, ty)                    -> ty-    RAppF RTyCon { rtc_tc = tc } ts _ _ -> mkHsTyConApp+      (specTypeToLHsType t)+    RAllP _ ty -> specTypeToLHsType ty+    RApp RTyCon { rtc_tc = tc } ts _ _ -> mkHsTyConApp       (getRdrName tc)-      [ hst | (t, hst) <- ts, notExprArg t ]+      [ specTypeToLHsType t | t <- ts, notExprArg t ]      where       notExprArg (RExprArg _) = False       notExprArg _            = True-    RAllEF _ (_, tin) (_, tout) -> nlHsFunTy tin tout-    RExF   _ (_, tin) (_, tout) -> nlHsFunTy tin tout-    -- impossible-    RAppTyF _ (RExprArg _, _) _ ->+    RAllE _ tin tout -> nlHsFunTy (specTypeToLHsType tin) (specTypeToLHsType tout)+    REx _ tin tout -> nlHsFunTy (specTypeToLHsType tin) (specTypeToLHsType tout)+    RAppTy _ (RExprArg _) _ ->       impossible Nothing "RExprArg should not appear here"-    RAppTyF (_, t) (_, t') _ -> nlHsAppTy t t'-    -- YL: todo..-    RRTyF _ _ _ (_, t)       -> t-    RHoleF _                 -> noLocA $ HsWildCardTy Ghc.noExtField-    RExprArgF _ ->+    RAppTy t t' _ -> nlHsFunTy (specTypeToLHsType t) (specTypeToLHsType t')+    RRTy _ _ _ t -> specTypeToLHsType t+    RHole _ -> noLocA $ HsWildCardTy Ghc.noExtField+    RExprArg _ ->       todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg"
src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -11,8 +11,8 @@   ( -- * Create alias expansion environment     makeRTEnv -    -- * Expand and Qualify-  , qualifyExpand+    -- * Expand+  , Expand(expand)      -- * Converting BareType to SpecType   , cookSpecType@@ -29,48 +29,61 @@  import           Control.Monad import           Control.Monad.State+import           Data.Bifunctor (second) import           Data.Functor ((<&>)) import qualified Control.Exception         as Ex import qualified Data.HashMap.Strict       as M import qualified Data.Char                 as Char import qualified Data.List                 as L-import qualified Text.Printf               as Printf import qualified Text.PrettyPrint.HughesPJ as PJ  import qualified Language.Fixpoint.Types               as F -- import qualified Language.Fixpoint.Types.Visitor       as F import qualified Language.Fixpoint.Misc                as Misc-import           Language.Fixpoint.Types (Expr(..)) -- , Symbol, symbol)+import           Language.Fixpoint.Types (Expr, ExprV(..), SourcePos) -- , Symbol, symbol) import qualified Language.Haskell.Liquid.GHC.Misc      as GM import qualified Liquid.GHC.API       as Ghc+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Names import qualified Language.Haskell.Liquid.Types.RefType as RT-import           Language.Haskell.Liquid.Types         hiding (fresh)+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types import qualified Language.Haskell.Liquid.Misc          as Misc import qualified Language.Haskell.Liquid.Measure       as Ms import qualified Language.Haskell.Liquid.Bare.Resolve  as Bare import qualified Language.Haskell.Liquid.Bare.Types    as Bare import qualified Language.Haskell.Liquid.Bare.Plugged  as Bare+import           Language.Haskell.Liquid.UX.Config+import qualified Text.Printf                           as Printf  -------------------------------------------------------------------------------- -- | `makeRTEnv` initializes the env needed to `expand` refinements and types, --   that is, the below needs to be called *before* we use `Expand.expand` ---------------------------------------------------------------------------------makeRTEnv :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.ModSpecs -> LogicMap-          -> BareRTEnv+makeRTEnv+  :: Bare.Env+  -> ModName+  -> Ms.BareSpec+  -> [(ModName, Ms.BareSpec)]+  -> LogicMap+  -> BareRTEnv ---------------------------------------------------------------------------------makeRTEnv env modName mySpec iSpecs lmap+makeRTEnv env modName mySpec dependencySpecs lmap           = renameRTArgs $ makeRTAliases tAs $ makeREAliases eAs   where-    tAs   = [ t                   | (_, s)  <- specs, t <- Ms.aliases  s ]-    eAs   = [ specREAlias env m e | (m, s)  <- specs, e <- Ms.ealiases s ]+    tAs   = [ t | (_, s)  <- specs, t <- Ms.aliases  s ]+    eAs   = [ e | (_m, s)  <- specs, e <- Ms.ealiases s ]          ++ if typeclass (getConfig env) then []                                               -- lmap expansion happens during elaboration                                               -- this clearly breaks things if a signature                                               -- contains lmap functions but never gets                                               -- elaborated-              else [ specREAlias env modName e | (_, xl) <- M.toList (lmSymDefs lmap)+              else [ e | (_, xl) <- M.toList (lmSymDefs lmap)                                   , let e    = lmapEAlias xl             ]-    specs = (modName, mySpec) : M.toList iSpecs+    specs = (modName, mySpec) : dependencySpecs  -- | We apply @renameRTArgs@ *after* expanding each alias-definition, to --   ensure that the substitutions work properly (i.e. don't miss expressions@@ -118,11 +131,6 @@   where     f rtEnv xt         = setRTAlias rtEnv (expandLoc rtEnv xt) -specREAlias :: Bare.Env -> ModName -> Located (RTAlias F.Symbol F.Expr) -> Located (RTAlias F.Symbol F.Expr)-specREAlias env m la = F.atLoc la $ a { rtBody = Bare.qualify env m (loc la) (rtVArgs a) (rtBody a) }-  where-    a     = val la- --------------------------------------------------------------------------------------------------------------  graphExpand :: (PPrint t)@@ -208,11 +216,11 @@ ordNub :: Ord a => [a] -> [a] ordNub = map head . L.group . L.sort -buildTypeEdges :: (F.Symbolic c) => AliasTable x t -> RType c tv r -> [F.Symbol]+buildTypeEdges :: AliasTable x t -> BareType -> [F.Symbol] buildTypeEdges table = ordNub . go   where     -- go :: t -> [Symbol]-    go (RApp c ts rs _) = go_alias (F.symbol c) ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)+    go (RApp c ts rs _) = go_alias (getLHNameSymbol $ val $ btc_tc c) ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)     go (RFun _ _ t1 t2 _) = go t1 ++ go t2     go (RAppTy t1 t2 _) = go t1 ++ go t2     go (RAllE _ t1 t2)  = go t1 ++ go t2@@ -263,25 +271,6 @@   expand :: BareRTEnv -> F.SourcePos -> a -> a  ------------------------------------------------------------------------------------- | @qualifyExpand@ first qualifies names so that we can successfully resolve them during expansion.------ When expanding, it's important we pass around a 'BareRTEnv' where the type aliases have been qualified as well.--- This is subtle, see for example T1761. In that test, we had a type alias \"OneTyAlias a = {v:a | oneFunPred v}\" where--- \"oneFunPred\" was marked inline. However, inlining couldn't happen because the 'BareRTEnv' had an--- entry for \"T1761.oneFunPred\", so the relevant expansion of \"oneFunPred\" couldn't happen. This was--- because the type alias entry inside 'BareRTEnv' mentioned the tuple (\"OneTyAlias\", \"{v:a | oneFunPred v}\") but--- the 'snd' element needed to be qualified as well, before trying to expand anything.------------------------------------------------------------------------------------qualifyExpand :: (PPrint a, Expand a, Bare.Qualify a)-              => Bare.Env -> ModName -> BareRTEnv -> F.SourcePos -> [F.Symbol] -> a -> a------------------------------------------------------------------------------------qualifyExpand env name rtEnv l bs-  = expand qualifiedRTEnv l . Bare.qualify env name l bs-  where-    qualifiedRTEnv :: BareRTEnv-    qualifiedRTEnv = rtEnv { typeAliases = M.map (Bare.qualify env name l bs) (typeAliases rtEnv) }------------------------------------------------------------------------------------ expandLoc :: (Expand a) => BareRTEnv -> Located a -> Located a expandLoc rtEnv lx = expand rtEnv (F.loc lx) <$> lx @@ -314,6 +303,16 @@     = expandReft     rtEnv l -- apply expression aliases     . expandBareType rtEnv l -- apply type       aliases +instance Expand () where+  expand _ _ = id++instance Expand (BRType ()) where+  expand rtEnv l+    = expandReft     rtEnv l -- apply expression aliases+    . void+    . expandBareType rtEnv l -- apply type       aliases+    . fmap (const mempty)+ instance Expand (RTAlias F.Symbol Expr) where   expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) } @@ -373,10 +372,8 @@ expandBareSpec :: BareRTEnv -> F.SourcePos -> Ms.BareSpec -> Ms.BareSpec expandBareSpec rtEnv l sp = sp   { measures   = expand rtEnv l (measures   sp)-  , asmSigs    = expand rtEnv l (asmSigs    sp)-  , sigs       = expand rtEnv l (sigs       sp)-  , localSigs  = expand rtEnv l (localSigs  sp)-  , reflSigs   = expand rtEnv l (reflSigs   sp)+  , asmSigs    = map (second (expand rtEnv l)) (asmSigs sp)+  , sigs       = map (second (expand rtEnv l)) (sigs sp)   , ialiases   = [ (f x, f y) | (x, y) <- ialiases sp ]   , dataDecls  = expand rtEnv l (dataDecls  sp)   , newtyDecls = expand rtEnv l (newtyDecls sp)@@ -384,7 +381,7 @@   where f      = expand rtEnv l  expandBareType :: BareRTEnv -> F.SourcePos -> BareType -> BareType-expandBareType rtEnv _ = go+expandBareType rtEnv l = go   where     go (RApp c ts rs r)  = case lookupRTEnv c rtEnv of                              Just rta -> expandRTAliasApp (GM.fSourcePos c) rta (go <$> ts) r@@ -399,10 +396,10 @@     go t@RHole{}         = t     go t@RVar{}          = t     go t@RExprArg{}      = t-    goRef (RProp ss t)   = RProp ss (go t)+    goRef (RProp ss t)   = RProp (map (expand rtEnv l <$>) ss) (go t)  lookupRTEnv :: BTyCon -> BareRTEnv -> Maybe (Located BareRTAlias)-lookupRTEnv c rtEnv = M.lookup (F.symbol c) (typeAliases rtEnv)+lookupRTEnv c rtEnv = M.lookup (getLHNameSymbol $ val $ btc_tc c) (typeAliases rtEnv)  expandRTAliasApp :: F.SourcePos -> Located BareRTAlias -> [BareType] -> RReft -> BareType expandRTAliasApp l (Loc la _ rta) args r = case isOK of@@ -411,9 +408,9 @@   where     tsu       = zipWith (\α t -> (α, toRSort t, t)) αs ts     esu       = F.mkSubst $ zip (F.symbol <$> εs) es-    es        = exprArg l msg <$> es0+    es        = exprArgFromBareType l msg <$> es0     (ts, es0) = splitAt nαs args-    (αs, εs)  = (BTV <$> rtTArgs rta, rtVArgs rta)+    (αs, εs)  = (BTV . dummyLoc <$> rtTArgs rta, rtVArgs rta)     targs     = takeWhile (not . isRExprArg) args     eargs     = dropWhile (not . isRExprArg) args @@ -436,6 +433,20 @@       | otherwise       = Nothing +-- | A copy of 'LHNameResolution.exprArg' tailored to the types needed in this+-- module.+exprArgFromBareType :: SourcePos -> String -> BareType -> Expr+exprArgFromBareType l msg = go+  where+    go :: BareType -> Expr+    go (RExprArg e)     = val e+    go (RVar x _)       = EVar $ F.symbol x+    go (RApp x [] [] _) = EVar (getLHNameSymbol $ val $ btc_tc x)+    go (RApp f ts [] _) = F.eApps (EVar (getLHNameSymbol $ val $ btc_tc f)) (go <$> ts)+    go (RAppTy t1 t2 _) = EApp (go t1) (go t2)+    go z                = panic sp $ Printf.printf "Unexpected expression parameter: %s in %s" (show z) msg+    sp                  = Just (GM.sourcePosSrcSpan l)+ isRExprArg :: RType c tv r -> Bool isRExprArg (RExprArg _) = True isRExprArg _            = False@@ -448,31 +459,6 @@     sp'             = GM.sourcePosSrcSpan la  ------------------------------------------------------------------------------------- | exprArg converts a tyVar to an exprVar because parser cannot tell---   this function allows us to treating (parsed) "types" as "value"---   arguments, e.g. type Matrix a Row Col = List (List a Row) Col---   Note that during parsing, we don't necessarily know whether a---   string is a type or a value expression. E.g. in tests/pos/T1189.hs,---   the string `Prop (Ev (plus n n))` where `Prop` is the alias:---     {-@ type Prop E = {v:_ | prop v = E} @-}---   the parser will chomp in `Ev (plus n n)` as a `BareType` and so---   `exprArg` converts that `BareType` into an `Expr`.----------------------------------------------------------------------------------exprArg :: F.SourcePos -> String -> BareType -> Expr-exprArg l msg = F.notracepp ("exprArg: " ++ msg) . go-  where-    go :: BareType -> Expr-    go (RExprArg e)     = val e-    go (RVar x _)       = EVar (F.symbol x)-    go (RApp x [] [] _) = EVar (F.symbol x)-    go (RApp f ts [] _) = F.mkEApp (F.symbol <$> btc_tc f) (go <$> ts)-    go (RAppTy t1 t2 _) = F.EApp (go t1) (go t2)-    go z                = panic sp $ Printf.printf "Unexpected expression parameter: %s in %s" (show z) msg-    sp                  = Just (GM.sourcePosSrcSpan l)-- ---------------------------------------------------------------------------------------- -- | @cookSpecType@ is the central place where a @BareType@ gets processed, --   in multiple steps, into a @SpecType@. See [NOTE:Cooking-SpecType] for@@ -492,18 +478,14 @@               -> Bare.Lookup LocSpecType ----------------------------------------------------------------------------------------- cookSpecTypeE env sigEnv name@(ModName _ _) x bt-  = fmap f . bareSpecType env name $ bareExpandType rtEnv bt+  = fmap f . bareSpecType env $ bareExpandType rtEnv bt   where     f = (if doplug || not allowTC then plugHoles allowTC sigEnv name x else id)-        . fmap (addTyConInfo embs tyi)+        . fmap (RT.addTyConInfo embs tyi)         . Bare.txRefSort tyi embs         . fmap txExpToBind -- What does this function DO         . (specExpandType rtEnv . fmap (generalizeWith x))         . (if doplug || not allowTC then maybePlug allowTC sigEnv name x else id)-        -- we do not qualify/resolve Expr/Pred when typeclass is enabled-        -- since ghci will not be able to recognize fully qualified names-        -- instead, we leave qualification to ghc elaboration-        . Bare.qualifyTop env name l      allowTC = typeclass (getConfig env)     -- modT   = mname `S.member` wiredInMods@@ -518,7 +500,6 @@     rtEnv  = Bare.sigRTEnv    sigEnv     embs   = Bare.sigEmbs     sigEnv     tyi    = Bare.sigTyRTyMap sigEnv-    l      = F.loc bt  -- | We don't want to generalize type variables that maybe bound in the --   outer scope, e.g. see tests/basic/pos/LocalPlug00.hs@@ -531,7 +512,7 @@ generalizeVar :: Ghc.Var -> SpecType -> SpecType generalizeVar v t = mkUnivs (zip as (repeat mempty)) [] t   where-    as            = filter isGen (freeTyVars t)+    as            = filter isGen (RT.freeTyVars t)     (vas,_)       = Ghc.splitForAllTyCoVars (GM.expandVarType v)     isGen (RTVar (RTV a) _) = a `elem` vas @@ -547,8 +528,8 @@ specExpandType :: BareRTEnv -> LocSpecType -> LocSpecType specExpandType = expandLoc -bareSpecType :: Bare.Env -> ModName -> LocBareType -> Bare.Lookup LocSpecType-bareSpecType env name bt = case Bare.ofBareTypeE env name (F.loc bt) Nothing (val bt) of+bareSpecType :: Bare.Env -> LocBareType -> Bare.Lookup LocSpecType+bareSpecType env bt = case Bare.ofBareTypeE env (F.loc bt) Nothing (val bt) of   Left e  -> Left e   Right t -> Right (F.atLoc bt t) @@ -747,7 +728,7 @@ addExist :: SpecType -> F.Symbol -> (RSort, F.Expr) -> SpecType addExist t x (tx, e) = REx x t' t   where-    t'               = ofRSort tx `strengthen` uTop r+    t'               = ofRSort tx `RT.strengthen` RT.uTop r     r                = F.exprReft e  expToBindRef :: UReft r -> State ExSt (UReft r)
− src/Language/Haskell/Liquid/Bare/Laws.hs 
@@ -1,54 +0,0 @@-module Language.Haskell.Liquid.Bare.Laws ( makeInstanceLaws ) where--import qualified Data.Maybe                                 as Mb-import qualified Data.List                                  as L-import qualified Data.HashMap.Strict                        as M-import           Control.Monad ((<=<))--import qualified Language.Haskell.Liquid.Measure            as Ms-import qualified Language.Fixpoint.Types                    as F-import qualified Language.Haskell.Liquid.GHC.Misc           as GM-import           Language.Haskell.Liquid.Bare.Types         as Bare-import           Language.Haskell.Liquid.Bare.Resolve       as Bare-import           Language.Haskell.Liquid.Bare.Expand        as Bare-import           Language.Haskell.Liquid.Types-import           Liquid.GHC.API----makeInstanceLaws :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)]-                -> Bare.ModSpecs -> [LawInstance]-makeInstanceLaws env sigEnv sigs specs-  = [makeInstanceLaw env sigEnv sigs name rilaw-              | (name, spec) <- M.toList specs-              , rilaw <- Ms.ilaws spec ]---makeInstanceLaw :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)] -> ModName-                -> RILaws LocBareType -> LawInstance-makeInstanceLaw env sigEnv sigs name rilaw = LawInstance-  { lilName   = Mb.fromMaybe errmsg tc-  , liSupers  = mkTy <$> rilSupers rilaw-  , lilTyArgs = mkTy <$> rilTyArgs rilaw-  , lilEqus   = [(mkVar l, mkTypedVar r) | (l,r)<- rilEqus rilaw ]-  , lilPos    = GM.sourcePosSrcSpan $ loc $ rilPos rilaw-  }-  where-    tc    :: Maybe Class-    tc     = classTc (rilName rilaw)-    errmsg = error ("Not a type class: " ++ F.showpp tc)--    classTc = tyConClass_maybe <=< (Bare.maybeResolveSym env name "makeClass" . btc_tc)--    mkTy :: LocBareType -> LocSpecType-    mkTy = Bare.cookSpecType env sigEnv name Bare.GenTV-    mkVar :: LocSymbol -> VarOrLocSymbol-    mkVar x = case Bare.maybeResolveSym env name "makeInstanceLaw" x of-                Just v -> Left v-                _      -> Right x--    mkTypedVar :: LocSymbol -> (VarOrLocSymbol, Maybe LocSpecType)-    mkTypedVar l = case mkVar l of-                     Left x -> (Left x, Just $ Mb.fromMaybe (dummyLoc $ ofType $ varType x) (L.lookup x sigs))-                     Right x -> (Right x, Nothing)-
src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -12,12 +12,15 @@   , makeMeasureSelectors   , makeMeasureSpec   , makeMeasureSpec'+  , makeOpaqueReflMeasures+  , getReflDCs   , varMeasures+  , getMeasVars   , makeClassMeasureSpec   -- , makeHaskellBounds+  , varLocSym   ) where -import Data.Default import qualified Control.Exception as Ex import Prelude hiding (mapM, error) import Data.Bifunctor@@ -36,8 +39,14 @@ import           Language.Haskell.Liquid.Misc             ((.||.)) import qualified Liquid.GHC.API       as Ghc import qualified Language.Haskell.Liquid.GHC.Misc      as GM+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names import qualified Language.Haskell.Liquid.Types.RefType as RT-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types -- import           Language.Haskell.Liquid.Types.Bounds import qualified Language.Haskell.Liquid.Measure       as Ms @@ -46,30 +55,37 @@ import qualified Language.Haskell.Liquid.Bare.Expand   as Bare import qualified Language.Haskell.Liquid.Bare.DataType as Bare import qualified Language.Haskell.Liquid.Bare.ToBare   as Bare+import           Language.Haskell.Liquid.UX.Config import Control.Monad (mapM)+import qualified Data.List as L  ---------------------------------------------------------------------------------makeHaskellMeasures :: Bool -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec-                    -> [Measure (Located BareType) LocSymbol]+makeHaskellMeasures :: Config -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec+                    -> [Measure (Located BareType) (Located LHName)] ---------------------------------------------------------------------------------makeHaskellMeasures allowTC src tycEnv lmap spec+makeHaskellMeasures cfg src tycEnv lmap spec           = Bare.measureToBare <$> ms   where-    ms    = makeMeasureDefinition allowTC tycEnv lmap cbs <$> mSyms-    cbs   = nonRecCoreBinds   (_giCbs src)+    ms    = makeMeasureDefinition cfg tycEnv lmap cbs <$> mSyms+    cbs   = Ghc.flattenBinds (_giCbs src)     mSyms = S.toList (Ms.hmeas spec) -makeMeasureDefinition :: Bool -> Bare.TycEnv -> LogicMap -> [Ghc.CoreBind] -> LocSymbol-                      -> Measure LocSpecType Ghc.DataCon-makeMeasureDefinition allowTC tycEnv lmap cbs x =-  case GM.findVarDef (val x) cbs of-    Nothing        -> Ex.throw $ errHMeas x "Cannot extract measure from haskell function"+makeMeasureDefinition+  :: Config -> Bare.TycEnv -> LogicMap -> [(Ghc.Id, Ghc.CoreExpr)] -> Located LHName+  -> Measure LocSpecType Ghc.DataCon+makeMeasureDefinition cfg tycEnv lmap cbs x =+  case L.find ((x ==) . makeGHCLHNameLocatedFromId . fst) cbs of+    Nothing ->+      Ex.throw $+        errHMeas x "Cannot extract measure from haskell function"     Just (v, cexp) -> Ms.mkM vx vinfo mdef MsLifted (makeUnSorted allowTC (Ghc.varType v) mdef)                      where-                       vx           = F.atLoc x (F.symbol v)-                       mdef         = coreToDef' allowTC tycEnv lmap vx v cexp+                       vx           = reflectLHName (Ghc.nameModule $ Ghc.getName v) <$> x+                       mdef         = coreToDef' cfg tycEnv lmap vx v cexp                        vinfo        = GM.varLocInfo (logicType allowTC) v +    where allowTC = typeclass cfg+ makeUnSorted :: Bool -> Ghc.Type -> [Def LocSpecType Ghc.DataCon] -> UnSortedExprs makeUnSorted allowTC ty defs   | isMeasureType ta@@ -87,41 +103,43 @@     isMeasureType (Ghc.TyConApp _ ts) = all Ghc.isTyVarTy ts     isMeasureType _                   = False -    defToUnSortedExpr defn = (xx:(fst <$> binds defn),-                             Ms.bodyPred (F.mkEApp (measure defn) [F.expr xx]) (body defn))+    defToUnSortedExpr defn =+      (xx:(fst <$> binds defn),+       Ms.bodyPred (F.eApps (F.EVar $ lhNameToResolvedSymbol $ F.val $ measure defn) [F.expr xx]) (body defn))      xx = F.vv $ Just 10000     isErasable = if allowTC then GM.isEmbeddedDictType else Ghc.isClassPred -coreToDef' :: Bool -> Bare.TycEnv -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr+coreToDef' :: Config -> Bare.TycEnv -> LogicMap -> Located LHName -> Ghc.Var -> Ghc.CoreExpr            -> [Def LocSpecType Ghc.DataCon]-coreToDef' allowTC tycEnv lmap vx v defn =-  case runToLogic embs lmap dm (errHMeas vx) (coreToDef allowTC vx v defn) of+coreToDef' cfg tycEnv lmap vx v defn =+  case runToLogic embs lmap dm cfg (errHMeas vx) (coreToDef vx v defn) of     Right l -> l     Left e  -> Ex.throw e   where     embs    = Bare.tcEmbs       tycEnv     dm      = Bare.tcDataConMap tycEnv -errHMeas :: LocSymbol -> String -> Error+errHMeas :: Located LHName -> String -> Error errHMeas x str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)  ---------------------------------------------------------------------------------makeHaskellInlines :: Bool -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec+makeHaskellInlines :: Config -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec                    -> [(LocSymbol, LMap)] ---------------------------------------------------------------------------------makeHaskellInlines allowTC src embs lmap spec-         = makeMeasureInline allowTC embs lmap cbs <$> inls+makeHaskellInlines cfg src embs lmap spec+         = makeMeasureInline cfg embs lmap cbs <$> inls   where-    cbs  = nonRecCoreBinds (_giCbs src)+    cbs  = Ghc.flattenBinds (_giCbs src)     inls = S.toList        (Ms.inlines spec) -makeMeasureInline :: Bool -> F.TCEmb Ghc.TyCon -> LogicMap -> [Ghc.CoreBind] -> LocSymbol-                  -> (LocSymbol, LMap)-makeMeasureInline allowTC embs lmap cbs x =-  case GM.findVarDef (val x) cbs of+makeMeasureInline+  :: Config -> F.TCEmb Ghc.TyCon -> LogicMap -> [(Ghc.Id, Ghc.CoreExpr)] -> Located LHName+  -> (LocSymbol, LMap)+makeMeasureInline cfg embs lmap cbs x =+  case L.find ((val x ==) . makeGHCLHNameFromId . fst) cbs of     Nothing        -> Ex.throw $ errHMeas x "Cannot inline haskell function"-    Just (v, defn) -> (vx, coreToFun' allowTC embs Nothing lmap vx v defn ok)+    Just (v, defn) -> (vx, coreToFun' cfg embs Nothing lmap vx v defn ok)                      where                        vx         = F.atLoc x (F.symbol v)                        ok (xs, e) = LMap vx (F.symbol <$> xs) (either id id e)@@ -131,31 +149,25 @@ --   but NOT when lifting inlines (which do not have case-of). --   For details, see [NOTE:Lifting-Stages] -coreToFun' :: Bool -> F.TCEmb Ghc.TyCon -> Maybe Bare.DataConMap -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr+coreToFun' :: Config -> F.TCEmb Ghc.TyCon -> Maybe Bare.DataConMap -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr            -> (([Ghc.Var], Either F.Expr F.Expr) -> a) -> a-coreToFun' allowTC embs dmMb lmap x v defn ok = either Ex.throw ok act+coreToFun' cfg embs dmMb lmap x v defn ok = either Ex.throw ok act   where-    act  = runToLogic embs lmap dm err xFun-    xFun = coreToFun allowTC x v defn-    err  = errHMeas x+    act  = runToLogic embs lmap dm cfg err xFun+    xFun = coreToFun x v defn+    err  str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)     dm   = Mb.fromMaybe mempty dmMb  -nonRecCoreBinds :: [Ghc.CoreBind] -> [Ghc.CoreBind]-nonRecCoreBinds            = concatMap go-  where-    go cb@(Ghc.NonRec _ _) = [cb]-    go    (Ghc.Rec xes)    = [Ghc.NonRec x e | (x, e) <- xes]- --------------------------------------------------------------------------------makeHaskellDataDecls :: Config -> ModName -> Ms.BareSpec -> [Ghc.TyCon]+makeHaskellDataDecls :: Config -> Ms.BareSpec -> [Ghc.TyCon]                      -> [DataDecl] ---------------------------------------------------------------------------------makeHaskellDataDecls cfg name spec tcs+makeHaskellDataDecls cfg spec tcs   | exactDCFlag cfg = Bare.dataDeclSize spec                     . Mb.mapMaybe tyConDataDecl                     -- . F.tracepp "makeHaskellDataDecls-3"-                    . zipMap   (hasDataDecl name spec . fst)+                    . zipMap   (hasDataDecl spec . fst)                     -- . F.tracepp "makeHaskellDataDecls-2"                     . liftableTyCons                     -- . F.tracepp "makeHaskellDataDecls-1"@@ -170,7 +182,7 @@ liftableTyCons :: [Ghc.TyCon] -> [(Ghc.TyCon, DataName)] liftableTyCons   = F.notracepp "LiftableTCs 3"-  . zipMapMaybe (tyConDataName True)+  . zipMapMaybe tyConDataName   . F.notracepp "LiftableTCs 2"   . filter   (not . Ghc.isBoxedTupleTyCon)   . F.notracepp "LiftableTCs 1"@@ -183,21 +195,15 @@ zipMapMaybe :: (a -> Maybe b) -> [a] -> [(a, b)] zipMapMaybe f = Mb.mapMaybe (\x -> (x, ) <$> f x) -hasDataDecl :: ModName -> Ms.BareSpec -> Ghc.TyCon -> HasDataDecl-hasDataDecl modName spec-                 = \tc -> F.notracepp (msg tc) $ M.lookupDefault defn (tcName tc) decls+hasDataDecl :: Ms.BareSpec -> Ghc.TyCon -> HasDataDecl+hasDataDecl spec+                 = \tc -> F.notracepp (msg tc) $ M.lookupDefault defn (tyConDataName tc) decls   where-    msg tc       = "hasDataDecl " ++ show (tcName tc)+    msg tc       = "hasDataDecl " ++ show (tyConDataName tc)     defn         = NoDecl Nothing-    tcName       = fmap (qualifiedDataName modName) . tyConDataName True-    dcName       =       qualifiedDataName modName  . tycName     decls        = M.fromList [ (Just dn, hasDecl d)                                 | d     <- Ms.dataDecls spec-                                , let dn = dcName d]--qualifiedDataName :: ModName -> DataName -> DataName-qualifiedDataName modName (DnName lx) = DnName (qualifyModName modName <$> lx)-qualifiedDataName modName (DnCon  lx) = DnCon  (qualifyModName modName <$> lx)+                                , let dn = tycName d]  {-tyConDataDecl :: {tc:TyCon | isAlgTyCon tc} -> Maybe DataDecl @-} tyConDataDecl :: ((Ghc.TyCon, DataName), HasDataDecl) -> Maybe DataDecl@@ -216,13 +222,12 @@       }       where decls = map dataConDecl . Ghc.tyConDataCons -tyConDataName :: Bool -> Ghc.TyCon -> Maybe DataName-tyConDataName full tc-  | vanillaTc  = Just (DnName (post . F.symbol <$> GM.locNamedThing tc))-  | d:_ <- dcs = Just (DnCon  (post . F.symbol <$> GM.locNamedThing d ))+tyConDataName :: Ghc.TyCon -> Maybe DataName+tyConDataName tc+  | vanillaTc  = Just $ DnName $ makeGHCLHNameLocated tc+  | d:_ <- dcs = Just $ DnCon $ makeGHCLHNameLocated d   | otherwise  = Nothing   where-    post       = if full then id else GM.dropModuleNamesAndUnique     vanillaTc  = Ghc.isVanillaAlgTyCon tc     dcs        = Misc.sortOn F.symbol (Ghc.tyConDataCons tc) @@ -231,8 +236,8 @@   where     isGadt        = not (Ghc.isVanillaDataCon d)     -- msg           = printf "dataConDecl (gadt = %s)" (show isGadt)-    xts           = [(Bare.makeDataConSelector Nothing d i, RT.bareOfType t) | (i, t) <- its ]-    dx            = F.symbol <$> GM.locNamedThing d+    xts           = [(makeGeneratedLogicLHName $ Bare.makeDataConSelector Nothing d i, RT.bareOfType t) | (i, t) <- its ]+    dx            = makeGHCLHNameLocated d     its           = zip [1..] ts     (as,_ps,ts,ty)  = Ghc.dataConSig d     outT          = Just (RT.bareOfType ty :: BareType)@@ -264,6 +269,7 @@       | isFunTy t && not (higherOrderFlag cfg)       = Nothing       | otherwise+        -- TODO: Use as origin module the module where the measure is created       = Just $ makeMeasureSelector (Loc l l' x) (projT i) dc n i      go' ((_,t), i)@@ -271,11 +277,11 @@       | isFunTy t && not (higherOrderFlag cfg)       = Nothing       | otherwise-      = Just $ makeMeasureSelector (Loc l l' (Bare.makeDataConSelector (Just dm) dc i)) (projT i) dc n i+      = Just $ makeMeasureSelector (Loc l l' (makeGeneratedLogicLHName $ Bare.makeDataConSelector (Just dm) dc i)) (projT i) dc n i      fields   = zip (reverse xts) [1..]     n        = length xts-    checker  = makeMeasureChecker (Loc l l' (Bare.makeDataConChecker dc)) checkT dc n+    checker  = makeMeasureChecker (Loc l l' (makeGeneratedLogicLHName $ Bare.makeDataConChecker dc)) checkT dc n     projT i  = dataConSel permitTC dc n (Proj i)     checkT   = dataConSel permitTC dc n Check     permitTC = typeclass cfg@@ -292,7 +298,7 @@     err                  = panic Nothing $ "DataCon " ++ show dc ++ "does not have " ++ show i ++ " fields"  -- bkDataCon :: DataCon -> Int -> ([RTVar RTyVar RSort], [SpecType], (Symbol, SpecType, RReft))-bkDataCon :: (F.Reftable (RTProp RTyCon RTyVar r), PPrint r, F.Reftable r) => Bool -> Ghc.DataCon -> Int -> ([RTVar RTyVar RSort], [RRType r], (F.Symbol, RFInfo, RRType r, r))+bkDataCon :: (Reftable (RTProp RTyCon RTyVar r), PPrint r, Reftable r) => Bool -> Ghc.DataCon -> Int -> ([RTVar RTyVar RSort], [RRType r], (F.Symbol, RFInfo, RRType r, r)) bkDataCon permitTC dcn nFlds  = (as, ts, (F.dummySymbol, classRFInfo permitTC, t, mempty))   where     ts                = RT.ofType <$> Misc.takeLast nFlds (map Ghc.irrelevantMult _ts)@@ -310,7 +316,7 @@ data DataConSel = Check | Proj Int  bareBool :: SpecType-bareBool = RApp (RTyCon Ghc.boolTyCon [] def) [] [] mempty+bareBool = RApp (RTyCon Ghc.boolTyCon [] defaultTyConInfo) [] [] mempty   {- | NOTE:Use DataconWorkId@@ -321,14 +327,14 @@  -} -makeMeasureSelector :: (Show a1) => LocSymbol -> SpecType -> Ghc.DataCon -> Int -> a1 -> Measure SpecType Ghc.DataCon+makeMeasureSelector :: (Show a1) => Located LHName -> SpecType -> Ghc.DataCon -> Int -> a1 -> Measure SpecType Ghc.DataCon makeMeasureSelector x s dc n i = M { msName = x, msSort = s, msEqns = [eqn], msKind = MsSelector, msUnSorted = mempty}   where     eqn                        = Def x dc Nothing args (E (F.EVar $ mkx i))     args                       = (, Nothing) . mkx <$> [1 .. n]     mkx j                      = F.symbol ("xx" ++ show j) -makeMeasureChecker :: LocSymbol -> SpecType -> Ghc.DataCon -> Int -> Measure SpecType Ghc.DataCon+makeMeasureChecker :: Located LHName -> SpecType -> Ghc.DataCon -> Int -> Measure SpecType Ghc.DataCon makeMeasureChecker x s0 dc n = M { msName = x, msSort = s, msEqns = eqn : (eqns <$> filter (/= dc) dcs), msKind = MsChecker, msUnSorted = mempty }   where     s       = F.notracepp ("makeMeasureChecker: " ++ show x) s0@@ -340,11 +346,11 @@   -----------------------------------------------------------------------------------------------makeMeasureSpec' :: Bool -> MSpec SpecType Ghc.DataCon -> ([(Ghc.Var, SpecType)], [(LocSymbol, RRType F.Reft)])+makeMeasureSpec' :: Bool -> MSpec SpecType Ghc.DataCon -> ([(Ghc.Var, SpecType)], [(Located LHName, RRType F.Reft)]) ---------------------------------------------------------------------------------------------- makeMeasureSpec' allowTC mspec0 = (ctorTys, measTys)   where-    ctorTys             = Misc.mapSnd RT.uRType <$> ctorTys0+    ctorTys             = fmap RT.uRType <$> ctorTys0     (ctorTys0, measTys) = Ms.dataConTypes allowTC mspec     mspec               = first (mapReft ur_reft) mspec0 @@ -353,53 +359,184 @@                    Bare.Lookup (Ms.MSpec SpecType Ghc.DataCon) ---------------------------------------------------------------------------------------------- makeMeasureSpec env sigEnv myName (name, spec)-  = mkMeasureDCon env               name-  . mkMeasureSort env               name+  = mkMeasureDCon env+  . mkMeasureSort env   . first val   . bareMSpec     env sigEnv myName name   $ spec -bareMSpec :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> Ms.BareSpec -> Ms.MSpec LocBareType LocSymbol-bareMSpec env sigEnv myName name spec = Ms.mkMSpec ms cms ims+--- Returns all the reflected symbols.+--- If Env is provided, the symbols are qualified using the environment.+getLocReflects :: Bare.ModSpecs -> S.HashSet F.Symbol+getLocReflects = S.unions . map names . M.elems   where-    cms        = F.notracepp "CMS" $ filter inScope1 $             Ms.cmeasures spec-    ms         = F.notracepp "UMS" $ filter inScope2 $ expMeas <$> Ms.measures  spec-    ims        = F.notracepp "IMS" $ filter inScope2 $ expMeas <$> Ms.imeasures spec-    expMeas    = expandMeasure env name  rtEnv+    names modSpec = unqualified modSpec+    unqualified modSpec = S.unions+      [ S.map (lhNameToResolvedSymbol . val) (Ms.reflects modSpec)+      , S.map val $ Ms.privateReflects modSpec+      , S.fromList (lhNameToResolvedSymbol . val . snd <$> Ms.asmReflectSigs modSpec)+      , S.fromList (lhNameToResolvedSymbol . val . fst <$> Ms.asmReflectSigs modSpec)+      , S.map (lhNameToResolvedSymbol . val) (Ms.inlines modSpec)+      , S.map (lhNameToResolvedSymbol . val) (Ms.hmeas modSpec)+      ]++-- Get all the symbols that are defined in the logic, based on the environment and the specs.+getDefinedSymbolsInLogic :: Bare.Env -> Bare.MeasEnv -> Bare.ModSpecs -> S.HashSet F.Symbol+getDefinedSymbolsInLogic env measEnv specs =+  S.unions (uncurry getFromAxioms <$> specsList) -- reflections that ended up in equations+    `S.union` getLocReflects specs -- reflected symbols+    `S.union` measVars -- Get the data constructors, ex. for Lit00.0+    `S.union` S.unions (getDataDecls . snd <$> specsList) -- get the Predicated type defs, ex. for T1669.CSemigroup+    `S.union` S.unions (getAliases . snd <$> specsList) -- aliases, ex. for T1738Lib.incr+  where+    specsList = M.toList specs+    getFromAxioms _modName spec = S.fromList $+      F.eqName <$> Ms.axeqs spec+    measVars     = S.fromList $ fst <$> getMeasVars env measEnv+    getDataDecls spec = S.unions $+      getFromDataCtor <$>+        concat (tycDCons `Mb.mapMaybe` (dataDecls spec ++ newtyDecls spec))+    getFromDataCtor decl = S.fromList $+      map lhNameToResolvedSymbol $ val (dcName decl) : (fst <$> dcFields decl)+    getAliases spec = S.fromList $ rtName . val <$> Ms.ealiases spec++-- Get the set of `DataCon`s (DCs) needed for the reflection of a given list of variables,+-- and which are not already present in the logic+getReflDCs :: Bare.MeasEnv -> [Ghc.Var] -> S.HashSet Ghc.DataCon+getReflDCs measEnv vars = dcsUndefinedInLogic+  where+    -- List of wired DCs that cannot be found in the measure environment as they are+    -- eliminated in the translation from core.+    -- Written as a list of symbols because that's easier than trying to get the corresponding DCs from GHC.+    wired = S.fromList $ F.symbol <$> ["GHC.Types.True", "GHC.Types.False", "GHC.Types.I#"]+    notWired dc = not $ GM.qualifiedNameSymbol (Ghc.getName dc) `S.member` wired+    -- Undefined ones are those that are not already defined in the measure environement and are not wired+    dcsUndefinedInLogic = S.filter notWired $ allDCInUnfoldings `S.difference` definedDCs+    -- Get the defined DataCons from the measure environement+    definedDCs = S.fromList $ (GM.idDataConM . fst) `Mb.mapMaybe` Bare.meDataCons measEnv+    allDCInUnfoldings = getDCsOfUnfoldingOfVars vars++----------------------------------------------------+-- Looks at the given list of equations and finds any undefined symbol in the logic,+-- for which we need to introduce an opaque reflection.+-- Returns the corresponding measures. Second part of the returned tuple is the information to save+-- to the `meOpaqueRefl` field of the measure environment.+makeOpaqueReflMeasures :: Bare.Env -> Bare.MeasEnv -> Bare.ModSpecs ->+              [(Ghc.Var, LocSpecType, F.Equation)] ->+              ([MSpec SpecType Ghc.DataCon], [(Ghc.Var, Measure LocBareType ctor)])+makeOpaqueReflMeasures env measEnv specs eqs =+  unzip $ createMeasureForVar <$> S.toList (varsUndefinedInLogic `S.union` requestedOpaqueRefl)+  where+    thisModule = Ghc.tcg_mod (Bare.reTcGblEnv env)+    -- Get the set of variables for the requested opaque reflections+    requestedOpaqueRefl = S.unions+      . map (S.map getVar . Ms.opaqueReflects . snd)+      . M.toList $ specs+    getVar sym = case Bare.lookupGhcIdLHName env sym of+      Right x -> x+      Left _ -> panic (Just $ GM.fSrcSpan sym) "function to reflect not in scope"+    definedSymbols = getDefinedSymbolsInLogic env measEnv specs+    undefinedInLogic v = not (S.member (F.symbol v) definedSymbols)+    -- Variables to consider+    varsUndefinedInLogic = S.unions $+      S.filter undefinedInLogic .+      (\(v, _, eq) -> getFreeVarsOfReflectionOfVar v eq) <$> eqs+    -- Main function: creates a (dummy) measure about a given variable+    createMeasureForVar :: Ghc.Var -> (MSpec SpecType Ghc.DataCon, (Ghc.Var, Measure LocBareType ctor))+    createMeasureForVar var =+      (Ms.mkMSpec' [smeas], (var, bmeas))+      where+        locSym = F.atLoc (loc specType) (reflectLHName thisModule $ makeGHCLHNameFromId var)+        specType = varSpecType var+        bareType = varBareType var+        bmeas = M locSym bareType [] MsReflect []+        smeas = M locSym (val specType) [] MsReflect []++getUnfoldingOfVar :: Ghc.Var -> Maybe Ghc.CoreExpr+getUnfoldingOfVar = getExpr . Ghc.realUnfoldingInfo . Ghc.idInfo+  where+    getExpr :: Ghc.Unfolding -> Maybe Ghc.CoreExpr+    getExpr (Ghc.CoreUnfolding expr _ _ _ _) = Just expr+    getExpr _ = Nothing++-- Get the set of "free" symbols in the (reflection of the) unfolding of a given variable.+-- Free symbols are those that are not already in the logic and that appear in+-- the reflection of the unfolding.+-- For this purpose, you need to give the variable naming the definition to reflect+-- and its corresponding equation in the logic.+getFreeVarsOfReflectionOfVar  :: Ghc.Var -> F.Equation -> S.HashSet Ghc.Var+getFreeVarsOfReflectionOfVar var eq =+    S.filter (\v -> F.symbol v `S.member` freeSymbolsInReflectedBody) freeVarsInCoreExpr+  where+    reflExpr = getUnfoldingOfVar var+    getAllFreeVars = Ghc.exprSomeFreeVarsList (const True)+    freeVarsInCoreExpr = maybe S.empty (S.fromList . getAllFreeVars) reflExpr+    freeSymbolsInReflectedBody = F.exprSymbolsSet (F.eqBody eq)++-- Collect all the DataCon that appear in the unfolding of a given variable.+getDCsOfUnfoldingOfVars :: [Ghc.Var] -> S.HashSet Ghc.DataCon+getDCsOfUnfoldingOfVars vars = S.unions $ collectDataCons <$> getUnfoldingOfVar `Mb.mapMaybe` vars++-- Collect all DataCon that occur in case split alternatives of an expression+collectDataCons :: Ghc.CoreExpr -> S.HashSet Ghc.DataCon+collectDataCons expr = go expr S.empty+  where+    go (Ghc.Var _) acc = acc+    go (Ghc.Lit _) acc = acc+    go (Ghc.App f e) acc = go f (go e acc)+    go (Ghc.Lam _ e) acc = go e acc+    go (Ghc.Let bind e) acc = go e (goBind bind acc)+    go (Ghc.Case e _ _ alts) acc = foldr goAlt (go e acc) alts+    go (Ghc.Cast e _) acc = go e acc+    go (Ghc.Tick _ e) acc = go e acc+    go (Ghc.Type _) acc = acc+    go (Ghc.Coercion _) acc = acc++    -- Special auxiliary function for `Alt` which is precisely where we get the datacons+    goAlt (Ghc.Alt (Ghc.DataAlt dc) _ e) acc = S.insert dc (go e acc)+    goAlt (Ghc.Alt _ _ e) acc = go e acc++    goBind (Ghc.NonRec _ e) acc = go e acc+    goBind (Ghc.Rec binds) acc = foldr (go . snd) acc binds++bareMSpec :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> Ms.BareSpec -> Ms.MSpec LocBareType (Located LHName)+bareMSpec env sigEnv myName name spec = Ms.mkMSpec ms cms ims oms+  where+    cms        = F.notracepp "CMS" $ filter inScope $             Ms.cmeasures spec+    ms         = F.notracepp "UMS" $ filter inScope $ expMeas <$> Ms.measures  spec+    ims        = F.notracepp "IMS" $ filter inScope $ expMeas <$> Ms.imeasures spec+    oms        = F.notracepp "OMS" $ filter inScope $ expMeas <$> Ms.omeasures spec+    expMeas    = expandMeasure rtEnv     rtEnv      = Bare.sigRTEnv          sigEnv     force      = name == myName-    inScope1 z = F.notracepp ("inScope1: " ++ F.showpp (msName z)) (force ||  okSort z)-    inScope2 z = F.notracepp ("inScope2: " ++ F.showpp (msName z)) (force || (okSort z && okCtors z))-    okSort     = Bare.knownGhcType env name . msSort-    okCtors    = all (Bare.knownGhcDataCon env name . ctor) . msEqns+    inScope z = F.notracepp ("inScope1: " ++ F.showpp (msName z)) (force ||  okSort z)+    okSort     = Bare.knownGhcType env . msSort -mkMeasureDCon :: Bare.Env -> ModName -> Ms.MSpec t LocSymbol -> Bare.Lookup (Ms.MSpec t Ghc.DataCon)-mkMeasureDCon env name m = do+mkMeasureDCon :: Bare.Env -> Ms.MSpec t (F.Located LHName) -> Bare.Lookup (Ms.MSpec t Ghc.DataCon)+mkMeasureDCon env m = do   let ns = measureCtors m-  dcs   <- mapM (Bare.lookupGhcDataCon env name "measure-datacon") ns+  dcs   <- mapM (Bare.lookupGhcDataConLHName env) ns   return $ mkMeasureDCon_ m (zip (val <$> ns) dcs)  -- mkMeasureDCon env name m = mkMeasureDCon_ m [ (val n, symDC n) | n <- measureCtors m ] --   where --     symDC                = Bare.lookupGhcDataCon env name "measure-datacon" -mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(F.Symbol, Ghc.DataCon)] -> Ms.MSpec t Ghc.DataCon-mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}+mkMeasureDCon_ :: Ms.MSpec t (F.Located LHName) -> [(LHName, Ghc.DataCon)] -> Ms.MSpec t Ghc.DataCon+mkMeasureDCon_ m ndcs = fmap (tx . val) m   where-    m'                = fmap (tx.val) m-    cm'               = Misc.hashMapMapKeys (F.symbol . tx) $ Ms.ctorMap m'     tx                = Misc.mlookup (M.fromList ndcs) -measureCtors ::  Ms.MSpec t LocSymbol -> [LocSymbol]+measureCtors ::  Ms.MSpec t (F.Located LHName) -> [F.Located LHName] measureCtors = Misc.sortNub . fmap ctor . concat . M.elems . Ms.ctorMap -mkMeasureSort :: Bare.Env -> ModName -> Ms.MSpec BareType LocSymbol-              -> Ms.MSpec SpecType LocSymbol-mkMeasureSort env name (Ms.MSpec c mm cm im) =+mkMeasureSort :: Bare.Env -> Ms.MSpec BareType (F.Located LHName)+              -> Ms.MSpec SpecType (F.Located LHName)+mkMeasureSort env (Ms.MSpec c mm cm im) =   Ms.MSpec (map txDef <$> c) (tx <$> mm) (tx <$> cm) (tx <$> im)     where       ofMeaSort :: F.SourcePos -> BareType -> SpecType-      ofMeaSort l = Bare.ofBareType env name l Nothing+      ofMeaSort l = Bare.ofBareType env l Nothing        tx :: Measure BareType ctor -> Measure SpecType ctor       tx (M n s eqs k u) = M n (ofMeaSort l s) (txDef <$> eqs) k u where l = GM.fSourcePos n@@ -414,15 +551,15 @@ -------------------------------------------------------------------------------- -- type BareMeasure = Measure LocBareType LocSymbol -expandMeasure :: Bare.Env -> ModName -> BareRTEnv -> BareMeasure -> BareMeasure-expandMeasure env name rtEnv m = m-  { msSort = RT.generalize                   <$> msSort m-  , msEqns = expandMeasureDef env name rtEnv <$> msEqns m+expandMeasure :: BareRTEnv -> BareMeasure -> BareMeasure+expandMeasure rtEnv m = m+  { msSort = RT.generalize <$> msSort m+  , msEqns = expandMeasureDef rtEnv <$> msEqns m   } -expandMeasureDef :: Bare.Env -> ModName -> BareRTEnv -> Def t LocSymbol -> Def t LocSymbol-expandMeasureDef env name rtEnv d = d-  { body  = F.notracepp msg $ Bare.qualifyExpand env name rtEnv l bs (body d) }+expandMeasureDef :: BareRTEnv -> Def t (Located LHName) -> Def t (Located LHName)+expandMeasureDef rtEnv d = d+  { body  = F.notracepp msg $ Bare.expand rtEnv l (body d) }   where     l     = loc (measure d)     bs    = fst <$> binds d@@ -433,23 +570,29 @@ ------------------------------------------------------------------------------ varMeasures env =   [ (F.symbol v, varSpecType v)-      | v <- knownVars env+      | v <- Bare.reDataConIds env       , GM.isDataConId v       , isSimpleType (Ghc.varType v) ] -knownVars :: Bare.Env -> [Ghc.Var]-knownVars env = [ v | (_, xThings)   <- M.toList (Bare._reTyThings env)-                    , (_,Ghc.AnId v) <- xThings-                ]+getMeasVars :: Bare.Env -> Bare.MeasEnv -> [(F.Symbol, Located (RRType F.Reft))]+getMeasVars env measEnv = Bare.meSyms measEnv -- ms'+                            ++ Bare.meClassSyms measEnv -- cms'+                            ++ varMeasures env  varSpecType :: (Monoid r) => Ghc.Var -> Located (RRType r) varSpecType = fmap (RT.ofType . Ghc.varType) . GM.locNamedThing +varBareType :: (Monoid r) => Ghc.Var -> Located (BRType r)+varBareType = fmap (RT.bareOfType . Ghc.varType) . GM.locNamedThing++varLocSym :: Ghc.Var -> LocSymbol+varLocSym v = F.symbol <$> GM.locNamedThing v+ isSimpleType :: Ghc.Type -> Bool isSimpleType = isFirstOrder . RT.typeSort mempty  makeClassMeasureSpec :: MSpec (RType c tv (UReft r2)) t-                     -> [(LocSymbol, CMeasure (RType c tv r2))]+                     -> [(Located LHName, CMeasure (RType c tv r2))] makeClassMeasureSpec Ms.MSpec{..} = tx <$> M.elems cmeasMap   where     tx (M n s _ _ _) = (n, CM n (mapReft ur_reft s))
src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -15,7 +15,7 @@  import           Prelude                               hiding (error) -import           Liquid.GHC.API       as Ghc  hiding (Located, showPpr)+import           Liquid.GHC.API       as Ghc  hiding (Located, get, showPpr)  import           Control.Monad                         (zipWithM_) import           Control.Monad.Except                  (MonadError, throwError)@@ -27,6 +27,7 @@ import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType import           Language.Haskell.Liquid.Types.Types  -- import           Language.Haskell.Liquid.Bare.Env@@ -53,7 +54,7 @@  {- HEAD-freeSymbols :: (F.Reftable r, F.Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2)+freeSymbols :: (Reftable r, Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2)             => [F.Symbol]             -> [(a1, Located (RType c2 tv2 r2))]             -> [(a, Located (RType c1 tv1 r1))]@@ -69,18 +70,18 @@   --------------------------------------------------------------------------------freeSyms :: (F.Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol]+freeSyms :: (Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol] ------------------------------------------------------------------------------- freeSyms ty    = [ F.atLoc ty x | x <- tySyms ]   where     tySyms     = Misc.sortNub $ concat $ efoldReft (\_ _ -> True) False (\_ _ -> []) (const []) (const ()) f (const id) F.emptySEnv [] (val ty)-    f γ _ r xs = let F.Reft (v, _) = F.toReft r in+    f γ _ r xs = let F.Reft (v, _) = toReft r in                  [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs  --- ABOVE IS THE T1773 STUFF --- BELOW IS THE develop-classes STUFF --- freeSymbols :: (F.Reftable r, F.Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2)+-- freeSymbols :: (Reftable r, Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2) --             => [F.Symbol] --             -> [(a1, Located (RType c2 tv2 r2))] --             -> [(a, Located (RType c1 tv1 r1))]@@ -95,11 +96,11 @@   --- freeSyms :: (F.Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol]+-- freeSyms :: (Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol] -- freeSyms ty    = [ F.atLoc ty x | x <- tySyms ] --   where --     tySyms     = Misc.sortNub $ concat $ efoldReft (\_ _ -> True) False (\_ _ -> []) (\_ -> []) (const ()) f (const id) F.emptySEnv [] (val ty)---     f γ _ r xs = let F.Reft (v, _) = F.toReft r in+--     f γ _ r xs = let F.Reft (v, _) = toReft r in --                  [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs  -}
src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -10,6 +10,7 @@   ) where  import Prelude hiding (error)+import qualified Data.Bifunctor as Bifunctor import Data.Generics.Aliases (mkT) import Data.Generics.Schemes (everywhere) @@ -24,8 +25,13 @@ import qualified Language.Haskell.Liquid.GHC.Misc  as GM import qualified Liquid.GHC.API   as Ghc import           Language.Haskell.Liquid.GHC.Types (StableName, mkStableName)-import           Language.Haskell.Liquid.Types.RefType ()-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types import qualified Language.Haskell.Liquid.Misc       as Misc import qualified Language.Haskell.Liquid.Bare.Types as Bare import qualified Language.Haskell.Liquid.Bare.Misc  as Bare@@ -133,17 +139,19 @@ plugMany :: Bool -> F.TCEmb Ghc.TyCon -> Bare.TyConMap          -> Located DataConP          -> ([Ghc.Var], [Ghc.Type],             Ghc.Type)   -- ^ hs type-         -> ([RTyVar] , [(F.Symbol, SpecType)], SpecType)   -- ^ lq type-         -> ([(F.Symbol, SpecType)], SpecType)              -- ^ plugged lq type+         -> ([RTyVar] , [(LHName, SpecType)], SpecType)   -- ^ lq type+         -> ([(LHName, SpecType)], SpecType)              -- ^ plugged lq type plugMany allowTC embs tyi ldcp (hsAs, hsArgs, hsRes) (lqAs, lqArgs, lqRes)-                     = F.notracepp msg (drop nTyVars (zip xs ts), t)+                     = F.notracepp msg (drop nTyVars (zip (map lookupLHName xs) ts), t)   where+    lookupLHName s   = Mb.fromMaybe (panic (Just (GM.fSrcSpan ldcp)) $ "unexpected symbol: " ++ show s) $ lookup s lhNameMap+    lhNameMap        = [ (lhNameToUnqualifiedSymbol n, n) | n <- map fst lqArgs ]     ((xs,_,ts,_), t) = bkArrow (val pT)     pT               = plugHoles allowTC (Bare.LqTV dcName) embs tyi (const killHoles) hsT (F.atLoc ldcp lqT)     hsT              = foldr (Ghc.mkFunTy Ghc.FTF_T_T Ghc.ManyTy) hsRes hsArgs'     lqT              = foldr (uncurry (rFun' (classRFInfo allowTC))) lqRes lqArgs'     hsArgs'          = [ Ghc.mkTyVarTy a               | a <- hsAs] ++ hsArgs-    lqArgs'          = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ lqArgs+    lqArgs'          = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ map (Bifunctor.first lhNameToUnqualifiedSymbol) lqArgs     nTyVars          = length hsAs -- == length lqAs     dcName           = Ghc.dataConName . dcpCon . val $ ldcp     msg              = "plugMany: " ++ F.showpp (dcName, hsT, lqT)
src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ConstraintKinds       #-}@@ -14,29 +13,26 @@ module Language.Haskell.Liquid.Bare.Resolve   ( -- * Creating the Environment     makeEnv+  , makeLocalVars+  , makeGHCTyLookupEnv+  , GHCTyLookupEnv(..)      -- * Resolving symbols-  , ResolveSym (..)-  , Qualify (..)   , Lookup-  , qualifyTop, qualifyTopDummy    -- * Looking up names-  , maybeResolveSym-  , lookupGhcDataCon+  , lookupGhcDataConLHName   , lookupGhcDnTyCon-  , lookupGhcTyCon-  , lookupGhcVar-  , lookupGhcNamedVar+  , lookupGhcIdLHName+  , lookupLocalVar+  , lookupGhcTyConLHName+  , lookupGhcTyThingFromName+  , lookupGhcId    -- * Checking if names exist-  , knownGhcVar-  , knownGhcTyCon-  , knownGhcDataCon   , knownGhcType    -- * Misc-  , srcVars   , coSubRReft   , unQualifySymbol @@ -55,28 +51,36 @@   ) where  import qualified Control.Exception                 as Ex-import           Control.Monad (mplus)+import           Data.Bifunctor (first)+import           Data.Function (on)+import           Data.IORef (newIORef) import qualified Data.List                         as L import qualified Data.HashSet                      as S import qualified Data.Maybe                        as Mb import qualified Data.HashMap.Strict               as M-import qualified Data.Text                         as T+import           GHC.Stack+import           Text.Megaparsec.Pos (sourceColumn, sourceLine) import qualified Text.PrettyPrint.HughesPJ         as PJ  import qualified Language.Fixpoint.Types               as F import qualified Language.Fixpoint.Types.Visitor       as F import qualified Language.Fixpoint.Misc                as Misc import qualified Liquid.GHC.API       as Ghc+import qualified Language.Haskell.Liquid.GHC.Interface as Interface import qualified Language.Haskell.Liquid.GHC.Misc      as GM import qualified Language.Haskell.Liquid.Misc          as Misc+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import qualified Language.Haskell.Liquid.Types.RefType as RT import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Measure       (BareSpec)-import           Language.Haskell.Liquid.Types.Specs   hiding (BareSpec)+import           Language.Haskell.Liquid.Types.Specs import           Language.Haskell.Liquid.Types.Visitors import           Language.Haskell.Liquid.Bare.Types-import           Language.Haskell.Liquid.Bare.Misc-import           Language.Haskell.Liquid.WiredIn+import           Language.Haskell.Liquid.UX.Config+import           System.IO.Unsafe (unsafePerformIO)  myTracepp :: (F.PPrint a) => String -> a -> a myTracepp = F.notracepp@@ -87,23 +91,22 @@ ------------------------------------------------------------------------------- -- | Creating an environment --------------------------------------------------------------------------------makeEnv :: Config -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env-makeEnv cfg src lmap specs = RE-  { reLMap      = lmap-  , reSyms      = syms-  , _reSubst    = makeVarSubst   src-  , _reTyThings = makeTyThingMap src-  , reQualImps  = _gsQualImps     src-  , reAllImps   = _gsAllImps      src-  , reLocalVars = makeLocalVars  src+makeEnv :: Config -> GHCTyLookupEnv -> [Ghc.Id] -> Ghc.TcGblEnv -> Ghc.InstEnvs -> LocalVars -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env+makeEnv cfg ghcTyLookupEnv dataConIds tcg instEnv localVars src lmap specs = RE+  { reTyLookupEnv = ghcTyLookupEnv+  , reTcGblEnv  = tcg+  , reInstEnvs = instEnv+  , reUsedExternals = usedExternals+  , reLMap      = lmap+  , reDataConIds = dataConIds+  , reLocalVars = localVars   , reSrc       = src   , reGlobSyms  = S.fromList     globalSyms   , reCfg       = cfg   }   where     globalSyms  = concatMap getGlobalSyms specs-    syms        = [ (F.symbol v, v) | v <- vars ]-    vars        = srcVars src+    usedExternals = Ghc.exprsOrphNames $ map snd $ Ghc.flattenBinds $ _giCbs src  getGlobalSyms :: (ModName, BareSpec) -> [F.Symbol] getGlobalSyms (_, spec)@@ -111,38 +114,65 @@        $ (mbName <$> measures  spec)       ++ (mbName <$> cmeasures spec)       ++ (mbName <$> imeasures spec)+      ++ (mbName <$> omeasures spec)   where-    mbName = F.val . msName+    mbName = lhNameToResolvedSymbol . F.val . msName -makeLocalVars :: GhcSrc -> LocalVars-makeLocalVars = localVarMap . localBinds . _giCbs+makeLocalVars :: [Ghc.CoreBind] -> LocalVars+makeLocalVars = localVarMap . localBinds  -- TODO: rewrite using CoreVisitor-localBinds :: [Ghc.CoreBind] -> [Ghc.Var]-localBinds                    = concatMap (bgo S.empty)+localBinds :: [Ghc.CoreBind] -> [LocalVarDetails]+localBinds                    = concatMap (bgoT [])   where-    add  x g                  = maybe g (`S.insert` g) (localKey x)-    adds b g                  = foldr add g (Ghc.bindersOf b)-    take' x g                 = maybe [] (\k -> [x | not (S.member k g)]) (localKey x)-    pgo g (x, e)              = take' x g ++ go (add x g) e-    bgo g (Ghc.NonRec x e)    = pgo g (x, e)-    bgo g (Ghc.Rec xes)       = concatMap (pgo g) xes-    go  g (Ghc.App e a)       = concatMap (go  g) [e, a]-    go  g (Ghc.Lam _ e)       = go g e-    go  g (Ghc.Let b e)       = bgo g b ++ go (adds b g) e-    go  g (Ghc.Tick _ e)      = go g e-    go  g (Ghc.Cast e _)      = go g e-    go  g (Ghc.Case e _ _ cs) = go g e ++ concatMap (go g . (\(Ghc.Alt _ _ e') -> e')) cs-    go  _ (Ghc.Var _)         = []-    go  _ _                   = []+    bgoT g (Ghc.NonRec _ e) = go g e+    bgoT g (Ghc.Rec xes)    = concatMap (go g . snd) xes+    pgo g isRec (x, e)      = mkLocalVarDetails g isRec x : go g e+    bgo g (Ghc.NonRec x e)  = pgo g False (x, e)+    bgo g (Ghc.Rec xes)     = concatMap (pgo g True) xes+    go g (Ghc.App e a)       = concatMap (go g) [e, a]+    go g (Ghc.Lam x e)       = go (x:g) e+    go g (Ghc.Let b e)       = bgo g b ++ go (Ghc.bindersOf b ++ g) e+    go g (Ghc.Tick _ e)      = go g e+    go g (Ghc.Cast e _)      = go g e+    go g (Ghc.Case e _ _ cs) = go g e ++ concatMap (\(Ghc.Alt _ bs e') -> go (bs ++ g) e') cs+    go _ (Ghc.Var _)         = []+    go _ _                   = [] -localVarMap :: [Ghc.Var] -> LocalVars-localVarMap vs =-  Misc.group [ (x, (i, v)) | v <- vs-                           , let i = F.unPos (F.srcLine v)-                           , x <- Mb.maybeToList (localKey v)-             ]+    mkLocalVarDetails g isRec v = LocalVarDetails+      { lvdSourcePos = F.sp_start $ F.srcSpan v+      , lvdVar = v+      , lvdLclEnv = g+      , lvdIsRec = isRec+      } +localVarMap :: [LocalVarDetails] -> LocalVars+localVarMap lvds =+    LocalVars+      { lvSymbols = Misc.group+          [ (x, lvd)+          | lvd <- lvds+          , let v = lvdVar lvd+                x = F.symbol $ Ghc.occNameString $ Ghc.nameOccName $ Ghc.varName v+          ]+      , lvNames = Ghc.mkNameEnvWith (Ghc.getName . lvdVar) lvds+      }++makeGHCTyLookupEnv :: Ghc.CoreProgram -> Ghc.TcRn GHCTyLookupEnv+makeGHCTyLookupEnv cbs = do+    hscEnv <- Ghc.getTopEnv+    session <- Ghc.Session <$> Ghc.liftIO (newIORef hscEnv)+    tcg <- Ghc.getGblEnv+      -- Types differ in tcg_type_env vs the core bindings though they seem to+      -- be alpha-equivalent. We prefer the type in the core bindings and we+      -- also include the types of local variables.+    let varsEnv = Ghc.mkTypeEnv $ map Ghc.AnId $ letVars cbs+        typeEnv = Ghc.tcg_type_env tcg `Ghc.plusTypeEnv` varsEnv+    return GHCTyLookupEnv+      { gtleSession = session+      , gtleTypeEnv = typeEnv+      }+ localKey   :: Ghc.Var -> Maybe F.Symbol localKey v   | isLocal m = Just x@@ -150,370 +180,96 @@   where     (m, x)    = splitModuleNameExact . GM.dropModuleUnique . F.symbol $ v -makeVarSubst :: GhcSrc -> F.Subst-makeVarSubst src = F.mkSubst unqualSyms-  where-    unqualSyms   = [ (x, mkVarExpr v)-                       | (x, mxs) <- M.toList (makeSymMap src)-                       , not (isWiredInName x)-                       , v <- Mb.maybeToList (okUnqualified me mxs)-                   ]-    me           = F.symbol (_giTargetMod src)---- | @okUnqualified mod mxs@ takes @mxs@ which is a list of modulenames-var---   pairs all of which have the same unqualified symbol representation.---   The function returns @Just v@ if---   1. that list is a singleton i.e. there is a UNIQUE unqualified version, OR---   2. there is a version whose module equals @me@.--okUnqualified :: F.Symbol -> [(F.Symbol, a)] -> Maybe a-okUnqualified _ [(_, x)] = Just x-okUnqualified me mxs     = go mxs-  where-    go []                = Nothing-    go ((m,x) : rest)-      | me == m          = Just x-      | otherwise        = go rest---makeSymMap :: GhcSrc -> M.HashMap F.Symbol [(F.Symbol, Ghc.Var)]-makeSymMap src = Misc.group [ (sym, (m, x))-                                | x           <- srcVars src-                                , let (m, sym) = qualifiedSymbol x ]--makeTyThingMap :: GhcSrc -> TyThingMap-makeTyThingMap src =-  addListTyConName $-  Misc.group [ (x, (m, t))  | t         <- srcThings src-                            , tSym      <- Mb.maybeToList (tyThingSymbol t)-                            , let (m, x) = qualifiedSymbol tSym-                            , not (isLocal m)-             ]-  where-    -- We add the TyThing for the List constructor here. Otherwise, we-    -- lookups in the TyThingMap will fail for "List" and not for "[]".-    addListTyConName m =-      case M.lookup "[]" m of-        Nothing -> m-        Just ps -> M.insertWith (++) "List" (filterListTyCon ps) m--    -- The TyCon name in the TyThing for @"[]"@ must be @"[]"@ apparently.-    ---    -- listTyCon uses "List", and that made later checks fail for some tests,-    -- so we cannot just return @[("GHC.Types", ATyCon listTyCon)]@-    ---    -- Returning the TyCon that GHC yields for @"[]"@ has later tests fail,-    -- because that TyCon has no associated data constructors.-    ---    -- The solution we adopted for now is to return listTyCon, and use-    -- the name from the TyThing that GHC returned.-    filterListTyCon ps =-      [ (mn, Ghc.ATyCon tc') | (mn, Ghc.ATyCon tc) <- ps-          , "GHC.Types" == mn-          , let tc' = Ghc.listTyCon { Ghc.tyConName = Ghc.tyConName tc }-      ]--tyThingSymbol :: Ghc.TyThing -> Maybe F.Symbol-tyThingSymbol (Ghc.AnId     x) = Just (F.symbol x)-tyThingSymbol (Ghc.ATyCon   c) = Just (F.symbol c)-tyThingSymbol (Ghc.AConLike d) = conLikeSymbol d-tyThingSymbol _tt              = Nothing -- panic Nothing ("TODO: tyThingSymbol" ++ showPpr tt)---conLikeSymbol :: Ghc.ConLike -> Maybe F.Symbol-conLikeSymbol (Ghc.RealDataCon d) = Just (F.symbol d)-conLikeSymbol _z                   = Nothing -- panic Nothing ("TODO: conLikeSymbol -- " ++ showPpr z)---- isLocal :: F.Symbol -> Bool isLocal = isEmptySymbol -qualifiedSymbol :: (F.Symbolic a) => a -> (F.Symbol, F.Symbol)-qualifiedSymbol = splitModuleNameExact . F.symbol- isEmptySymbol :: F.Symbol -> Bool isEmptySymbol x = F.lengthSym x == 0 -srcThings :: GhcSrc -> [Ghc.TyThing]-srcThings src = myTracepp "SRCTHINGS"-              $ Misc.hashNubWith F.showpp (_gsTyThings src ++ mySrcThings src)--mySrcThings :: GhcSrc -> [Ghc.TyThing]-mySrcThings src = [ Ghc.AnId   x | x <- vars ]-               ++ [ Ghc.ATyCon c | c <- tcs  ]-               ++ [ aDataCon   d | d <- dcs  ]-  where-    vars        = Misc.sortNub $ dataConVars dcs ++ srcVars  src-    dcs         = Misc.sortNub $ concatMap Ghc.tyConDataCons tcs-    tcs         = Misc.sortNub $ srcTyCons src-    aDataCon    = Ghc.AConLike . Ghc.RealDataCon--srcTyCons :: GhcSrc -> [Ghc.TyCon]-srcTyCons src = concat-  [ _gsTcs     src-  , _gsFiTcs   src-  , _gsPrimTcs src-  , srcVarTcs src-  ]--srcVarTcs :: GhcSrc -> [Ghc.TyCon]-srcVarTcs = varTyCons . srcVars--varTyCons :: [Ghc.Var] -> [Ghc.TyCon]-varTyCons = concatMap (typeTyCons . Ghc.dropForAlls . Ghc.varType)--typeTyCons :: Ghc.Type -> [Ghc.TyCon]-typeTyCons t = tops t ++ inners t-  where-    tops     = Mb.maybeToList . Ghc.tyConAppTyCon_maybe-    inners   = concatMap typeTyCons . snd . Ghc.splitAppTys---- | We prioritize the @Ghc.Var@ in @srcVars@ because @_giDefVars@ and @gsTyThings@---   have _different_ values for the same binder, with different types where the---   type params are alpha-renamed. However, for absref, we need _the same_---   type parameters as used by GHC as those are used inside the lambdas and---   other bindings in the code. See also [NOTE: Plug-Holes-TyVars] and---      tests-absref-pos-Papp00.hs--srcVars :: GhcSrc -> [Ghc.Var]-srcVars src = filter Ghc.isId .  fmap Misc.thd3 . Misc.fstByRank $ concat-  [ key "SRC-VAR-DEF" 0 <$> _giDefVars src-  , key "SRC-VAR-DER" 1 <$> S.toList (_giDerVars src)-  , key "SRC-VAR-IMP" 2 <$> _giImpVars src-  , key "SRC-VAR-USE" 3 <$> _giUseVars src-  , key "SRC-VAR-THN" 4 <$> [ x | Ghc.AnId x <- _gsTyThings src ]-  ]-  where-    key :: String -> Int -> Ghc.Var -> (Int, F.Symbol, Ghc.Var)-    key _ i x  = (i, F.symbol x, {- dump s -} x)-    _dump msg x = fst . myTracepp msg $ (x, RT.ofType (Ghc.expandTypeSynonyms (Ghc.varType x)) :: SpecType)--dataConVars :: [Ghc.DataCon] -> [Ghc.Var]-dataConVars dcs = (Ghc.dataConWorkId <$> dcs) ++ (Ghc.dataConWrapId <$> dcs)------------------------------------------------------------------------------------ | Qualify various names---------------------------------------------------------------------------------qualifyTop :: (Qualify a) => Env -> ModName -> F.SourcePos -> a -> a-qualifyTop env name l = qualify env name l []--qualifyTopDummy :: (Qualify a) => Env -> ModName -> a -> a-qualifyTopDummy env name = qualifyTop env name dummySourcePos--dummySourcePos :: F.SourcePos-dummySourcePos = F.loc (F.dummyLoc ())--class Qualify a where-  qualify :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a--instance Qualify TyConMap where-  qualify env name l bs tyi = tyi-    { tcmTyRTy = tx <$> tcmTyRTy tyi-    , tcmFIRTy = tx <$> tcmFIRTy tyi-    }-    where-      tx :: (Qualify a) => a -> a-      tx = qualify env name l bs--instance Qualify TyConP where-  qualify env name _ bs tcp = tcp { tcpSizeFun = qualify env name (tcpLoc tcp) bs <$> tcpSizeFun tcp }--instance Qualify SizeFun where-  qualify env name _ bs (SymSizeFun lx) = SymSizeFun (qualify env name (F.loc lx) bs lx)-  qualify _   _    _ _  sf              = sf--instance Qualify F.Equation where-  qualify _env _name _l _bs x = x -- TODO-REBARE--- REBARE: qualifyAxiomEq :: Bare.Env -> Var -> Subst -> AxiomEq -> AxiomEq--- REBARE: qualifyAxiomEq v su eq = subst su eq { eqName = symbol v}--instance Qualify F.Symbol where-  qualify env name l bs x = qualifySymbol env name l bs x+-- | @lookupLocalVar@ takes as input the list of "global" (top-level) vars+--   that also match the name @lx@; we then pick the "closest" definition.+--   See tests/names/LocalSpec.hs for a motivating example. -qualifySymbol :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> F.Symbol -> F.Symbol-qualifySymbol env name l bs x-  | isSpl     = x-  | otherwise = case resolveLocSym env name "Symbol" (F.Loc l l x) of-                  Left _ -> x-                  Right v -> v+lookupLocalVar :: F.Loc a => LocalVars -> LocSymbol -> [a] -> Maybe (Either a Ghc.Var)+lookupLocalVar localVars lx gvs = findNearest lxn kvs   where-    isSpl     = isSplSymbol env bs x--isSplSymbol :: Env -> [F.Symbol] -> F.Symbol -> Bool-isSplSymbol env bs x-  =  isWiredInName x-  || elem x bs-  || S.member x (reGlobSyms env)--instance (Qualify a) => Qualify (Located a) where-  qualify env name l bs = fmap (qualify env name l bs)--instance (Qualify a) => Qualify [a] where-  qualify env name l bs = fmap (qualify env name l bs)--instance (Qualify a) => Qualify (Maybe a) where-  qualify env name l bs = fmap (qualify env name l bs)+    kvs                   = prioritizeRecBinds (M.lookupDefault [] x (lvSymbols localVars)) ++ gs+    gs                    = [(F.sp_start $ F.srcSpan v, Left v) | v <- gvs]+    lxn                   = F.sp_start $ F.srcSpan lx+    (_, x)                = unQualifySymbol (F.val lx) -instance Qualify Body where-  qualify env name l bs (P   p) = P   (qualify env name l bs p)-  qualify env name l bs (E   e) = E   (qualify env name l bs e)-  qualify env name l bs (R x p) = R x (qualify env name l bs p)+    -- Sometimes GHC produces multiple bindings that have the same source+    -- location. To select among these, we give preference to the recursive+    -- bindings which might need termination metrics.+    prioritizeRecBinds lvds =+      let (recs, nrecs) = L.partition lvdIsRec lvds+       in map lvdToPair (recs ++ nrecs)+    lvdToPair lvd = (lvdSourcePos lvd, Right (lvdVar lvd)) -instance Qualify TyConInfo where-  qualify env name l bs tci = tci { sizeFunction = qualify env name l bs <$> sizeFunction tci }+    findNearest :: F.SourcePos -> [(F.SourcePos, b)] -> Maybe b+    findNearest key kvs1 = argMin [ (posDistance key k, v) | (k, v) <- kvs1 ] -instance Qualify RTyCon where-  qualify env name l bs rtc = rtc { rtc_info = qualify env name l bs (rtc_info rtc) }+    -- We prefer the var with the smaller distance, or equal distance+    -- but left of the spec, or not left of the spec but below it.+    posDistance a b =+      ( abs (F.unPos (sourceLine a) - F.unPos (sourceLine b))+      , sourceColumn a < sourceColumn b -- Note: False is prefered/smaller to True+      , sourceLine a > sourceLine b+      ) -instance Qualify (Measure SpecType Ghc.DataCon) where-  qualify env name _ bs m = m -- FIXME substEnv env name bs $-    { msName = qualify env name l bs     lname-    , msEqns = qualify env name l bs <$> msEqns m-    }-    where-      l      = F.loc  lname-      lname  = msName m+    argMin :: (Ord k) => [(k, v)] -> Maybe v+    argMin = Mb.listToMaybe . map snd . L.sortBy (compare `on` fst)  -instance Qualify (Def ty ctor) where-  qualify env name l bs d = d-    { body  = qualify env name l (bs ++ bs') (body d) }-    where-      bs'   = fst <$> binds d--instance Qualify BareMeasure where-  qualify env name l bs m = m-    { msEqns = qualify env name l bs (msEqns m)-    }--instance Qualify DataCtor where-  qualify env name l bs c = c-    { dcTheta  = qualify env name l bs (dcTheta  c)-    , dcFields = qualify env name l bs (dcFields c)-    , dcResult = qualify env name l bs (dcResult c)-    }--instance Qualify DataDecl where-  qualify env name l bs d = d-    { tycDCons  = qualify env name l bs (tycDCons  d)-    , tycPropTy = qualify env name l bs (tycPropTy d)-    }--instance Qualify ModSpecs where-  qualify env name l bs = Misc.hashMapMapWithKey (\_ -> qualify env name l bs)--instance Qualify b => Qualify (a, b) where-  qualify env name l bs (x, y) = (x, qualify env name l bs y)--instance Qualify BareSpec where-  qualify = qualifyBareSpec--qualifyBareSpec :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> BareSpec -> BareSpec-qualifyBareSpec env name l bs sp = sp-  { measures   = qualify env name l bs (measures   sp)-  , asmSigs    = qualify env name l bs (asmSigs    sp)-  , sigs       = qualify env name l bs (sigs       sp)-  , localSigs  = qualify env name l bs (localSigs  sp)-  , reflSigs   = qualify env name l bs (reflSigs   sp)-  , dataDecls  = qualify env name l bs (dataDecls  sp)-  , newtyDecls = qualify env name l bs (newtyDecls sp)-  , ialiases   = [ (f x, f y) | (x, y) <- ialiases sp ]-  }-  where f      = qualify env name l bs--instance Qualify a => Qualify (RTAlias F.Symbol a) where-  qualify env name l bs rtAlias-   = rtAlias { rtName  = qualify env name l bs (rtName rtAlias)-             , rtTArgs = qualify env name l bs (rtTArgs rtAlias)-             , rtVArgs = qualify env name l bs (rtVArgs rtAlias)-             , rtBody  = qualify env name l bs (rtBody rtAlias)-             }--instance Qualify F.Expr where-  qualify = substEnv--instance Qualify RReft where-  qualify = substEnv--instance Qualify F.Qualifier where-  qualify env name _ bs q = q { F.qBody = qualify env name (F.qPos q) bs' (F.qBody q) }-    where-      bs'                 = bs ++ (F.qpSym <$> F.qParams q)--substEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a-substEnv env name l bs = F.substa (qualifySymbol env name l bs)--instance Qualify SpecType where-  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5--instance Qualify BareType where-  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5--substFreeEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a-substFreeEnv env name l bs = F.substf (F.EVar . qualifySymbol env name l bs)+lookupGhcDnTyCon :: Env -> ModName -> DataName -> Lookup (Maybe Ghc.TyCon)+lookupGhcDnTyCon env name = failMaybe env name . lookupGhcDnTyConE env ---------------------------------------------------------------------------------lookupGhcNamedVar :: (Ghc.NamedThing a, F.Symbolic a) => Env -> ModName -> a -> Maybe Ghc.Var---------------------------------------------------------------------------------lookupGhcNamedVar env name z = maybeResolveSym  env name "Var" lx-  where-    lx                       = GM.namedLocSymbol z+lookupGhcDnTyConE :: Env -> DataName -> Lookup Ghc.TyCon+lookupGhcDnTyConE env (DnCon  lname)+  = Ghc.dataConTyCon <$> lookupGhcDataConLHName env lname+lookupGhcDnTyConE env (DnName lname)+  = do+   case lookupTyThing (reTyLookupEnv env) lname of+     Ghc.ATyCon tc -> Right tc+     Ghc.AConLike (Ghc.RealDataCon d) -> Right $ Ghc.dataConTyCon d+     _ -> panic+           (Just $ GM.fSrcSpan lname) $ "not a type or data constructor: " ++ show (val lname) -lookupGhcVar :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.Var-lookupGhcVar env name kind lx = case resolveLocSym env name kind lx of-    Right v -> Mb.maybe (Right v) Right (lookupLocalVar env lx [v])-    Left  e -> Mb.maybe (Left  e) Right (lookupLocalVar env lx [])+lookupGhcDataConLHName :: HasCallStack => Env -> Located LHName -> Lookup Ghc.DataCon+lookupGhcDataConLHName env lname = do+   case lookupTyThing (reTyLookupEnv env) lname of+     Ghc.AConLike (Ghc.RealDataCon d) -> Right d+     _ -> panic+           (Just $ GM.fSrcSpan lname) $ "not a data constructor: " ++ show (val lname) -  -- where-    -- err e   = Misc.errorP "error-lookupGhcVar" (F.showpp (e, F.loc lx, lx))-  --  err     = Ex.throw+lookupGhcIdLHName :: HasCallStack => Env -> Located LHName -> Lookup Ghc.Id+lookupGhcIdLHName env lname =+   case lookupTyThing (reTyLookupEnv env) lname of+     Ghc.AConLike (Ghc.RealDataCon d) -> Right (Ghc.dataConWorkId d)+     Ghc.AnId x -> Right x+     _ -> panic+           (Just $ GM.fSrcSpan lname) $ "not a variable or data constructor: " ++ show (val lname) --- | @lookupLocalVar@ takes as input the list of "global" (top-level) vars---   that also match the name @lx@; we then pick the "closest" definition.---   See tests/names/LocalSpec.hs for a motivating example.+lookupGhcTyThingFromName :: GHCTyLookupEnv -> Ghc.Name -> Maybe Ghc.TyThing+-- see note about unsafePerformIO in lookupTyThingMaybe+lookupGhcTyThingFromName env n =+   unsafePerformIO $ Ghc.reflectGhc (Interface.lookupTyThing (gtleTypeEnv env) n) (gtleSession env) -lookupLocalVar :: Env -> LocSymbol -> [Ghc.Var] -> Maybe Ghc.Var-lookupLocalVar env lx gvs = Misc.findNearest lxn kvs+lookupGhcId :: Env -> Ghc.Name -> Maybe Ghc.Id+lookupGhcId env n =+    case lookupGhcTyThingFromName env' n of+      Just (Ghc.AConLike (Ghc.RealDataCon d)) -> Just (Ghc.dataConWorkId d)+      Just (Ghc.AnId x) -> Just x+      _ -> Nothing   where-    _msg                  = "LOOKUP-LOCAL: " ++ F.showpp (F.val lx, lxn, kvs)-    kvs                   = gs ++ M.lookupDefault [] x (reLocalVars env)-    gs                    = [(F.unPos (F.srcLine v), v) | v <- gvs]-    lxn                   = F.unPos (F.srcLine lx)-    (_, x)                = unQualifySymbol (F.val lx)--lookupGhcDataCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.DataCon-lookupGhcDataCon = resolveLocSym -- strictResolveSym--lookupGhcTyCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon-lookupGhcTyCon env name k lx = myTracepp ("LOOKUP-TYCON: " ++ F.showpp (val lx))-                               $ {- strictResolveSym -} resolveLocSym env name k lx--lookupGhcDnTyCon :: Env -> ModName -> String -> DataName -> Lookup (Maybe Ghc.TyCon)--- lookupGhcDnTyCon = lookupGhcDnTyConE-lookupGhcDnTyCon env name msg = failMaybe env name . lookupGhcDnTyConE env name msg--lookupGhcDnTyConE :: Env -> ModName -> String -> DataName -> Lookup Ghc.TyCon-lookupGhcDnTyConE env name msg (DnCon  s)-  = lookupGhcDnCon env name msg s-lookupGhcDnTyConE env name msg (DnName s)-  = case resolveLocSym env name msg s of-      Right r -> Right r-      Left  e -> case lookupGhcDnCon  env name msg s of-                   Right r -> Right r-                   Left  _ -> Left  e---lookupGhcDnCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon-lookupGhcDnCon env name msg = fmap Ghc.dataConTyCon . resolveLocSym env name msg+    env' = reTyLookupEnv env  ------------------------------------------------------------------------------- -- | Checking existence of names --------------------------------------------------------------------------------knownGhcType :: Env ->  ModName -> LocBareType -> Bool-knownGhcType env name (F.Loc l _ t) =-  case ofBareTypeE env name l Nothing t of+knownGhcType :: Env -> LocBareType -> Bool+knownGhcType env (F.Loc l _ t) =+  case ofBareTypeE env l Nothing t of     Left e  -> myTracepp ("knownType: " ++ F.showpp (t, e)) False     Right _ -> True @@ -525,231 +281,11 @@     f acc t@RApp {} = rt_tycon t : acc     f acc _         = acc --- Aargh. Silly that each of these is the SAME code, only difference is the type.--knownGhcVar :: Env -> ModName -> LocSymbol -> Bool-knownGhcVar env name lx = Mb.isJust v-  where-    v :: Maybe Ghc.Var -- This annotation is crucial-    v = myTracepp ("knownGhcVar " ++ F.showpp lx)-      $ maybeResolveSym env name "known-var" lx--knownGhcTyCon :: Env -> ModName -> LocSymbol -> Bool-knownGhcTyCon env name lx = myTracepp  msg $ Mb.isJust v-  where-    msg = "knownGhcTyCon: "  ++ F.showpp lx-    v :: Maybe Ghc.TyCon -- This annotation is crucial-    v = maybeResolveSym env name "known-tycon" lx--knownGhcDataCon :: Env -> ModName -> LocSymbol -> Bool-knownGhcDataCon env name lx = Mb.isJust v-  where-    v :: Maybe Ghc.DataCon -- This annotation is crucial-    v = myTracepp ("knownGhcDataCon" ++ F.showpp lx)-      $ maybeResolveSym env name "known-datacon" lx------------------------------------------------------------------------------------ | Using the environment---------------------------------------------------------------------------------class ResolveSym a where-  resolveLocSym :: Env -> ModName -> String -> LocSymbol -> Lookup a--instance ResolveSym Ghc.Var where-  resolveLocSym = resolveWith "variable" $ \case-                    Ghc.AnId x -> Just x-                    _          -> Nothing--instance ResolveSym Ghc.TyCon where-  resolveLocSym = resolveWith "type constructor" $ \case-                    Ghc.ATyCon x -> Just x-                    _            -> Nothing--instance ResolveSym Ghc.DataCon where-  resolveLocSym = resolveWith "data constructor" $ \case-                    Ghc.AConLike (Ghc.RealDataCon x) -> Just x-                    _                                -> Nothing---{- Note [ResolveSym for Symbol]--In case we need to resolve (aka qualify) a 'Symbol', we need to do some extra work. Generally speaking,-all these 'ResolveSym' instances perform a lookup into a 'Map' keyed by the 'Symbol' in-order to find a 'TyThing'. More specifically such map is known as the 'TyThingMap':--type TyThingMap = M.HashMap F.Symbol [(F.Symbol, Ghc.TyThing)]--This means, in practice, that we might have more than one result indexed by a given 'Symbol', and we need-to make a choice. The function 'rankedThings' does this. By default, we try to extract only /identifiers/-(i.e. a GHC's 'Id') out of an input 'TyThing', but in the case of test \"T1688\", something different happened.-By tracing calls to 'rankedThings' (called by 'resolveLocSym') there were cases where we had something like-this as our input TyThingMap:--[- 1 : T1688Lib : Data constructor T1688Lib.Lambda,- 1 : T1688Lib : Identifier T1688Lib.Lambda-]--Here name resolution worked because 'resolveLocSym' used the 'ResolveSym' instance defined for 'GHC.Var' that-looks only for 'Id's (contained inside 'Identifier's, and we had one). In some other cases, though,-'resolveLocSym' got called with only this:--[1 : T1688Lib : Data constructor T1688Lib.Lambda]--This would /not/ yield a match, despite the fact a \"Data constructor\" in principle /does/ contain an 'Id'-(it can be extracted out of a 'RealDataCon' by calling 'dataConWorkId'). In the case of test T1688, such-failed lookup caused the 'Symbol' to /not/ qualify, which in turn caused the symbols inside the type synonym:--ProofOf( Step (App (Lambda x e) v) e)--To not qualify. Finally, by the time 'expand' was called, the 'ProofOf' type alias would be replaced with-the correct refinement, but the unqualified 'Symbol's would now cause a test failure when refining the client-module.--It's not clear to me (Alfredo) why 'resolveLocSym' is called multiple times within the same module with-different inputs, but it definitely makes sense to allow for the special case here, at least for 'Symbol's.--Probably finding the /root cause/ would entail partially rewriting the name resoultion engine.---}---instance ResolveSym F.Symbol where-  resolveLocSym env name _ lx =-    -- If we can't resolve the input 'Symbol' from an 'Id', try again-    -- by grabbing the 'Id' of an 'AConLike', if any.-    -- See Note [ResolveSym for Symbol].-    let resolved =  resolveLocSym env name "Var" lx-                 <> resolveWith "variable" lookupVarInsideRealDataCon env name "Var" lx-    in case resolved of-      Left _               -> Right (val lx)-      Right (v :: Ghc.Var) -> Right (F.symbol v)-    where-      lookupVarInsideRealDataCon :: Ghc.TyThing -> Maybe Ghc.Var-      lookupVarInsideRealDataCon = \case-        Ghc.AConLike (Ghc.RealDataCon x) -> Just (Ghc.dataConWorkId x)-        _                                -> Nothing----resolveWith :: (PPrint a) => PJ.Doc -> (Ghc.TyThing -> Maybe a) -> Env -> ModName -> String -> LocSymbol-            -> Lookup a-resolveWith kind f env name str lx =-  -- case Mb.mapMaybe f things of-  case rankedThings f things of-    []  -> Left [errResolve kind str lx]-    [x] -> Right x-    xs  -> Left [ErrDupNames sp (pprint (F.val lx)) (pprint <$> xs)]-  where-    _xSym   = F.val lx-    sp      = GM.fSrcSpanSrcSpan (F.srcSpan lx)-    things  = myTracepp msg $ lookupTyThing env name lx-    msg     = "resolveWith: " ++ str ++ " " ++ F.showpp (val lx)---rankedThings :: (Misc.EqHash k) => (a -> Maybe b) -> [(k, a)] -> [b]-rankedThings f ias = case Misc.sortOn fst (Misc.groupList ibs) of-                       (_,ts):_ -> ts-                       []       -> []-  where-    ibs            = Mb.mapMaybe (\(k, x) -> (k,) <$> f x) ias------------------------------------------------------------------------------------ | @lookupTyThing@ is the central place where we lookup the @Env@ to find---   any @Ghc.TyThing@ that match that name. The code is a bit hairy as we---   have various heuristics to approximiate how GHC resolves names. e.g.---   see tests-names-pos-*.hs, esp. vector04.hs where we need the name `Vector`---   to resolve to `Data.Vector.Vector` and not `Data.Vector.Generic.Base.Vector`...---------------------------------------------------------------------------------lookupTyThing :: Env -> ModName -> LocSymbol -> [((Int, F.Symbol), Ghc.TyThing)]---------------------------------------------------------------------------------lookupTyThing env mdname lsym = [ (k, t) | (k, ts) <- ordMatches, t <- ts]--  where-    ordMatches             = Misc.sortOn fst (Misc.groupList matches)-    matches                = myTracepp ("matches-" ++ msg)-                             [ ((k, m), t) | (m, t) <- lookupThings env x-                                           , k      <- myTracepp msg $ mm nameSym m mds ]-    msg                    = "lookupTyThing: " ++ F.showpp (lsym, x, mds)-    (x, mds)               = symbolModules env (F.val lsym)-    nameSym                = F.symbol mdname-    mm name m mods         = myTracepp ("matchMod: " ++ F.showpp (lsym, name, m, mods)) $-                               matchMod env name m mods--lookupThings :: Env -> F.Symbol -> [(F.Symbol, Ghc.TyThing)]-lookupThings env x = myTracepp ("lookupThings: " ++ F.showpp x)-                   $ Mb.fromMaybe [] $ get x `mplus` get (GM.stripParensSym x)-  where-    get z          = M.lookup z (_reTyThings env)--matchMod :: Env -> F.Symbol -> F.Symbol -> Maybe [F.Symbol] -> [Int]-matchMod env tgtName defName = go-  where-    go Nothing               -- Score UNQUALIFIED names-     | defName == tgtName = [0]                       -- prioritize names defined in *this* module-     | otherwise          = [matchImp env defName 1]  -- prioritize directly imported modules over-                                                      -- names coming from elsewhere, with a--    go (Just ms)             -- Score QUALIFIED names-     |  isEmptySymbol defName-     && ms == [tgtName]   = [0]                       -- local variable, see tests-names-pos-local00.hs-     | ms == [defName]    = [1]-     | isExt              = [matchImp env defName 2]  -- to allow matching re-exported names e.g. Data.Set.union for Data.Set.Internal.union-     | otherwise          = []-     where-       isExt              = any (`isParentModuleOf` defName) ms---- | Returns 'True' if the 'Symbol' given as a first argument represents a parent module for the second.------ >>> L.symbolic "Data.Text" `isParentModuleOf` L.symbolic "Data.Text.Internal"--- True------ Invariants:------ * The empty 'Symbol' is always considered the module prefix of the second,---   in compliance with 'isPrefixOfSym' (AND: why?)--- * If the parent \"hierarchy\" is smaller than the children's one, this is clearly not a parent module.-isParentModuleOf :: F.Symbol -> F.Symbol -> Bool-isParentModuleOf parentModule childModule-  | isEmptySymbol parentModule = True-  | otherwise                  =-    length parentHierarchy <= length childHierarchy && all (uncurry (==)) (zip parentHierarchy childHierarchy)-  where-    parentHierarchy :: [T.Text]-    parentHierarchy = T.splitOn "." . F.symbolText $ parentModule--    childHierarchy :: [T.Text]-    childHierarchy = T.splitOn "." . F.symbolText $ childModule---symbolModules :: Env -> F.Symbol -> (F.Symbol, Maybe [F.Symbol])-symbolModules env s = (x, glerb <$> modMb)-  where-    (modMb, x)      = unQualifySymbol s-    glerb m         = M.lookupDefault [m] m qImps-    qImps           = qiNames (reQualImps env)---- | @matchImp@ lets us prioritize @TyThing@ defined in directly imported modules over---   those defined elsewhere. Specifically, in decreasing order of priority we have---   TyThings that we:---   * DIRECTLY     imported WITHOUT qualification---   * TRANSITIVELY imported (e.g. were re-exported by SOME imported module)---   * QUALIFIED    imported (so qualify the symbol to get this result!)--matchImp :: Env -> F.Symbol -> Int -> Int-matchImp env defName i-  | isUnqualImport = i-  | isQualImport   = i + 2-  | otherwise      = i + 1-  where-    isUnqualImport = S.member defName (reAllImps env) && not isQualImport-    isQualImport   = S.member defName (qiModules (reQualImps env))-- -- | `unQualifySymbol name sym` splits `sym` into a pair `(mod, rest)` where --   `mod` is the name of the module, derived from `sym` if qualified. unQualifySymbol :: F.Symbol -> (Maybe F.Symbol, F.Symbol) unQualifySymbol sym-  | GM.isQualifiedSym sym = Misc.mapFst Just (splitModuleNameExact sym)+  | GM.isQualifiedSym sym = first Just (splitModuleNameExact sym)   | otherwise             = (Nothing, sym)  splitModuleNameExact :: F.Symbol -> (F.Symbol, F.Symbol)@@ -761,36 +297,21 @@ errResolve :: PJ.Doc -> String -> LocSymbol -> Error errResolve k msg lx = ErrResolve (GM.fSrcSpan lx) k (F.pprint (F.val lx)) (PJ.text msg) --- -- | @strictResolve@ wraps the plain @resolve@ to throw an error--- --   if the name being searched for is unknown.--- strictResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> a--- strictResolveSym env name kind x = case resolveLocSym env name kind x of---   Left  err -> Misc.errorP "error-strictResolveSym" (F.showpp err)---   Right val -> val---- | @maybeResolve@ wraps the plain @resolve@ to return @Nothing@---   if the name being searched for is unknown.-maybeResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> Maybe a-maybeResolveSym env name kind x = case resolveLocSym env name kind x of-  Left  _   -> Nothing-  Right val -> Just val- ------------------------------------------------------------------------------- -- | @ofBareType@ and @ofBareTypeE@ should be the _only_ @SpecType@ constructors --------------------------------------------------------------------------------ofBareType :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> SpecType-ofBareType env name l ps t = either fail' id (ofBareTypeE env name l ps t)+ofBareType :: HasCallStack => Env -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> SpecType+ofBareType env l ps t = either fail' id (ofBareTypeE env l ps t)   where     fail'                  = Ex.throw     -- fail                   = Misc.errorP "error-ofBareType" . F.showpp -ofBareTypeE :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> Lookup SpecType-ofBareTypeE env name l ps t = ofBRType env name (resolveReft env name l ps t) l t+ofBareTypeE :: HasCallStack => Env -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> Lookup SpecType+ofBareTypeE env l ps t = ofBRType env (const (resolveReft l ps t)) l t -resolveReft :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> [F.Symbol] -> RReft -> RReft-resolveReft env name l ps t bs-        = qualify env name l bs-        . txParam l RT.subvUReft (RT.uPVar <$> πs) t+resolveReft :: F.SourcePos -> Maybe [PVar BSort] -> BareType -> RReft -> RReft+resolveReft l ps t+        = txParam l RT.subvUReft (RT.uPVar <$> πs) t         . fixReftTyVars t       -- same as fixCoercions   where     πs  = Mb.fromMaybe tπs ps@@ -810,14 +331,14 @@ coSubReft su (F.Reft (x, e)) = F.Reft (x, F.applyCoSub su e)  -ofBSort :: Env -> ModName -> F.SourcePos -> BSort -> RSort-ofBSort env name l t = either (Misc.errorP "error-ofBSort" . F.showpp) id (ofBSortE env name l t)+ofBSort :: HasCallStack => Env -> F.SourcePos -> BSort -> RSort+ofBSort env l t = either (Misc.errorP "error-ofBSort" . F.showpp) id (ofBSortE env l t) -ofBSortE :: Env -> ModName -> F.SourcePos -> BSort -> Lookup RSort-ofBSortE env name l t = ofBRType env name (const id) l t+ofBSortE :: HasCallStack => Env -> F.SourcePos -> BSort -> Lookup RSort+ofBSortE env l t = ofBRType env (const id) l t -ofBPVar :: Env -> ModName -> F.SourcePos -> BPVar -> RPVar-ofBPVar env name l = fmap (ofBSort env name l)+ofBPVar :: Env -> F.SourcePos -> BPVar -> RPVar+ofBPVar env l = fmap (ofBSort env l)  -------------------------------------------------------------------------------- txParam :: F.SourcePos -> ((UsedPVar -> UsedPVar) -> t) -> [UsedPVar] -> RType c tv r -> t@@ -842,13 +363,14 @@  -------------------------------------------------------------------------------- type Expandable r = ( PPrint r-                    , F.Reftable r+                    , Reftable r                     , SubsTy RTyVar (RType RTyCon RTyVar ()) r-                    , F.Reftable (RTProp RTyCon RTyVar r))+                    , Reftable (RTProp RTyCon RTyVar r)+                    , HasCallStack) -ofBRType :: (Expandable r) => Env -> ModName -> ([F.Symbol] -> r -> r) -> F.SourcePos -> BRType r+ofBRType :: (Expandable r) => Env -> ([F.Symbol] -> r -> r) -> F.SourcePos -> BRType r          -> Lookup (RRType r)-ofBRType env name f l = go []+ofBRType env f l = go []   where     goReft bs r             = return (f bs r)     goRFun bs x i t1 t2 r  = RFun x i{permitTC = Just (typeclass (getConfig env))} <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r@@ -860,50 +382,50 @@     go bs (RAllT a t r)     = RAllT a' <$> go bs t <*> goReft bs r       where a'              = dropTyVarInfo (mapTyVarValue RT.bareRTyVar a)     go bs (RAllP a t)       = RAllP a' <$> go bs t-      where a'              = ofBPVar env name l a+      where a'              = ofBPVar env l a     go bs (RAllE x t1 t2)   = RAllE x  <$> go bs t1    <*> go bs t2     go bs (REx x t1 t2)     = REx   x  <$> go bs t1    <*> go (x:bs) t2     go bs (RRTy xts r o t)  = RRTy  <$> xts' <*> goReft bs r <*> pure o <*> go bs t-      where xts'            = mapM (Misc.mapSndM (go bs)) xts+      where xts'            = mapM (traverse (go bs)) xts     go bs (RHole r)         = RHole    <$> goReft bs r-    go bs (RExprArg le)     = return    $ RExprArg (qualify env name l bs le)+    go _ (RExprArg le)      = return    $ RExprArg le     goRef bs (RProp ss (RHole r)) = rPropP <$> mapM goSyms ss <*> goReft bs r     goRef bs (RProp ss t)         = RProp  <$> mapM goSyms ss <*> go bs t-    goSyms (x, t)                 = (x,) <$> ofBSortE env name l t+    goSyms (x, t)                 = (x,) <$> ofBSortE env l t     goRApp bs tc ts rs r          = bareTCApp <$> goReft bs r <*> lc' <*> mapM (goRef bs) rs <*> mapM (go bs) ts       where-        lc'                    = F.atLoc lc <$> matchTyCon env name lc (length ts)+        lc'                    = F.atLoc lc <$> lookupGhcTyConLHName (reTyLookupEnv env) lc         lc                     = btc_tc tc-    -- goRApp _ _ _ _             = impossible Nothing "goRApp failed through to final case" -{--    -- TODO-REBARE: goRImpF bounds _ (RApp c ps' _ _) t _-    -- TODO-REBARE:  | Just bnd <- M.lookup (btc_tc c) bounds-    -- TODO-REBARE:   = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'-    -- TODO-REBARE:        ts <- mapM go ts'-    -- TODO-REBARE:        makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t-    -- TODO-REBARE: goRFun bounds _ (RApp c ps' _ _) t _-    -- TODO-REBARE: | Just bnd <- M.lookup (btc_tc c) bounds-    -- TODO-REBARE: = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'-    -- TODO-REBARE: ts <- mapM go ts'-    -- TODO-REBARE: makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t--  -- TODO-REBARE: ofBareRApp env name t@(F.Loc _ _ !(RApp tc ts _ r))-  -- TODO-REBARE: | Loc l _ c <- btc_tc tc-  -- TODO-REBARE: , Just rta <- M.lookup c aliases-  -- TODO-REBARE: = appRTAlias l rta ts =<< resolveReft r---}+lookupGhcTyConLHName :: HasCallStack => GHCTyLookupEnv -> Located LHName -> Lookup Ghc.TyCon+lookupGhcTyConLHName env lc = do+    case lookupTyThing env lc of+      Ghc.ATyCon tc -> Right tc+      Ghc.AConLike (Ghc.RealDataCon dc) -> Right $ Ghc.promoteDataCon dc+      _ -> panic+            (Just $ GM.fSrcSpan lc) $ "not a type constructor: " ++ show (val lc) -matchTyCon :: Env -> ModName -> LocSymbol -> Int -> Lookup Ghc.TyCon-matchTyCon env name lc@(Loc _ _ c) arity-  | isList c && arity == 1  = Right Ghc.listTyCon-  | isTuple c               = Right tuplTc-  | otherwise               = resolveLocSym env name msg lc-  where-    msg                     = "matchTyCon: " ++ F.showpp c-    tuplTc                  = Ghc.tupleTyCon Ghc.Boxed arity+-- | Get the TyThing from an LHName.+--+-- This function uses 'unsafePerformIO' to lookup the 'Ghc.TyThing' of a 'Ghc.Name'.+-- This should be benign because the result doesn't depend of when exactly this is+-- called. Since this code is intended to be used inside a GHC plugin, there is no+-- danger that GHC is finalized before the result is evaluated.+lookupTyThingMaybe :: HasCallStack => GHCTyLookupEnv -> Located LHName -> Maybe Ghc.TyThing+lookupTyThingMaybe env lc@(Loc _ _ c0) = unsafePerformIO $ do+    case c0 of+      LHNUnresolved _ _ -> panic (Just $ GM.fSrcSpan lc) $ "unresolved name: " ++ show c0+      LHNResolved rn _ -> case rn of+        LHRLocal _ -> panic (Just $ GM.fSrcSpan lc) $ "cannot resolve a local name: " ++ show c0+        LHRIndex i -> panic (Just $ GM.fSrcSpan lc) $ "cannot resolve a LHRIndex " ++ show i+        LHRLogic _ -> panic (Just $ GM.fSrcSpan lc) $ "lookupTyThing: cannot resolve a LHRLogic name " ++ show (lhNameToResolvedSymbol c0)+        LHRGHC n ->+          Ghc.reflectGhc (Interface.lookupTyThing (gtleTypeEnv env) n) (gtleSession env) +lookupTyThing :: HasCallStack => GHCTyLookupEnv -> Located LHName -> Ghc.TyThing+lookupTyThing env lc =+    Mb.fromMaybe (panic (Just $ GM.fSrcSpan lc) $ "not found: " ++ show (val lc)) $+      lookupTyThingMaybe env lc  bareTCApp :: (Expandable r)           => r@@ -935,9 +457,9 @@   = RT.rApp c ts rs r  -tyApp :: F.Reftable r => RType c tv r -> [RType c tv r] -> [RTProp c tv r] -> r+tyApp :: Reftable r => RType c tv r -> [RType c tv r] -> [RTProp c tv r] -> r       -> RType c tv r-tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `F.meet` r')+tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `meet` r') tyApp t                []  []  r  = t `RT.strengthen` r tyApp _                 _  _   _  = panic Nothing "Bare.Type.tyApp on invalid inputs" @@ -975,18 +497,14 @@     -- pvs             = rTyConPVs rc'     (rargs, rrest)     = splitAt (length pvs) rs     r2                 = L.foldl' go rr rrest-    go r (RProp _ (RHole r')) = r' `F.meet` r-    go r (RProp  _ t' )       = let r' = Mb.fromMaybe mempty (stripRTypeBase t') in r `F.meet` r'+    go r (RProp _ (RHole r')) = r' `meet` r+    go r (RProp  _ t' )       = let r' = Mb.fromMaybe mempty (stripRTypeBase t') in r `meet` r'  addSymSort _ _ _ t   = t  addSymSortRef :: (PPrint s) => Ghc.SrcSpan -> s -> RPVar -> SpecProp -> Int -> SpecProp-addSymSortRef sp rc p r i-  | isPropPV p-  = addSymSortRef' sp rc i p r-  | otherwise-  = panic Nothing "addSymSortRef: malformed ref application"+addSymSortRef sp rc p r i = addSymSortRef' sp rc i p r  addSymSortRef' :: (PPrint s) => Ghc.SrcSpan -> s -> Int -> RPVar -> SpecProp -> SpecProp addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v
− src/Language/Haskell/Liquid/Bare/Slice.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE DerivingVia                #-}----- | This module has a function that computes the "slice" i.e. subset of the `Ms.BareSpec` that ---   we actually need to verify a given target module, so that LH doesn't choke trying to resolve ---   names that are not actually relevant and hence, not in the GHC Environment.---   See LH issue 1773 for more details.--- ---   Specifically, this module has datatypes and code for building a Specification Dependency Graph ---   whose vertices are 'names' that need to be resolve, and edges are 'dependencies'.---module Language.Haskell.Liquid.Bare.Slice (sliceSpecs) where---- import qualified Language.Fixpoint.Types as F--- import qualified Data.HashMap.Strict as M-import           Language.Haskell.Liquid.Types--- import Data.Hashable-import qualified Language.Haskell.Liquid.Measure as Ms--- import qualified Data.HashSet as S------------------------------------------------------------------------------------- | Top-level "slicing" function---------------------------------------------------------------------------------sliceSpecs :: GhcSrc -> Ms.BareSpec -> [(ModName, Ms.BareSpec)] -> -        [(ModName, Ms.BareSpec)]-sliceSpecs _tgtSrc _tgtSpec specs = specs --{- ------------------------------------------------------------------------------------ | The different kinds of names we have to resolve---------------------------------------------------------------------------------data Label-  = Sign  -- ^ identifier signature-  | Func  -- ^ measure or reflect-  | DCon  -- ^ data constructor-  | TCon  -- ^ type constructor-  deriving (Eq, Ord, Enum, Show)------------------------------------------------------------------------------------ | A dependency 'Node' is a pair of a name @LocSymbol@ and @Label@---------------------------------------------------------------------------------data Node = MkNode-  { nodeName  :: F.Symbol-  , nodeLabel :: Label-  }-  deriving (Eq, Ord)--instance Hashable Label where-  hashWithSalt s = hashWithSalt s . fromEnum -instance Hashable Node where -  hashWithSalt s MkNode {..} = hashWithSalt s (nodeName, nodeLabel) --newtype DepGraph = MkDepGraph -  { dGraph :: M.HashMap Node [Node] -  }------------------------------------------------------------------------------------ | A way to combine graphs of multiple modules----------------------------------------------------------------------------------instance Semigroup DepGraph where-  x <> y = MkDepGraph { dGraph = M.unionWith (++) (dGraph x) (dGraph y) }--instance Monoid DepGraph where-  mempty = MkDepGraph mempty------------------------------------------------------------------------------------ | A function to build the dependencies for each module----------------------------------------------------------------------------------mkRoots :: GhcSrc -> S.HashSet Node-mkRoots = undefined------------------------------------------------------------------------------------ | A function to build the dependencies for each module----------------------------------------------------------------------------------class Graph a where-  mkGraph :: a -> DepGraph--instance Graph [Ms.BareSpec] where-  mkGraph specs = mconcat [ mkGraph sp | sp <- specs]--instance Graph Ms.BareSpec where-  mkGraph sp = mconcat -    [ undefined -- FIXME -- mkGraph (expSigs sp)-    ]------------------------------------------------------------------------------------ | 'reachable roots g' returns the list of Node transitively reachable from roots---------------------------------------------------------------------------------reachable :: S.HashSet Node -> DepGraph -> S.HashSet Node-reachable roots g = undefined -- _TODO------------------------------------------------------------------------------------ | Extract the dependencies ----------------------------------------------------------------------------------class Deps a where-  deps :: a -> [Node]--instance Deps BareType where-  deps = error "TBD:deps:bareType"--instance Deps DataDecl where-  deps = error "TBD:deps:datadecl"--instance Deps DataCtor where -  deps = error "TBD:deps:datactor"---}----{- -             -- = [ (n, slice nodes sp) | (n, sp) <- specs ]-  -- where-    -- tgtGraph = mkGraph tgtSpec-    -- impGraph = mkGraph (snd <$> specs)-    -- roots    = mkRoots tgtSrc -- S.fromList . M.keys . dGraph $ tgtGraph-    -- nodes    = reachable roots (tgtGraph <> impGraph)--class Sliceable a where-  slice :: S.HashSet Node -> a -> a--instance Sliceable Ms.BareSpec where -  slice nodes sp = sp---}------{- -These are the fields we have to worry about--unsafeFromLiftedSpec :: LiftedSpec -> Spec LocBareType F.LocSymbol-unsafeFromLiftedSpec a = Spec-  { -  --->>> , asmSigs    = S.toList . liftedAsmSigs $ a-  --->>> , sigs       = S.toList . liftedSigs $ a-  --->>> , invariants = S.toList . liftedInvariants $ a-  --->>> , dataDecls  = S.toList . liftedDataDecls $ a-  --->>> , newtyDecls = S.toList . liftedNewtyDecls $ a-    -  , measures   = S.toList . liftedMeasures $ a-  , impSigs    = S.toList . liftedImpSigs $ a-  , expSigs    = S.toList . liftedExpSigs $ a-  , ialiases   = S.toList . liftedIaliases $ a-  , imports    = S.toList . liftedImports $ a-  , aliases    = S.toList . liftedAliases $ a-  , ealiases   = S.toList . liftedEaliases $ a-  , embeds     = liftedEmbeds a-  , qualifiers = S.toList . liftedQualifiers $ a-  , decr       = S.toList . liftedDecr $ a-  , lvars      = liftedLvars a-  , autois     = liftedAutois a-  , autosize   = liftedAutosize a-  , cmeasures  = S.toList . liftedCmeasures $ a-  , imeasures  = S.toList . liftedImeasures $ a-  , classes    = S.toList . liftedClasses $ a-  , claws      = S.toList . liftedClaws $ a-  , rinstance  = S.toList . liftedRinstance $ a-  , ilaws      = S.toList . liftedIlaws $ a-  , dvariance  = S.toList . liftedDvariance $ a-  , bounds     = liftedBounds a-  , defs       = liftedDefs a-  , axeqs      = S.toList . liftedAxeqs $ a-  }--}--
src/Language/Haskell/Liquid/Bare/ToBare.hs view
@@ -12,13 +12,13 @@  import           Data.Bifunctor -import           Language.Fixpoint.Misc (mapSnd) import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.GHC.Misc import           Liquid.GHC.API-import           Language.Haskell.Liquid.Types--- import           Language.Haskell.Liquid.Measure--- import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.Specs  -------------------------------------------------------------------------------- specToBare :: SpecType -> BareType@@ -36,18 +36,14 @@ -------------------------------------------------------------------------------- measureToBare = bimap (fmap specToBare) dataConToBare -dataConToBare :: DataCon -> LocSymbol-dataConToBare d = dropModuleNames . F.symbol <$> locNamedThing d-  where-    _msg  = "dataConToBare dc = " ++ show d ++ " v = " ++ show v ++ " vx = " ++ show vx-    v     = dataConWorkId d-    vx    = F.symbol v+dataConToBare :: DataCon -> F.Located LHName+dataConToBare d = makeGHCLHNameFromId . dataConWorkId <$> locNamedThing d  specToBareTC :: RTyCon -> BTyCon specToBareTC = tyConBTyCon . rtc_tc  specToBareTV :: RTyVar -> BTyVar-specToBareTV (RTV α) = BTV (F.symbol α)+specToBareTV (RTV α) = BTV (F.symbol <$> locNamedThing α)  txRType :: (c1 -> c2) -> (tv1 -> tv2) -> RType c1 tv1 r -> RType c2 tv2 r txRType cF vF = go@@ -61,7 +57,7 @@     go (REx x t t')        = REx   x         (go t) (go t')     go (RAppTy t t' r)     = RAppTy          (go t) (go t') r     go (RApp c ts rs r)    = RApp  (cF c)    (go <$> ts) (goRTP <$> rs) r-    go (RRTy xts r o t)    = RRTy  (mapSnd go <$> xts) r o (go t)+    go (RRTy xts r o t)    = RRTy  (fmap go <$> xts) r o (go t)     go (RExprArg e)        = RExprArg e     go (RHole r)           = RHole r @@ -69,8 +65,8 @@     go' = txRType cF vF      -- goRTP :: RTProp c1 tv1 r -> RTProp c2 tv2 r-    goRTP (RProp s (RHole r)) = RProp (mapSnd go' <$> s) (RHole r)-    goRTP (RProp s t)         = RProp (mapSnd go' <$> s) (go t)+    goRTP (RProp s (RHole r)) = RProp (fmap go' <$> s) (RHole r)+    goRTP (RProp s t)         = RProp (fmap go' <$> s) (go t)      -- goRTV :: RTVU c1 tv1 -> RTVU c2 tv2     goRTV = txRTV cF vF@@ -85,5 +81,5 @@ txPV cF vF (PV sym k y txes) = PV sym k' y txes'   where     txes'                  = [ (tx t, x, e) | (t, x, e) <- txes]-    k'                     = tx <$> k+    k'                     = tx k     tx                     = txRType cF vF
src/Language/Haskell/Liquid/Bare/Typeclass.hs view
@@ -27,16 +27,22 @@ import qualified Liquid.GHC.API                                                as Ghc import qualified Language.Haskell.Liquid.Misc  as Misc-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import qualified Language.Haskell.Liquid.Types.RefType                                                as RT+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Visitors import qualified Language.Haskell.Liquid.Bare.Types                                                as Bare import qualified Language.Haskell.Liquid.Bare.Resolve                                                as Bare import qualified Language.Haskell.Liquid.Measure                                                as Ms--- import           Language.Haskell.Liquid.Types.Types import qualified Data.HashMap.Strict           as M  @@ -54,8 +60,8 @@     { dataDecls = clsDecls     , reflects  = F.notracepp "reflects " $ S.fromList                     (  fmap-                        ( fmap GM.dropModuleNames-                        . GM.namedLocSymbol+                        ( fmap (updateLHNameSymbol GM.dropModuleNames)+                        . makeGHCLHNameLocatedFromId                         . Ghc.instanceDFunId                         . fst                         )@@ -67,21 +73,21 @@       -- class methods   (refinedMethods, sigsNew) = foldr grabClassSig (mempty, mempty) (sigs spec)   grabClassSig-    :: (F.LocSymbol, ty)-    -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)])-    -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)])+    :: (F.Located LHName, ty)+    -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.Located LHName, ty)])+    -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.Located LHName, ty)])   grabClassSig sigPair@(lsym, ref) (refs, sigs') = case clsOp of     Nothing         -> (refs, sigPair : sigs')     Just (cls, sig) -> (M.alter (merge sig) cls refs, sigs')    where     clsOp = do-      var <- Bare.maybeResolveSym env name "grabClassSig" lsym+      var <- either (const Nothing) Just $ Bare.lookupGhcIdLHName env lsym       cls <- Ghc.isClassOpId_maybe var       pure (cls, (var, ref))     merge sig v = case v of       Nothing -> Just [sig]       Just vs -> Just (sig : vs)-  methods = [ GM.namedLocSymbol x | (_, xs) <- instmethods, x <- xs ]+  methods = [ makeGHCLHNameLocatedFromId x | (_, xs) <- instmethods, x <- xs ]       -- instance methods    mkSymbol x@@ -115,10 +121,7 @@       ++ concatMap (Mb.mapMaybe resolveClassMaybe . dataDecls . snd) rest   resolveClassMaybe :: DataDecl -> Maybe Ghc.Class   resolveClassMaybe d =-    Bare.maybeResolveSym env-                         name-                         "resolveClassMaybe"-                         (dataNameSymbol . tycName $ d)+    either (const Nothing) Just (Bare.lookupGhcTyConLHName (Bare.reTyLookupEnv env) $ dataNameSymbol $ tycName d)       >>= Ghc.tyConClass_maybe  @@ -131,7 +134,7 @@ -- maybe this should be fixed right after the GHC API refactoring? classDeclToDataDecl :: Ghc.Class -> [(Ghc.Id, LocBareType)] -> DataDecl classDeclToDataDecl cls refinedIds = DataDecl-  { tycName   = DnName (F.symbol <$> GM.locNamedThing cls)+  { tycName   = DnName $ makeGHCLHNameLocated cls   , tycTyVars = tyVars   , tycPVars  = []   , tycDCons  = Just [dctor]@@ -141,7 +144,8 @@   , tycKind   = DataUser   }  where-  dctor = F.notracepp "classDeclToDataDecl" DataCtor { dcName   = F.dummyLoc $ F.symbol classDc+  dctor = F.notracepp "classDeclToDataDecl"+    DataCtor { dcName   = F.dummyLoc $ makeGHCLHName (Ghc.getName classDc) (F.symbol classDc)     -- YL: same as class tyvars??     -- Ans: it's been working so far so probably yes                    , dcTyVars = tyVars@@ -158,9 +162,9 @@   fields = fmap attachRef classIds   attachRef sid     | Just ref <- L.lookup sid refinedIds-    = (F.symbol sid, RT.subts tyVarSubst (F.val ref))+    = (makeGHCLHNameFromId sid, RT.subts tyVarSubst (F.val ref))     | otherwise-    = (F.symbol sid, RT.bareOfType . dropTheta . Ghc.varType $ sid)+    = (makeGHCLHNameFromId sid, RT.bareOfType . dropTheta . Ghc.varType $ sid)    tyVarSubst = [ (GM.dropModuleUnique v, v) | v <- tyVars ] @@ -185,10 +189,10 @@ elaborateClassDcp coreToLg simplifier dcp = do   t' <- flip (zipWith addCoherenceOblig) prefts     <$> forM fts (elaborateSpecType coreToLg simplifier)-  let ts' = elaborateMethod (F.symbol dc) (S.fromList xs) <$> t'+  let ts' = elaborateMethod (F.symbol dc) (S.fromList $ map lhNameToResolvedSymbol xs) <$> t'   pure     ( dcp { dcpTyArgs = zip xs (stripPred <$> ts') }-    , dcp { dcpTyArgs = fmap (\(x, t) -> (x, strengthenTy x t)) (zip xs t') }+    , dcp { dcpTyArgs = fmap (\(x, t) -> (x, strengthenTy (lhNameToResolvedSymbol x) t)) (zip xs t') }     )  where   addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType@@ -352,13 +356,13 @@     elaboratedSig  <- flip addCoherenceOblig preft <$> elab fullSig      let retSig =  mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) (F.notracepp ("elaborated" ++ GM.showPpr method) elaboratedSig)-    let tysub  = F.notracepp "tysub" $ M.fromList $ zip (F.notracepp "newtype-vars" $ allTyVars' (F.notracepp "new-type" retSig)) (F.notracepp "ghc-type-vars" (allTyVars' ((F.notracepp "ghc-type" $ ofType (Ghc.varType method)) :: SpecType)))+    let tysub  = F.notracepp "tysub" $ M.fromList $ zip (F.notracepp "newtype-vars" $ RT.allTyVars' (F.notracepp "new-type" retSig)) (F.notracepp "ghc-type-vars" (RT.allTyVars' ((F.notracepp "ghc-type" $ RT.ofType (Ghc.varType method)) :: SpecType)))         cosub  = M.fromList [ (F.symbol a, F.fObj (GM.namedLocSymbol b)) |  (a,RTV b) <- M.toList tysub]         tysubf x = F.notracepp ("cosub:" ++ F.showpp cosub) $ M.lookupDefault x x tysub         subbedTy = mapReft (Bare.coSubRReft cosub) (renameTvs tysubf retSig)      -- need to make the variable names consistent-    pure (method, F.dummyLoc (F.notracepp ("vars:" ++ F.showpp (F.symbol <$> allTyVars' subbedTy)) subbedTy))+    pure (method, F.dummyLoc (F.notracepp ("vars:" ++ F.showpp (F.symbol <$> RT.allTyVars' subbedTy)) subbedTy))    -- "is" is used as a shorthand for instance, following the convention of the Ghc api   where@@ -371,7 +375,7 @@     cls = Mb.fromJust . Ghc.tyConClass_maybe $ Ghc.dataConTyCon (dcpCon dcp)     addCoherenceOblig  :: SpecType -> Maybe RReft -> SpecType     addCoherenceOblig t Nothing = t-    addCoherenceOblig t (Just r) = F.notracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `strengthen` r}+    addCoherenceOblig t (Just r) = F.notracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `RT.strengthen` r}       where rrep = toRTypeRep t             res  = ty_res rrep    -- (Monoid.mappend -> $cmappend##Int, ...)     -- core rewriting mark2: do the same thing except they don't have to be symbols@@ -382,14 +386,14 @@     dfunSymL = GM.namedLocSymbol $ Ghc.instanceDFunId inst     dfunSym = F.val dfunSymL     (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst-    isSpecTys = ofType <$> isTys-    isPredSpecTys = ofType <$> isPredTys-    isRTvs = makeRTVar . rTyVar <$> isTvs+    isSpecTys = RT.ofType <$> isTys+    isPredSpecTys = RT.ofType <$> isPredTys+    isRTvs = makeRTVar . RT.rTyVar <$> isTvs     dcp = F.val ldcp     -- Monoid.mappend, ...     clsMethods = filter (\x -> GM.dropModuleNames (F.symbol x) `elem` fmap mkSymbol methods) $       Ghc.classAllSelIds (Ghc.is_cls inst)-    yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp]+    yts = [(lhNameToResolvedSymbol y, t) | (y, t) <- dcpTyArgs dcp]     mkSymbol x       | -- F.notracepp ("isDictonaryId:" ++ GM.showPpr x) $         Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x)@@ -398,7 +402,7 @@     clsTvs = dcpFreeTyVars dcp         -- copy/pasted from Bare/Class.hs     subst [] t = t-    subst ((a, ta):su) t = subsTyVarMeet' (a, ta) (subst su t)+    subst ((a, ta):su) t = RT.subsTyVarMeet' (a, ta) (subst su t)  substAuxMethod :: F.Symbol -> M.HashMap F.Symbol F.Symbol -> F.Expr -> F.Expr substAuxMethod dfun methods = F.notracepp "substAuxMethod" . go
src/Language/Haskell/Liquid/Bare/Types.hs view
@@ -5,9 +5,11 @@ module Language.Haskell.Liquid.Bare.Types    ( -- * Name resolution environment      Env (..)+  , GHCTyLookupEnv (..)   , TyThingMap    , ModSpecs-  , LocalVars +  , LocalVars(..)+  , LocalVarDetails (..)      -- * Tycon and Datacon processing environment   , TycEnv (..) @@ -33,11 +35,15 @@ import qualified Data.HashMap.Strict                   as M import qualified Language.Fixpoint.Types               as F  import qualified Language.Haskell.Liquid.Measure       as Ms+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Names import qualified Language.Haskell.Liquid.Types.RefType as RT +import           Language.Haskell.Liquid.Types.RType import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.Specs   hiding (BareSpec) import           Liquid.GHC.API       as Ghc hiding (Located, Env) import           Language.Haskell.Liquid.GHC.Types     (StableName)+import           Language.Haskell.Liquid.UX.Config   type ModSpecs = M.HashMap ModName Ms.BareSpec@@ -66,25 +72,41 @@ -- | Name resolution environment  ------------------------------------------------------------------------------- data Env = RE -  { reLMap      :: !LogicMap-  , reSyms      :: ![(F.Symbol, Ghc.Var)]    -- ^ see "syms" in old makeGhcSpec'-  , _reSubst    :: !F.Subst                  -- ^ see "su"   in old makeGhcSpec'-  , _reTyThings :: !TyThingMap -  , reCfg       :: !Config-  , reQualImps  :: !QImports                 -- ^ qualified imports-  , reAllImps   :: !(S.HashSet F.Symbol)     -- ^ all imported modules-  , reLocalVars :: !LocalVars                -- ^ lines at which local variables are defined.-  , reGlobSyms  :: !(S.HashSet F.Symbol)     -- ^ global symbols, typically unlifted measures like 'len', 'fromJust'-  , reSrc       :: !GhcSrc                   -- ^ all source info+  { reTyLookupEnv :: GHCTyLookupEnv+  , reTcGblEnv  :: Ghc.TcGblEnv+  , reInstEnvs  :: Ghc.InstEnvs+  , reUsedExternals :: Ghc.NameSet+  , reLMap      :: LogicMap+  , reDataConIds :: [Ghc.Id]                -- ^ Data constructors used in the current module+  , reCfg       :: Config+  , reLocalVars :: LocalVars                -- ^ lines at which local variables are defined.+  , reGlobSyms  :: S.HashSet F.Symbol       -- ^ global symbols, typically unlifted measures like 'len', 'fromJust'+  , reSrc       :: GhcSrc                   -- ^ all source info   } +data GHCTyLookupEnv = GHCTyLookupEnv+       { gtleSession :: Ghc.Session+       , gtleTypeEnv :: Ghc.TypeEnv+       }+ instance HasConfig Env where    getConfig = reCfg  --- | @LocalVars@ is a map from names to lists of pairs of @Ghc.Var@ and ---   the lines at which they were defined. -type LocalVars = M.HashMap F.Symbol [(Int, Ghc.Var)]+data LocalVars = LocalVars+  { -- | A map from names to lists of pairs of @Ghc.Var@ and+    --   the lines at which they were defined.+    lvSymbols :: M.HashMap F.Symbol [LocalVarDetails]+    -- | A map from names to its details+  , lvNames :: NameEnv LocalVarDetails+  } +data LocalVarDetails = LocalVarDetails+  { lvdSourcePos :: F.SourcePos+  , lvdVar :: Ghc.Var+  , lvdLclEnv :: [Ghc.Var]+  , lvdIsRec :: Bool  -- ^ Is the variable defined in a letrec?+  } deriving Show+ ------------------------------------------------------------------------------- -- | A @TyThingMap@ is used to resolve symbols into GHC @TyThing@ and,  --   from there into Var, TyCon, DataCon, etc.@@ -129,13 +151,30 @@   , meDataCons    :: ![(Ghc.Var,  LocSpecType)]              , meClasses     :: ![DataConP]                              , meMethods     :: ![(ModName, Ghc.Var, LocSpecType)]  -  , meCLaws       :: ![(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]  +  , meOpaqueRefl  :: ![(Ghc.Var, Measure (Located BareType) (F.Located LHName))] -- the opaque-reflected symbols and the corresponding measures   }  instance Semigroup MeasEnv where-  (<>) = error "FIXME:1773"+  a <> b = MeasEnv+    { meMeasureSpec = meMeasureSpec a <> meMeasureSpec b+    , meClassSyms   = meClassSyms a <> meClassSyms b+    , meSyms        = meSyms a <> meSyms b+    , meDataCons    = meDataCons a <> meDataCons b  +    , meClasses     = meClasses a <> meClasses b                       +    , meMethods     = meMethods a <> meMethods b+    , meOpaqueRefl  = meOpaqueRefl a <> meOpaqueRefl b+    } instance Monoid MeasEnv where-  mempty = error "FIXME:1773"+  mempty = MeasEnv+    {+      meMeasureSpec = mempty+    , meClassSyms   = mempty+    , meSyms        = mempty+    , meDataCons    = mempty+    , meClasses     = mempty+    , meMethods     = mempty+    , meOpaqueRefl  = mempty+    }  ------------------------------------------------------------------------------- -- | Converting @Var@ to @Sort@
src/Language/Haskell/Liquid/Constraint/Constraint.hs view
@@ -11,7 +11,9 @@  import Prelude hiding (error) import Data.Maybe-import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.RType+import Language.Haskell.Liquid.Types.RTypeOp+import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Constraint.Types import Language.Haskell.Liquid.Constraint.Env import Language.Fixpoint.Types
src/Language/Haskell/Liquid/Constraint/Env.hs view
@@ -20,6 +20,7 @@   , addBinders   , addSEnv   , addEEnv+  , addRewritesForNextBinding   , (-=)   , globalize @@ -67,10 +68,14 @@   -import           Liquid.GHC.API hiding (panic)+import           Liquid.GHC.API hiding (get, panic) import           Language.Haskell.Liquid.Types.RefType import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp-import           Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types hiding (binds) import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Fresh () import           Language.Haskell.Liquid.Transforms.RefSplit@@ -154,6 +159,14 @@   put          $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) }   return ((x, F.sr_sort r), {- traceShow ("addBind: " ++ showpp x) -} i) +-- | Add local rewrites associated to the next binding that will be inserted.+addRewritesForNextBinding :: F.LocalRewrites -> CG ()+addRewritesForNextBinding rws = do+  st <- get+  let bid = F.bindEnvSize $ binds st+  put $ st { localRewrites = F.insertRewrites bid rws $ localRewrites st }++ addClassBind :: CGEnv -> SrcSpan -> SpecType -> CG [((F.Symbol, F.Sort), F.BindId)] addClassBind γ l = mapM (uncurry (addBind l)) . classBinds (emb γ) @@ -168,7 +181,7 @@   = addCGEnv tx γ (eMsg, sym, t)   where     xs            = localBindsOfType tyy (renv γ)-    t             = L.foldl' F.meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]+    t             = L.foldl' meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]     (tyx', ttrue) = splitXRelatedRefs yy tyx  addCGEnv tx γ (_, x, t') = do@@ -181,7 +194,7 @@   is    <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t   return $ γ' { fenv = insertsFEnv (fenv γ) is } -rTypeSortedReft' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+rTypeSortedReft' :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))     => CGEnv -> F.Templates -> RRType r -> F.SortedReft rTypeSortedReft' γ t   = pruneUnsortedReft (feEnv $ fenv γ) t . f
src/Language/Haskell/Liquid/Constraint/Fresh.hs view
@@ -30,15 +30,17 @@ import           Control.Monad                  (when, (>=>)) import           Prelude                        hiding (error) -import           Language.Fixpoint.Misc  ((=>>)) import qualified Language.Fixpoint.Types as F import           Language.Fixpoint.Types.Visitor (kvarsExpr)-import           Language.Haskell.Liquid.Types--- import           Language.Haskell.Liquid.Types.RefType--- import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Constraint.Types import qualified Language.Haskell.Liquid.GHC.Misc as GM-import           Liquid.GHC.API as Ghc+import           Language.Haskell.Liquid.UX.Config+import           Liquid.GHC.API as Ghc hiding (get)  -------------------------------------------------------------------------------- -- | This is all hardwiring stuff to CG ----------------------------------------@@ -74,9 +76,10 @@ freshTyExpr allowTC k e _  = freshTyReftype allowTC k $ exprRefType e  freshTyReftype     :: Bool -> KVKind -> SpecType -> CG SpecType-freshTyReftype allowTC k _t = (fixTy t >>= refresh allowTC) =>> addKVars k-  where-    t                = {- F.tracepp ("freshTyReftype:" ++ show k) -} _t+freshTyReftype allowTC k t = do+    st <- fixTy t >>= refresh allowTC+    addKVars k st+    return st  -- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive --   definitions, and also to update the KVar profile.
src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -37,7 +37,7 @@ import qualified Data.List                                     as L import qualified Data.Foldable                                 as F import qualified Data.Functor.Identity-import Language.Fixpoint.Misc ( (<<=), errorP, mapSnd, safeZip )+import Language.Fixpoint.Misc (errorP, safeZip ) import           Language.Fixpoint.Types.Visitor import qualified Language.Fixpoint.Types                       as F import qualified Language.Fixpoint.Types.Visitor               as F@@ -47,13 +47,30 @@ import           Language.Haskell.Liquid.Constraint.Monad import Language.Haskell.Liquid.Constraint.Split ( splitC, splitW ) import           Language.Haskell.Liquid.Constraint.Relational (consAssmRel, consRelTop)-import           Language.Haskell.Liquid.Types hiding (binds, Loc, loc, Def)+import           Language.Haskell.Liquid.Types.Dictionaries+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.Literals+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.PredType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types hiding (binds) import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Constraint ( addConstraints ) import           Language.Haskell.Liquid.Constraint.Template import           Language.Haskell.Liquid.Constraint.Termination+import           Language.Haskell.Liquid.Constraint.RewriteCase import           Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult, runToLogic, coreToLogic) import           Language.Haskell.Liquid.Bare.DataType (dataConMap, makeDataConChecker)+import Language.Haskell.Liquid.UX.Config+    ( HasConfig(getConfig),+      Config(typeclass, gradual, checkDerived, extensionality,+             nopolyinfer, noADT, dependantCase, exactDC, rankNTypes),+      patternFlag,+      higherOrderFlag )  -------------------------------------------------------------------------------- -- | Constraint Generation: Toplevel -------------------------------------------@@ -263,11 +280,10 @@ killSubst = fmap killSubstReft  killSubstReft :: F.Reft -> F.Reft-killSubstReft = trans kv () ()+killSubstReft = trans ks   where-    kv    = defaultVisitor { txExpr = ks }-    ks _ (F.PKVar k _) = F.PKVar k mempty-    ks _ p             = p+    ks (F.PKVar k _) = F.PKVar k mempty+    ks p             = p  defAnn :: Bool -> t -> Annot t defAnn True  = AnnRDf@@ -373,7 +389,7 @@  addForAllConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG () addForAllConstraint γ _ _ (RAllT rtv rt rr)-  | F.isTauto rr+  | isTauto rr   = return ()   | otherwise   = do t'       <- true (typeclass (getConfig γ)) rt@@ -647,7 +663,8 @@  consPattern γ (Rs.PatProject xe _ τ c ys i) _ = do   let yi = ys !! i-  t    <- (addW . WfC γ) <<= freshTyType (typeclass (getConfig γ)) ProjectE (Var yi) τ+  t    <- freshTyType (typeclass (getConfig γ)) ProjectE (Var yi) τ+  _    <- (addW . WfC γ) t   γ'   <- caseEnv γ xe [] (DataAlt c) ys (Just [i])   ti   <- {- γ' ??= yi -} varRefType γ' yi   addC (SubC γ' ti t) "consPattern:project"@@ -700,7 +717,7 @@                   else eCoerc (typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x)                          (typeSort (emb γ) τ)                          $ F.expr x-       return (t `strengthen` uTop (F.uexprReft ce) {- `F.meet` tx -})+       return (t `strengthen` uTop (F.uexprReft ce) {- `meet` tx -})   where eCoerc s t e          | s == t    = e          | otherwise = F.ECoerc s t e@@ -856,13 +873,16 @@   let ys''         = F.symbol <$> filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) ys   let r1           = dataConReft   c   ys''   let r2           = dataConMsReft rtd ys''-  let xt           = (xt0 `F.meet` rtd) `strengthen` uTop (r1 `F.meet` r2)+  let xt           = (xt0 `meet` rtd) `strengthen` uTop (r1 `meet` r2)   let cbs          = safeZip "cconsCase" (x':ys')                          (map (`F.subst1` (selfSymbol, F.EVar x'))                          (xt0 : yts))-  cγ'             <- addBinders γ x' cbs+  cγ'  <- addBinders γ   x' cbs+  when allowDC $+    addRewritesForNextBinding $ getCaseRewrites γ $ xt0 `meet` rtd   addBinders cγ' x' [(x', substSelf <$> xt)]   where allowTC    = typeclass (getConfig γ)+        allowDC    = dependantCase (getConfig γ)  caseEnv γ x acs a _ _ = do   let x'  = F.symbol x@@ -915,7 +935,7 @@         yts''                = zipWith F.subst sus (yts'++[rt])         (t3,yts)             = (last yts'', init yts'')         sus                  = F.mkSubst <$> L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys']-        (αs, ys')            = mapSnd (F.symbol <$>) $ L.partition isTyVar ys+        (αs, ys')            = fmap F.symbol <$> L.partition isTyVar ys         tvs' :: [SpecType]         tvs'                 = rVar <$> αs         tvys                 = ofType . varType <$> αs@@ -960,7 +980,7 @@ -- | Helpers: Creating Fresh Refinement ------------------------------- ----------------------------------------------------------------------- freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp-freshPredRef γ e (PV _ (PVProp rsort) _ as)+freshPredRef γ e (PV _ rsort _ as)   = do t    <- freshTyType (typeclass (getConfig γ))  PredInstE e (toType False rsort)        args <- mapM (const fresh) as        let targs = [(x, s) | (x, (s, y, z)) <- zip args as, F.EVar y == z ]@@ -968,10 +988,6 @@        addW $ WfC γ' t        return $ RProp targs t -freshPredRef _ _ (PV _ PVHProp _ _)-  = todo Nothing "EFFECTS:freshPredRef"-- -------------------------------------------------------------------------------- -- | Helpers: Creating Refinement Types For Various Things --------------------- --------------------------------------------------------------------------------@@ -996,11 +1012,10 @@ lamExpr :: CGEnv -> CoreExpr -> CG (Maybe F.Expr) lamExpr g e = do     adts <- gets cgADTs-    allowTC <- gets cgiTypeclass     let dm = dataConMap adts-    return $ eitherToMaybe $ runToLogic (emb g) mempty dm+    return $ eitherToMaybe $ runToLogic (emb g) mempty dm (getConfig g)       (\x -> todo Nothing ("coreToLogic not working lamExpr: " ++ x))-      (coreToLogic allowTC e)+      (coreToLogic e)  -------------------------------------------------------------------------------- (??=) :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType@@ -1089,25 +1104,25 @@ -- | RJ: `nomeet` replaces `strengthenS` for `strengthen` in the definition --   of `varRefType`. Why does `tests/neg/strata.hs` fail EVEN if I just replace --   the `otherwise` case? The fq file holds no answers, both are sat.-strengthenTop :: (PPrint r, F.Reftable r) => RType c tv r -> r -> RType c tv r-strengthenTop (RApp c ts rs r) r'   = RApp c ts rs   $ F.meet r r'-strengthenTop (RVar a r) r'         = RVar a         $ F.meet r r'-strengthenTop (RFun b i t1 t2 r) r' = RFun b i t1 t2 $ F.meet r r'-strengthenTop (RAppTy t1 t2 r) r'   = RAppTy t1 t2   $ F.meet r r'-strengthenTop (RAllT a t r)    r'   = RAllT a t      $ F.meet r r'+strengthenTop :: (PPrint r, Reftable r) => RType c tv r -> r -> RType c tv r+strengthenTop (RApp c ts rs r) r'   = RApp c ts rs   $ meet r r'+strengthenTop (RVar a r) r'         = RVar a         $ meet r r'+strengthenTop (RFun b i t1 t2 r) r' = RFun b i t1 t2 $ meet r r'+strengthenTop (RAppTy t1 t2 r) r'   = RAppTy t1 t2   $ meet r r'+strengthenTop (RAllT a t r)    r'   = RAllT a t      $ meet r r' strengthenTop t _                   = t  -- TODO: this is almost identical to RT.strengthen! merge them!-strengthenMeet :: (PPrint r, F.Reftable r) => RType c tv r -> r -> RType c tv r-strengthenMeet (RApp c ts rs r) r'  = RApp c ts rs (r `F.meet` r')-strengthenMeet (RVar a r) r'        = RVar a       (r `F.meet` r')-strengthenMeet (RFun b i t1 t2 r) r'= RFun b i t1 t2 (r `F.meet` r')-strengthenMeet (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `F.meet` r')-strengthenMeet (RAllT a t r) r'     = RAllT a (strengthenMeet t r') (r `F.meet` r')+strengthenMeet :: (PPrint r, Reftable r) => RType c tv r -> r -> RType c tv r+strengthenMeet (RApp c ts rs r) r'  = RApp c ts rs (r `meet` r')+strengthenMeet (RVar a r) r'        = RVar a       (r `meet` r')+strengthenMeet (RFun b i t1 t2 r) r'= RFun b i t1 t2 (r `meet` r')+strengthenMeet (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `meet` r')+strengthenMeet (RAllT a t r) r'     = RAllT a (strengthenMeet t r') (r `meet` r') strengthenMeet t _                  = t --- topMeet :: (PPrint r, F.Reftable r) => r -> r -> r--- topMeet r r' = r `F.meet` r'+-- topMeet :: (PPrint r, Reftable r) => r -> r -> r+-- topMeet r r' = r `meet` r'  -------------------------------------------------------------------------------- -- | Cleaner Signatures For Rec-bindings ---------------------------------------
src/Language/Haskell/Liquid/Constraint/Init.hs view
@@ -32,11 +32,22 @@ import qualified Language.Haskell.Liquid.GHC.SpanStack         as Sp import           Language.Haskell.Liquid.GHC.Misc             ( idDataConM, hasBaseTypeVar, isDataConId) -- dropModuleNames, simplesymbol) import           Liquid.GHC.API               as Ghc-import           Language.Haskell.Liquid.Misc import           Language.Fixpoint.Misc import           Language.Haskell.Liquid.Constraint.Types -import           Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)+import           Language.Haskell.Liquid.Types.Dictionaries+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.Literals+import           Language.Haskell.Liquid.Types.Meet+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types hiding (binds)+import           Language.Haskell.Liquid.Types.Visitors+import           Language.Haskell.Liquid.UX.Config  -------------------------------------------------------------------------------- initEnv :: TargetInfo -> CG CGEnv@@ -44,7 +55,7 @@ initEnv info   = do let tce   = gsTcEmbeds (gsName sp)        let fVars = giImpVars (giSrc info)-       let dcs   = filter isConLikeId (snd <$> gsFreeSyms (gsName sp))+       let dcs   = gsDataConIds (gsName sp)        let dcs'  = filter isConLikeId fVars        defaults <- forM fVars $ \x -> fmap (x,) (trueTy allowTC $ varType x)        dcsty    <- forM dcs   (makeDataConTypes allowTC)@@ -60,18 +71,18 @@        f40      <- makeExactDc <$> refreshArgs' (vals gsCtors (gsData sp)) -- constructor refinements  (for measures)        f5       <- refreshArgs' $ vals gsInSigs (gsSig sp)                   -- internal refinements     (from Haskell measures)        fi       <- refreshArgs' $ catMaybes $ [(x,) . val <$> getMethodType mt | (x, mt) <- gsMethods $ gsSig $ giSpec info ]-       (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty  (gsAutosize (gsTerm sp)) dcs-       (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (gsAutosize (gsTerm sp)) dcs'+       (invs1, f41) <- traverse refreshArgs' $ makeAutoDecrDataCons dcsty  (gsAutosize (gsTerm sp)) dcs+       (invs2, f42) <- traverse refreshArgs' $ makeAutoDecrDataCons dcsty' (gsAutosize (gsTerm sp)) dcs'        let f4    = mergeDataConTypes tce (mergeDataConTypes tce f40 (f41 ++ f42)) (filter (isDataConId . fst) f2)-       let tx    = mapFst F.symbol . addRInv ialias . predsUnify sp+       let tx    = first F.symbol . addRInv ialias . predsUnify sp        f6       <- map tx . addPolyInfo' <$> refreshArgs' (vals gsRefSigs (gsSig sp))        let bs    = (tx <$> ) <$> [f0 ++ f0' ++ fi, f1 ++ f1', f2, f3 ++ f3', f4, f5]        modify $ \s -> s { dataConTys = f4 }        lt1s     <- gets (F.toListSEnv . cgLits)        let lt2s  = [ (F.symbol x, rTypeSort tce t) | (x, t) <- f1' ]-       let tcb   = mapSnd (rTypeSort tce) <$> concat bs+       let tcb   = fmap (rTypeSort tce) <$> concat bs        let cbs   = giCbs . giSrc $ info-       rTrue   <- mapM (mapSndM (true allowTC)) f6+       rTrue   <- mapM (traverse (true allowTC)) f6        let γ0    = measEnv sp (head bs) cbs tcb lt1s lt2s (f6 ++ bs!!3) (bs!!5) hs info        γ  <- globalize <$> foldM (+=) γ0 ( [("initEnv", x, y) | (x, y) <- concat (rTrue:tail bs)])        return γ {invs = is (invs1 ++ invs2)}@@ -79,9 +90,9 @@     allowTC      = typeclass (getConfig info)     sp           = giSpec info     ialias       = mkRTyConIAl (gsIaliases (gsData sp))-    vals f       = map (mapSnd val) . f+    vals f       = map (fmap val) . f     is autoinv   = mkRTyConInv    (gsInvariants (gsData sp) ++ ((Nothing,) <$> autoinv))-    addPolyInfo' = if reflection (getConfig info) then map (mapSnd addPolyInfo) else id+    addPolyInfo' = if reflection (getConfig info) then map (fmap addPolyInfo) else id      makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs @@ -142,7 +153,7 @@     mXY x tx y ty = meetVarTypes tce (F.pprint x) (getSrcSpan x, tx) (getSrcSpan y, ty)  refreshArgs' :: [(a, SpecType)] -> CG [(a, SpecType)]-refreshArgs' = mapM (mapSndM refreshArgs)+refreshArgs' = mapM (traverse refreshArgs)   -- | TODO: All this *should* happen inside @Bare@ but appears@@ -174,10 +185,15 @@ measEnv sp xts cbs _tcb lt1s lt2s asms itys hs info = CGE   { cgLoc    = Sp.empty   , renv     = fromListREnv (second val <$> gsMeas (gsData sp)) []-  , syenv    = F.fromListSEnv (gsFreeSyms (gsName sp))   , litEnv   = F.fromListSEnv lts   , constEnv = F.fromListSEnv lt2s-  , fenv     = initFEnv $ filterHO (tcb' ++ lts ++ (second (rTypeSort tce . val) <$> gsMeas (gsData sp)))+  , fenv     =+      initFEnv $ filterHO $ concat+        [ tcb'+        , lts+        , second (rTypeSort tce . val) <$> gsMeas (gsData sp)+        , [(F.eqName e, eqSort e) | e <- gsImpAxioms (gsRefl sp)]+        ]   , denv     = dmapty val $ gsDicts (gsSig sp)   , recs     = S.empty   , invs     = mempty@@ -204,6 +220,9 @@       lts         = lt1s ++ lt2s       tcb'        = [] +-- | Constructs the sort of an equation+eqSort :: F.EquationV v -> F.Sort+eqSort e  = foldr (F.FFunc . snd) (F.eqSort e) (F.eqArgs e)  assm :: TargetInfo -> [(Var, SpecType)] assm = assmGrty (giImpVars . giSrc)@@ -244,43 +263,44 @@     measLits  = filter (selF . snd) $ mkSort <$> litF spc     spc       = giSpec info     tce       = gsTcEmbeds (gsName spc)-    mkSort    = mapSnd (F.sr_sort . rTypeSortedReft tce . val)+    mkSort    = fmap (F.sr_sort . rTypeSortedReft tce . val)  initCGI :: Config -> TargetInfo -> CGInfo initCGI cfg info = CGInfo {-    fEnv       = F.emptySEnv-  , hsCs       = []-  , hsWfs      = []-  , fixCs      = []-  , fixWfs     = []-  , freshIndex = 0-  , dataConTys = []-  , binds      = F.emptyBindEnv-  , ebinds     = []-  , annotMap   = AI M.empty-  , newTyEnv   = M.fromList (mapSnd val <$> gsNewTypes (gsSig spc))-  , tyConInfo  = tyi-  , tyConEmbed = tce-  , kuts       = mempty-  , kvPacks    = mempty-  , cgLits     = infoLits (gsMeas . gsData) (const True) info-  , cgConsts   = infoLits (gsMeas . gsData) notFn        info-  , cgADTs     = gsADTs nspc-  , termExprs  = M.fromList [(v, es) | (v, _, es) <- gsTexprs (gsSig spc) ]-  , specLVars  = gsLvars (gsVars spc)-  , specLazy   = dictionaryVar `S.insert` gsLazy tspc-  , specTmVars = gsNonStTerm tspc-  , tcheck     = terminationCheck cfg-  , cgiTypeclass = typeclass cfg-  , pruneRefs  = pruneUnsorted cfg-  , logErrors  = []-  , kvProf     = emptyKVProf-  , recCount   = 0-  , bindSpans  = M.empty-  , autoSize   = gsAutosize tspc-  , allowHO    = higherOrderFlag cfg-  , ghcI       = info-  , unsorted   = F.notracepp "UNSORTED" $ F.makeTemplates $ gsUnsorted $ gsData spc+    fEnv          = F.emptySEnv+  , hsCs          = []+  , hsWfs         = []+  , fixCs         = []+  , fixWfs        = []+  , freshIndex    = 0+  , dataConTys    = []+  , binds         = F.emptyBindEnv+  , localRewrites = mempty+  , ebinds        = []+  , annotMap      = AI M.empty+  , newTyEnv      = M.fromList (fmap val <$> gsNewTypes (gsSig spc))+  , tyConInfo     = tyi+  , tyConEmbed    = tce+  , kuts          = mempty+  , kvPacks       = mempty+  , cgLits        = infoLits (gsMeas . gsData) (const True) info+  , cgConsts      = infoLits (gsMeas . gsData) notFn        info+  , cgADTs        = gsADTs nspc+  , termExprs     = M.fromList [(v, es) | (v, _, es) <- gsTexprs (gsSig spc) ]+  , specLVars     = gsLvars (gsVars spc)+  , specLazy      = dictionaryVar `S.insert` gsLazy tspc+  , specTmVars    = gsNonStTerm tspc+  , tcheck        = terminationCheck cfg+  , cgiTypeclass  = typeclass cfg+  , pruneRefs     = pruneUnsorted cfg+  , logErrors     = []+  , kvProf        = emptyKVProf+  , recCount      = 0+  , bindSpans     = M.empty+  , autoSize      = gsAutosize tspc+  , allowHO       = higherOrderFlag cfg+  , ghcI          = info+  , unsorted      = F.notracepp "UNSORTED" $ F.makeTemplates $ gsUnsorted $ gsData spc   }   where     tce        = gsTcEmbeds nspc@@ -297,9 +317,7 @@   where     src         = giSrc info     lconsts      = literalConst tce <$> literals (giCbs src)-    dcons        = filter isDCon freeVs-    freeVs       = giImpVars src ++ freeSyms-    freeSyms     = fmap snd . gsFreeSyms . gsName . giSpec $ info+    dcons        = filter isDCon $ gsDataConIds $ gsName $ giSpec info     dconToSort   = typeSort tce . expandTypeSynonyms . varType     dconToSym    = F.symbol . idDataCon     isDCon x     = isDataConId x && not (hasBaseTypeVar x)
src/Language/Haskell/Liquid/Constraint/Monad.hs view
@@ -11,7 +11,10 @@  import           Control.Monad import           Control.Monad.State (gets, modify)-import           Language.Haskell.Liquid.Types hiding (loc)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Env import           Language.Fixpoint.Misc hiding (errorstar)
src/Language/Haskell/Liquid/Constraint/Qualifier.hs view
@@ -14,6 +14,8 @@ import qualified Data.HashSet        as S import qualified Data.HashMap.Strict as M import           Debug.Trace (trace)+import           Control.Monad.Reader+ import           Language.Fixpoint.Types                  hiding (panic, mkQual) import qualified Language.Fixpoint.Types.Config as FC import           Language.Fixpoint.SortCheck@@ -23,7 +25,13 @@ import           Language.Haskell.Liquid.Types.PredType import           Liquid.GHC.API hiding (Expr, mkQual, panic) -import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.UX.Config+import Language.Fixpoint.Types.Config (ElabFlags)   --------------------------------------------------------------------------------@@ -48,7 +56,7 @@ maxQualParams :: (HasConfig t) => t -> Int maxQualParams = maxParams . getConfig --- | Use explicitly given qualifiers .spec or source (.hs, .lhs) files+-- | Use explicitly given qualifiers useSpcQuals :: (HasConfig t) => t -> Bool useSpcQuals i = useQuals i && not (useAlsQuals i) @@ -71,11 +79,12 @@ -------------------------------------------------------------------------------- alsQualifiers info lEnv   = [ q | a <- gsRTAliases . gsQual . giSpec $ info-        , q <- refTypeQuals lEnv (loc a) tce (rtBody (val a))+        , q <- refTypeQuals lEnv ef (loc a) tce (rtBody (val a))         , length (qParams q) <= k + 1         , validQual lEnv q     ]     where+      ef  = maybe (FC.ElabFlags False) FC.solverFlags . smtsolver . getConfig $ info       k   = maxQualParams info       tce = gsTcEmbeds . gsName . giSpec $ info @@ -91,34 +100,17 @@ -------------------------------------------------------------------------------- sigQualifiers info lEnv   = [ q | (x, t) <- specBinders info-        , x `S.member` qbs-        , q <- refTypeQuals lEnv (getSourcePos x) tce (val t)+        , not (x `S.member` S.fromList (specAxiomVars info))+        , q <- refTypeQuals lEnv ef (getSourcePos x) tce (val t)         -- NOTE: large qualifiers are VERY expensive, so we only mine         -- qualifiers up to a given size, controlled with --max-params         , length (qParams q) <= k + 1     ]     where+      ef  = maybe (FC.ElabFlags False) FC.solverFlags . smtsolver . getConfig $ info       k   = maxQualParams info       tce = gsTcEmbeds . gsName . giSpec $ info-      qbs = qualifyingBinders info -qualifyingBinders :: TargetInfo -> S.HashSet Var-qualifyingBinders info = S.difference sTake sDrop-  where-    sTake              = S.fromList $ giDefVars src ++ giUseVars src ++ scrapeVars cfg src-    sDrop              = S.fromList $ specAxiomVars info-    cfg                = getConfig info-    src                = giSrc     info---- NOTE: this mines extra, useful qualifiers but causes--- a significant increase in running time, so we hide it--- behind `--scrape-imports` and `--scrape-used-imports`-scrapeVars :: Config -> TargetSrc -> [Var]-scrapeVars cfg src-  | cfg `hasOpt` scrapeUsedImports = giUseVars src-  | cfg `hasOpt` scrapeImports     = giImpVars src-  | otherwise                      = []- specBinders :: TargetInfo -> [(Var, LocSpecType)] specBinders info = mconcat   [ gsTySigs  (gsSig  sp)@@ -152,11 +144,11 @@  -- TODO: rewrite using foldReft' ---------------------------------------------------------------------------------refTypeQuals :: SEnv Sort -> SourcePos -> TCEmb TyCon -> SpecType -> [Qualifier]+refTypeQuals :: SEnv Sort -> ElabFlags -> SourcePos -> TCEmb TyCon -> SpecType -> [Qualifier] ---------------------------------------------------------------------------------refTypeQuals lEnv l tce t0    = go emptySEnv t0+refTypeQuals lEnv ef l tce t0    = go emptySEnv t0   where-    scrape                    = refTopQuals lEnv l tce t0+    scrape                    = refTopQuals lEnv ef l tce t0     add x t γ                 = insertSEnv x (rTypeSort tce t) γ     goBind x t γ t'           = go (add x t γ) t'     go γ t@(RVar _ _)         = scrape γ t@@ -177,19 +169,20 @@  refTopQuals :: (PPrint t, Reftable t, SubsTy RTyVar RSort t, Reftable (RTProp RTyCon RTyVar (UReft t)))             => SEnv Sort+            -> ElabFlags             -> SourcePos             -> TCEmb TyCon             -> RType RTyCon RTyVar r             -> SEnv Sort             -> RRType (UReft t)             -> [Qualifier]-refTopQuals lEnv l tce t0 γ rrt+refTopQuals lEnv ef l tce t0 γ rrt   = [ mkQ' v so pa  | let (RR so (Reft (v, ra))) = rTypeSortedReft tce rrt                    , pa                        <- conjuncts ra                    , not $ isHole    pa                    , not $ isGradual pa                    , notracepp ("refTopQuals: " ++ showpp pa)-                     $ isNothing $ checkSorted (srcSpan l) (insertSEnv v so γ') pa+                     $ isNothing $ runReader (checkSorted (srcSpan l) (insertSEnv v so γ') pa) ef     ]     ++     [ mkP s e | let (MkUReft _ (Pr ps)) = fromMaybe (msg rrt) $ stripRTypeBase rrt
src/Language/Haskell/Liquid/Constraint/Relational.hs view
@@ -40,9 +40,14 @@ import qualified Language.Haskell.Liquid.GHC.SpanStack          as Sp import           Language.Haskell.Liquid.GHC.TypeRep            () import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types                  hiding (Def,-                                                                 Loc, binds,-                                                                 loc)+import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.Literals+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types hiding (binds)+import           Language.Haskell.Liquid.UX.Config import           System.Console.CmdArgs.Verbosity               (whenLoud) import           System.IO.Unsafe                               (unsafePerformIO) @@ -321,7 +326,7 @@     e' = subVarAndTy z z' e unapply _ _ _ (_ : _) t _ _ = F.panic $ "can't unapply type " ++ F.showpp t unapply γ y yt [] t e _ = do-  let yt' = t `F.meet` yt+  let yt' = t `meet` yt   γ' <- γ += ("unapply res", y, yt')   return $ traceWhenLoud ("SCRUTINEE " ++ F.showpp (y, yt')) (γ', e) @@ -526,7 +531,7 @@     consRelSub γ s1 s2 qr2 qr1     γ' <- γ += ("consRelSub HOF", F.symbol g1, s1)     γ'' <- γ' += ("consRelSub HOF", F.symbol g2, s2)-    let psubst = unapplyArg resL g1 <> unapplyArg resR g2+    let psubst x = unapplyArg resL g1 x F.&.& unapplyArg resR g2 x     consRelSub γ'' t1 t2 (psubst p1) (psubst p2) consRelSub γ f1@(RFun g1 _ s1@RFun{} t1 _) f2@(RFun g2 _ s2@RFun{} t2 _)              pr1@(F.PAnd [F.PImp qr1@F.PImp{} p1])            pr2@(F.PImp qr2@F.PImp{} p2)@@ -534,7 +539,7 @@     consRelSub γ s1 s2 qr2 qr1     γ' <- γ += ("consRelSub HOF", F.symbol g1, s1)     γ'' <- γ' += ("consRelSub HOF", F.symbol g2, s2)-    let psubst = unapplyArg resL g1 <> unapplyArg resR g2+    let psubst x = unapplyArg resL g1 x F.&.& unapplyArg resR g2 x     consRelSub γ'' t1 t2 (psubst p1) (psubst p2) consRelSub γ f1@(RFun x1 _ s1 e1 _) f2 p1 p2 =   traceSub "fun" f1 f2 p1 p2 $ do@@ -771,7 +776,9 @@ traceUSyn expr e cg = do   t <- cg   trace (expr ++ " To SYNTH UNARY") e dummy t dummy dummy cg-  where dummy = F.PTrue+  where+    dummy :: F.Expr+    dummy = F.PTrue  trace   :: (PPrint e, PPrint d, PPrint t, PPrint s, PPrint p)
+ src/Language/Haskell/Liquid/Constraint/RewriteCase.hs view
@@ -0,0 +1,138 @@+module Language.Haskell.Liquid.Constraint.RewriteCase +    (getCaseRewrites) +    where++import           Language.Fixpoint.Types+import qualified Language.Fixpoint.Misc as M+import           Language.Haskell.Liquid.Constraint.Types+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.RType++import           Data.Maybe+import           Data.Tuple++import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S++getCaseRewrites :: CGEnv -> SpecType -> LocalRewrites+getCaseRewrites γ spec =+    let Reft (_, refinement) = ur_reft $ rt_reft spec+        -- Names of constustors both type constructors and data constructors+        ctors   = toSet $ seBinds  $ constEnv γ+        -- All the global names (top level functions, types, etc...)+        globals = toSet $ reGlobal $ renv     γ+    in unloop+       $ concatMap (uncurry $ unify ctors globals)+       $ groupUnifiableEqualities +       $ getEqualities refinement+    where toSet = S.fromList . M.keys++-- | Generates substitutions for non-global variables that make @e1@ and @e2@+-- equal.+--+-- If @v@ is not global, and @C@ is a data constructor+--+--  * @v@ and @e2@ produces @(v, e2)@+--  * @e1@ and @v@ produces @(e1, v)@+--  * @C a₁ ... aₙ@ and @C b₁ ... bₙ@ produces the substitutions from unifying+--    @(a₁, b₁), ..., (aₙ, bₙ)@+--+-- If any unification fails, the substitutions from the unifications that+-- succeed are still produced.+--+unify :: S.HashSet Symbol -> S.HashSet Symbol -> Expr -> Expr -> [(Symbol, Expr)]+unify ctors globals = go+    where+        go e1 e2 | e1 == e2 = []+        -- NOTE: We don't need to check for ECst because the expressions arent+        -- elaborated+        go (EVar s1) e2 | isLocal s1 = [(s1, e2)]+        go e1 (EVar s2) | isLocal s2 = [(s2, e1)]+        -- TODO: Tecnically we could also unify under lambdas but you have to be+        -- carefull about alpha equivalence idk if the effort is worth it.+        go e1 e2 +            -- Performing the unification under constructor is safe because +            -- C a₁ ... aₙ = C b₁ ... bₙ ⟺ ∀ n . a₁ = bₙ+            | (EVar name1 , args1) <- splitEApp e2+            , (EVar name2 , args2) <- splitEApp e1+            , name1 == name2+            , isCtor name1+            , length args1 == length args2+            = concat $ zipWith go args1 args2+        go _ _ = []++        isCtor  name = name `S.member` ctors+        isLocal name = not (name `S.member` globals +                           || name `S.member` ctors+                           || isPrefixOfSym anfPrefix name)+++-- | Given a list of equalities this function produces the equalities that+-- result from applying transitivity exactly once. For instance, if we have+-- @[e1=e2, e2=e3, e1=e4]@ this function will produce @[e1=e3, e2=e4]@.+groupUnifiableEqualities :: [(Expr, Expr)] -> [(Expr, Expr)]+groupUnifiableEqualities = concat . concatMap mkEqs . grouping+  where+    mkEqs (e1 : es) = [ (e1, e) | e <- es ] : mkEqs es+    mkEqs _         = []++    grouping eqs = fmap snd $ M.groupList $ eqs ++ fmap swap eqs++getEqualities :: Expr -> [(Expr, Expr)]+getEqualities (PAtom Eq e1 e2) = [(e1, e2)]+getEqualities (PAnd eqs)       = concatMap getEqualities eqs+getEqualities _                = []+++-- +-----------------------------------------------------++-- | AcyclicRewrites: collection of rewrites that cannot |+-- | cause an infinite loop                              |+-- +-----------------------------------------------------++-- This could be extracted as a separate module++-- | A collection of rewrites that cannot cause an infinite loop+newtype AcyclicRewrites = AR (M.HashMap Symbol Expr)++-- We can think of the map as a directed graph where every symbol is a vertex and+-- there is an edge v₁ → v₂ if v₂ is free in the expression that v₁ is rewritten to.+-- To guarantee that the set of rewrite rules is terminating, we ensure that there+-- aren't any cycles in the graph.++-- | Drops rewrites that would cause an infinite loop. The procedure is order+-- biased as rewrites earlier in the list take precedence.+unloop :: [(Symbol, Expr)] -> LocalRewrites+unloop = LocalRewrites . toRewrites . foldl' doInsert empty +    where doInsert ar (s, e) = ar `fromMaybe` insert ar s e ++-- | Get the "raw" list of rewrites+toRewrites :: AcyclicRewrites -> M.HashMap Symbol Expr+toRewrites (AR m) = m++-- | @existsPth g s1 s2@ yields @True@ checks if there is a path from @s1@ to @s2@+-- in @g@. Time is @O(Σ(e ∈ m) |exprSymbolSet e|)@, or said otherwise, it is @O(m)@+-- where @m@ is the number of edges.+existsPath :: AcyclicRewrites -> Symbol -> Symbol -> Bool+existsPath (AR m) s1' s2 = go s1'+  where+    -- Since m is a DAG, we can use DFS to check if there is a path from s1 to+    -- s2 without worrying about infinite loops+    go s1 | s1 == s2 = True+    go s1 | Just e <- M.lookup s1 m+          = any go $ S.toList $ exprSymbolsSet e+    go _ = False++-- | Constructs an empty set of rewrites+empty :: AcyclicRewrites+empty = AR M.empty++-- | Inserts the rewrite if it wont't cause an infinite loop+insert :: AcyclicRewrites -> Symbol -> Expr -> Maybe AcyclicRewrites+insert ar s e | not $ s `S.member` exprSymbolsSet e+              , not $ any (\s2 -> existsPath ar s2 s) $ S.toList $ exprSymbolsSet e+              -- There are two ways to break the DAG invariant+              -- 1. If the rewrite is closing a loop+              -- 2. If the rewrite by itself is a cycle+              = Just $ insertUnsafe ar s e+              | otherwise +              = Nothing+    where insertUnsafe (AR m) s' e' = AR $ M.insert s' e' m
src/Language/Haskell/Liquid/Constraint/Split.hs view
@@ -40,7 +40,16 @@  import           Language.Haskell.Liquid.Misc -- (concatMapM) import qualified Language.Haskell.Liquid.UX.CTags       as Tg-import           Language.Haskell.Liquid.Types hiding (loc)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.PredType+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Variance+import           Language.Haskell.Liquid.UX.Config+import           Language.Haskell.Liquid.UX.Tidy ()   import           Language.Haskell.Liquid.Constraint.Types@@ -118,7 +127,7 @@      isHO  <- gets allowHO      return $ bsplitW' γ t temp isHO -bsplitW' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+bsplitW' :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))          => CGEnv -> RRType r -> F.Templates -> Bool -> [F.WfC Cinfo] bsplitW' γ t temp isHO   | isHO || F.isNonTrivial r'@@ -267,7 +276,7 @@     vv  = "vvRec"     ci  = Ci src err (cgVar γ)     err = Just $ ErrAssType src o (text $ show o ++ "type error") g (rHole rr)-    rr  = F.toReft r+    rr  = toReft r     tag = getTag γ     src = getLocation γ     g   = reLocal $ renv γ@@ -432,10 +441,10 @@ forallExprReftLookup :: CGEnv                      -> F.Symbol                      -> Maybe ([F.Symbol], [RFInfo], [SpecType], [RReft], SpecType)-forallExprReftLookup γ sym = snap <$> F.lookupSEnv sym (syenv γ)+forallExprReftLookup γ sym = snap <$> lookup' sym   where-    snap     = mapFifth5 ignoreOblig . (\((x,a,b,c),t)->(x,a,b,c,t)) . bkArrow . thd3 . bkUniv . lookup'-    lookup' z = fromMaybe (panicUnbound γ z) (γ ?= F.symbol z)+    snap     = mapFifth5 ignoreOblig . (\((x,a,b,c),t)->(x,a,b,c,t)) . bkArrow . thd3 . bkUniv+    lookup' z = γ ?= F.symbol z   --------------------------------------------------------------------------------
src/Language/Haskell/Liquid/Constraint/Template.hs view
@@ -24,11 +24,16 @@ import           GHC.Core (CoreExpr) import           GHC.Core.Utils ( exprType ) import qualified Language.Fixpoint.Types                       as F-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Env ( lookupREnv, (+=) ) import           Language.Haskell.Liquid.Constraint.Monad (addPost, addW) import           Language.Haskell.Liquid.Constraint.Fresh (refreshArgsTop, freshTyExpr)+import           Language.Haskell.Liquid.UX.Config  -- Template
src/Language/Haskell/Liquid/Constraint/Termination.hs view
@@ -25,18 +25,18 @@ import           Text.PrettyPrint.HughesPJ ( (<+>), text ) import qualified Language.Haskell.Liquid.GHC.Misc                    as GM import qualified Language.Fixpoint.Types            as F-import           Language.Fixpoint.Types.PrettyPrint (PPrint) import           Language.Haskell.Liquid.Constraint.Types (CG, CGInfo (..), CGEnv, makeRecInvariants) import           Language.Haskell.Liquid.Constraint.Monad (addWarning) import           Language.Haskell.Liquid.Constraint.Env (setTRec) import           Language.Haskell.Liquid.Constraint.Template ( Template(..), unTemplate, varTemplate, safeFromAsserted, extender )-import           Language.Haskell.Liquid.Transforms.Rec (isIdTRecBound)-import           Language.Haskell.Liquid.Types (refreshArgs, HasConfig (..), toRSort)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Fresh+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.Types-  (SpecType, TError (..), RType (..), RTypeRep (..), Oblig (..), Error, Config (..), RReft,-   toRTypeRep, structuralTerm, bkArrowDeep, mkArrow, bkUniv, bkArrow, fromRTypeRep) import           Language.Haskell.Liquid.Types.RefType (isDecreasing, makeDecrType, makeLexRefa, makeNumEnv) import           Language.Haskell.Liquid.Misc (safeFromLeft, replaceN, (<->), zip4, safeFromJust, fst5)+import           Language.Haskell.Liquid.UX.Config import qualified Liquid.GHC.API as GHC  @@ -91,21 +91,21 @@ -- | TERMINATION TYPE ---------------------------------------------------------- -------------------------------------------------------------------------------- -makeDecrIndex :: (GHC.Var, Template SpecType, [GHC.Var]) -> CG (Maybe Int)-makeDecrIndex (x, Assumed t, args)-  = do dindex <- makeDecrIndexTy x t args+makeDecrIndex :: (GHC.Var, Template SpecType) -> CG (Maybe Int)+makeDecrIndex (x, Assumed t)+  = do dindex <- makeDecrIndexTy x t        case dindex of          Left msg -> addWarning msg >> return Nothing          Right i -> return $ Just i-makeDecrIndex (x, Asserted t, args)-  = do dindex <- makeDecrIndexTy x t args+makeDecrIndex (x, Asserted t)+  = do dindex <- makeDecrIndexTy x t        case dindex of          Left msg -> addWarning msg >> return Nothing          Right i  -> return $ Just i makeDecrIndex _ = return Nothing -makeDecrIndexTy :: GHC.Var -> SpecType -> [GHC.Var] -> CG (Either (TError t) Int)-makeDecrIndexTy x st args+makeDecrIndexTy :: GHC.Var -> SpecType -> CG (Either (TError t) Int)+makeDecrIndexTy x st   = do autosz <- gets autoSize        return $ case dindex autosz of          Nothing -> Left msg@@ -114,11 +114,10 @@        msg  = ErrTermin (GHC.getSrcSpan x) [F.pprint x] (text "No decreasing parameter")        trep = toRTypeRep $ unOCons st        ts   = ty_args trep-       tvs  = zip ts args        cenv = makeNumEnv ts -       p autosz (t, v)   = isDecreasing autosz cenv t && not (isIdTRecBound v)-       dindex     autosz = L.findIndex (p autosz) tvs+       p autosz t = isDecreasing autosz cenv t+       dindex     autosz = L.findIndex (p autosz) ts  recType :: F.Symbolic a         => S.HashSet GHC.TyCon@@ -186,7 +185,7 @@        autoenv  <- gets autoSize        ts       <- forM ts' $ T.mapM refreshArgs        let vs    = zipWith collectArgs' ts es-       is       <- mapM makeDecrIndex (zip3 vars ts vs) >>= checkSameLens+       is       <- mapM makeDecrIndex (zip vars ts) >>= checkSameLens        let xeets = zipWith (\v i -> [((v,i), x) | x <- zip3 vars is $ map unTemplate ts]) vs is        _        <- mapM checkIndex (zip4 vars vs ts is) >>= checkEqTypes        let rts   = (recType autoenv <$>) <$> xeets
src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -24,7 +24,7 @@  -- AT: Move to own module? -- imports for AxiomEnv-import qualified Language.Haskell.Liquid.UX.Config as Config+import           Language.Haskell.Liquid.UX.Config import           Language.Haskell.Liquid.UX.DiffCheck (coreDefs, coreDeps, dependsOn, Def(..)) import qualified Language.Haskell.Liquid.GHC.Misc  as GM -- (simplesymbol) import qualified Data.List                         as L@@ -33,7 +33,11 @@ -- import           Language.Fixpoint.Misc import qualified Language.Haskell.Liquid.Misc      as Misc -import           Language.Haskell.Liquid.Types hiding     ( binds )+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types hiding     ( binds )  fixConfig :: FilePath -> Config -> FC.Config fixConfig tgt cfg = def@@ -55,8 +59,10 @@   , FC.gradual                  = gradual           cfg   , FC.ginteractive             = ginteractive       cfg   , FC.noslice                  = noslice           cfg-  , FC.rewriteAxioms            = Config.allowPLE   cfg-  , FC.pleWithUndecidedGuards   = Config.pleWithUndecidedGuards cfg+  , FC.rewriteAxioms            = allowPLE   cfg+  , FC.pleWithUndecidedGuards   = pleWithUndecidedGuards cfg+  , FC.etabeta                  = etabeta    cfg+  , FC.localRewrites            = dependantCase cfg   , FC.etaElim                  = not (exactDC cfg) && extensionality cfg -- SEE: https://github.com/ucsd-progsys/liquidhaskell/issues/1601   , FC.extensionality           = extensionality    cfg   , FC.interpreter              = interpreter    cfg@@ -72,7 +78,7 @@ cgInfoFInfo info cgi = return (targetFInfo info cgi)  targetFInfo :: TargetInfo -> CGInfo -> F.FInfo Cinfo-targetFInfo info cgi = mappend (mempty { F.ae = ax }) fi+targetFInfo info cgi = mappend (mempty { F.ae = ax, F.lrws = localRewrites cgi }) fi   where     fi               = F.fi cs ws bs ls consts ks qs bi aHO aHOqs es mempty adts ebs     cs               = fixCs    cgi@@ -160,7 +166,7 @@ refinementEQs t =   case stripRTypeBase tres of     Just r ->-      [ (lhs, rhs) | (F.EEq lhs rhs) <- F.splitPAnd $ F.reftPred (F.toReft r) ]+      [ (lhs, rhs) | (F.EEq lhs rhs) <- F.splitPAnd $ F.reftPred (toReft r) ]     Nothing ->       []   where@@ -181,8 +187,8 @@      xs = do       (sym, arg) <- zip (ty_binds tRep) (ty_args tRep)-      let e = maybe F.PTrue (F.reftPred . F.toReft) (stripRTypeBase arg)-      return $ F.RR (rTypeSort tce arg) (F.Reft (sym, e))+      let e = maybe F.PTrue (F.reftPred . toReft) (stripRTypeBase arg)+      return $ F.RR (RT.rTypeSort tce arg) (F.Reft (sym, e))      tRep = toRTypeRep $ val t @@ -198,8 +204,8 @@   doExpand :: TargetSpec -> Config -> F.SubC Cinfo -> Bool-doExpand sp cfg sub = Config.allowGlobalPLE cfg-                   || (Config.allowLocalPLE cfg && maybe False (isPLEVar sp) (subVar sub))+doExpand sp cfg sub = allowGlobalPLE cfg+                   || (allowLocalPLE cfg && maybe False (isPLEVar sp) (subVar sub))  -- [TODO:missing-sorts] data-constructors often have unelaboratable 'define' so either -- 1. Make `elaborate` robust so it doesn't crash and returns maybe or@@ -288,17 +294,17 @@   where     res       = specTypeToResultRef expr st     args      = zipWith mkExpr (mkReft <$> ts) es-    mkReft t  =  F.toReft $ Mb.fromMaybe mempty (stripRTypeBase t)+    mkReft t  =  toReft $ Mb.fromMaybe mempty (stripRTypeBase t)     mkExpr (F.Reft (v, ev)) e = F.subst1 ev (v, e)       ok      = okLen && okClass && okArgs     okLen   = length xs == length xs-    okClass = all (F.isTauto . snd) cls+    okClass = all (isTauto . snd) cls     okArgs  = all okArg ts      okArg (RVar _ _) = True-    okArg t@RApp{}   = F.isTauto (t{rt_reft = mempty})+    okArg t@RApp{}   = isTauto (t{rt_reft = mempty})     okArg _          = False  @@ -312,7 +318,7 @@  specTypeToResultRef :: F.Expr -> SpecType -> F.Expr specTypeToResultRef e t-  = mkExpr $ F.toReft $ Mb.fromMaybe mempty (stripRTypeBase $ ty_res trep)+  = mkExpr $ toReft $ Mb.fromMaybe mempty (stripRTypeBase $ ty_res trep)   where     mkExpr (F.Reft (v, ev)) = F.subst1 ev (v, e)     trep                   = toRTypeRep t
src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -75,15 +75,20 @@ import           Language.Fixpoint.Misc  import qualified Language.Haskell.Liquid.UX.CTags      as Tg+import           Language.Haskell.Liquid.UX.Config -import           Language.Haskell.Liquid.Types hiding   (binds)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types hiding (binds)  type CG = State CGInfo  data CGEnv = CGE   { cgLoc    :: !SpanStack         -- ^ Location in original source file   , renv     :: !REnv              -- ^ SpecTypes for Bindings in scope-  , syenv    :: !(F.SEnv Var)      -- ^ Map from free Symbols (e.g. datacons) to Var   , denv     :: !RDEnv             -- ^ Dictionary Environment   , litEnv   :: !(F.SEnv F.Sort)   -- ^ Global  literals   , constEnv :: !(F.SEnv F.Sort)   -- ^ Distinct literals@@ -200,39 +205,40 @@ -- | Generation: Types --------------------------------------------------------- -------------------------------------------------------------------------------- data CGInfo = CGInfo-  { fEnv       :: !(F.SEnv F.Sort)                    -- ^ top-level fixpoint env-  , hsCs       :: ![SubC]                             -- ^ subtyping constraints over RType-  , hsWfs      :: ![WfC]                              -- ^ wellformedness constraints over RType-  , fixCs      :: ![FixSubC]                          -- ^ subtyping over Sort (post-splitting)-  , fixWfs     :: ![FixWfC]                           -- ^ wellformedness constraints over Sort (post-splitting)-  , freshIndex :: !Integer                            -- ^ counter for generating fresh KVars-  , binds      :: !FixBindEnv                         -- ^ set of environment binders-  , ebinds     :: ![F.BindId]                         -- ^ existentials-  , annotMap   :: !(AnnInfo (Annot SpecType))         -- ^ source-position annotation map-  , tyConInfo  :: !TyConMap                           -- ^ information about type-constructors-  , newTyEnv   :: !(M.HashMap Ghc.TyCon SpecType)     -- ^ Mapping of new type type constructors with their refined types.-  , termExprs  :: !(M.HashMap Var [F.Located F.Expr]) -- ^ Terminating Metrics for Recursive functions-  , specLVars  :: !(S.HashSet Var)                    -- ^ Set of variables to ignore for termination checking-  , specLazy   :: !(S.HashSet Var)                    -- ^ "Lazy binders", skip termination checking-  , specTmVars :: !(S.HashSet Var)                    -- ^ Binders that FAILED struct termination check that MUST be checked-  , autoSize   :: !(S.HashSet Ghc.TyCon)              -- ^ ? FIX THIS-  , tyConEmbed :: !(F.TCEmb Ghc.TyCon)                -- ^ primitive Sorts into which TyCons should be embedded-  , kuts       :: !F.Kuts                             -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)-  , kvPacks    :: ![S.HashSet F.KVar]                 -- ^ Fixpoint "packs" of correlated kvars-  , cgLits     :: !(F.SEnv F.Sort)                    -- ^ Global symbols in the refinement logic-  , cgConsts   :: !(F.SEnv F.Sort)                    -- ^ Distinct constant symbols in the refinement logic-  , cgADTs     :: ![F.DataDecl]                       -- ^ ADTs extracted from Haskell 'data' definitions-  , tcheck     :: !Bool                               -- ^ Check Termination (?)-  , cgiTypeclass :: !Bool                             -- ^ Enable typeclass support-  , pruneRefs  :: !Bool                               -- ^ prune unsorted refinements-  , logErrors  :: ![Error]                            -- ^ Errors during constraint generation-  , kvProf     :: !KVProf                             -- ^ Profiling distribution of KVars-  , recCount   :: !Int                                -- ^ number of recursive functions seen (for benchmarks)-  , bindSpans  :: M.HashMap F.BindId SrcSpan          -- ^ Source Span associated with Fixpoint Binder-  , allowHO    :: !Bool-  , ghcI       :: !TargetInfo-  , dataConTys :: ![(Var, SpecType)]                  -- ^ Refined Types of Data Constructors-  , unsorted   :: !F.Templates                        -- ^ Potentially unsorted expressions+  { fEnv          :: !(F.SEnv F.Sort)                    -- ^ top-level fixpoint env+  , hsCs          :: ![SubC]                             -- ^ subtyping constraints over RType+  , hsWfs         :: ![WfC]                              -- ^ wellformedness constraints over RType+  , fixCs         :: ![FixSubC]                          -- ^ subtyping over Sort (post-splitting)+  , fixWfs        :: ![FixWfC]                           -- ^ wellformedness constraints over Sort (post-splitting)+  , freshIndex    :: !Integer                            -- ^ counter for generating fresh KVars+  , binds         :: !FixBindEnv                         -- ^ set of environment binders+  , localRewrites :: !F.LocalRewritesEnv                 -- ^ set of local rewrites+  , ebinds        :: ![F.BindId]                         -- ^ existentials+  , annotMap      :: !(AnnInfo (Annot SpecType))         -- ^ source-position annotation map+  , tyConInfo     :: !TyConMap                           -- ^ information about type-constructors+  , newTyEnv      :: !(M.HashMap Ghc.TyCon SpecType)     -- ^ Mapping of new type type constructors with their refined types.+  , termExprs     :: !(M.HashMap Var [F.Located F.Expr]) -- ^ Terminating Metrics for Recursive functions+  , specLVars     :: !(S.HashSet Var)                    -- ^ Set of variables to ignore for termination checking+  , specLazy      :: !(S.HashSet Var)                    -- ^ "Lazy binders", skip termination checking+  , specTmVars    :: !(S.HashSet Var)                    -- ^ Binders that FAILED struct termination check that MUST be checked+  , autoSize      :: !(S.HashSet Ghc.TyCon)              -- ^ ? FIX THIS+  , tyConEmbed    :: !(F.TCEmb Ghc.TyCon)                -- ^ primitive Sorts into which TyCons should be embedded+  , kuts          :: !F.Kuts                             -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)+  , kvPacks       :: ![S.HashSet F.KVar]                 -- ^ Fixpoint "packs" of correlated kvars+  , cgLits        :: !(F.SEnv F.Sort)                    -- ^ Global symbols in the refinement logic+  , cgConsts      :: !(F.SEnv F.Sort)                    -- ^ Distinct constant symbols in the refinement logic+  , cgADTs        :: ![F.DataDecl]                       -- ^ ADTs extracted from Haskell 'data' definitions+  , tcheck        :: !Bool                               -- ^ Check Termination (?)+  , cgiTypeclass  :: !Bool                               -- ^ Enable typeclass support+  , pruneRefs     :: !Bool                               -- ^ prune unsorted refinements+  , logErrors     :: ![Error]                            -- ^ Errors during constraint generation+  , kvProf        :: !KVProf                             -- ^ Profiling distribution of KVars+  , recCount      :: !Int                                -- ^ number of recursive functions seen (for benchmarks)+  , bindSpans     :: M.HashMap F.BindId SrcSpan          -- ^ Source Span associated with Fixpoint Binder+  , allowHO       :: !Bool+  , ghcI          :: !TargetInfo+  , dataConTys    :: ![(Var, SpecType)]                  -- ^ Refined Types of Data Constructors+  , unsorted      :: !F.Templates                        -- ^ Potentially unsorted expressions   }  @@ -295,7 +301,7 @@ -------------------------------------------------------------------------------- mkRTyConInv tss = group [ (c, RInv (go ts) t v) | (v, t@(RApp c ts _ _)) <- strip <$> tss]   where-    strip = mapSnd (thrd3 . bkUniv . val)+    strip = fmap (thrd3 . bkUniv . val)     go ts | generic (toRSort <$> ts) = []           | otherwise                = toRSort <$> ts @@ -351,13 +357,13 @@ conjoinInvariant :: SpecType -> SpecType -> SpecType conjoinInvariant (RApp c ts rs r) (RApp ic its _ ir)   | c == ic && length ts == length its-  = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir)+  = RApp c (zipWith conjoinInvariantShift ts its) rs (r `meet` ir)  conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir)-  = t { rt_reft = r `F.meet` ir }+  = t { rt_reft = r `meet` ir }  conjoinInvariant t@(RVar _ r) (RVar _ ir)-  = t { rt_reft = r `F.meet` ir }+  = t { rt_reft = r `meet` ir }  conjoinInvariant t _   = t@@ -386,7 +392,7 @@      guard' (RApp c ts rs r)       | Just f <- szFun <$> sizeFunction (rtc_info c)-      = RApp c ts rs (MkUReft (ref f $ F.toReft r) mempty)+      = RApp c ts rs (MkUReft (ref f $ toReft r) mempty)       | otherwise       = RApp c ts rs mempty     guard' t@@ -430,9 +436,8 @@   rnf (RInv x y z) = rnf x `seq` rnf y `seq` rnf z  instance NFData CGEnv where-  rnf (CGE x1 _ x3 _ x4 x5 x55 x6 x7 x8 x9 _ _ _ x10 _ _ _ _ _ _ _ _ _ _)-    = x1 `seq` {- rnf x2 `seq` -} seq x3-         `seq` rnf x5+  rnf (CGE x1 _ _ x4 x5 x55 x6 x7 x8 x9 _ _ _ x10 _ _ _ _ _ _ _ _ _ _)+    = x1 `seq` rnf x5          `seq` rnf x55          `seq` rnf x6          `seq` x7
− src/Language/Haskell/Liquid/GHC/CoreToLogic.hs 
@@ -1,54 +0,0 @@-module Language.Haskell.Liquid.GHC.CoreToLogic where--coreToLogic :: String-coreToLogic = unlines-  [ "define Data.Set.Base.singleton x      = (Set_sng x)"-  , "define Data.Set.Base.union x y        = (Set_cup x y)"-  , "define Data.Set.Base.intersection x y = (Set_cap x y)"-  , "define Data.Set.Base.difference x y   = (Set_dif x y)"-  , "define Data.Set.Base.empty            = (Set_empty 0)"-  , "define Data.Set.Base.null x           = (Set_emp x)"-  , "define Data.Set.Base.member x xs      = (Set_mem x xs)"-  , "define Data.Set.Base.isSubsetOf x y   = (Set_sub x y)"-  , "define Data.Set.Base.fromList xs      = (listElts xs)"-  , ""-  , "define Data.Set.Internal.singleton x      = (Set_sng x)"-  , "define Data.Set.Internal.union x y        = (Set_cup x y)"-  , "define Data.Set.Internal.intersection x y = (Set_cap x y)"-  , "define Data.Set.Internal.difference x y   = (Set_dif x y)"-  , "define Data.Set.Internal.empty            = (Set_empty 0)"-  , "define Data.Set.Internal.null x           = (Set_emp x)"-  , "define Data.Set.Internal.member x xs      = (Set_mem x xs)"-  , "define Data.Set.Internal.isSubsetOf x y   = (Set_sub x y)"-  , "define Data.Set.Internal.fromList xs      = (listElts xs)"-  , ""-  , "define GHC.Internal.Real.fromIntegral x = (x)"-  , ""-  , "define GHC.Types.True                 = (true)"-  , "define GHC.Internal.Real.div x y      = (x / y)"-  , "define GHC.Internal.Real.mod x y      = (x mod y)"-  , "define GHC.Classes.not x              = (~ x)"-  , "define GHC.Internal.Base.$ f x        = (f x)"-  , ""-  , "define Language.Haskell.Liquid.Bag.get k m   = (Map_select m k)"-  , "define Language.Haskell.Liquid.Bag.put k m   = (Map_store m k (1 + (Map_select m k)))"-  , "define Language.Haskell.Liquid.Bag.union m n = (Map_union  m n)"-  , "define Language.Haskell.Liquid.Bag.empty     = (Map_default 0)"-  , ""-  , "define Data.Map.Base.insert k v m     = (Map_store m k v)"-  , "define Data.Map.Base.select k v       = (Map_select m k)"-  , ""-  , "define Language.Haskell.Liquid.String.stringEmp = (stringEmp)"-  , "define Data.RString.RString.stringEmp = (stringEmp)"-  , "define String.stringEmp  = (stringEmp)"-  , "define Main.mempty       = (mempty)"-  , "define Language.Haskell.Liquid.ProofCombinators.cast x y = (y)"-  , "define Language.Haskell.Liquid.ProofCombinators.withProof x y = (x)"-  , "define ProofCombinators.cast x y = (y)"-  , "define Liquid.ProofCombinators.cast x y = (y)"-  , "define Control.Parallel.Strategies.withStrategy s x = (x)"-  , ""-  , "define Language.Haskell.Liquid.Equational.eq x y = (y)"-  , ""-  , "define GHC.CString.unpackCString# x = x"-  ]
src/Language/Haskell/Liquid/GHC/Interface.hs view
@@ -26,23 +26,15 @@    -- * Internal exports (provisional)   , extractSpecComments-  , extractSpecQuotes'-  , makeLogicMap+  , listLMap   , classCons   , derivedVars   , importVars-  , allImports-  , qualifiedImports   , modSummaryHsFile   , makeFamInstEnv-  , parseSpecFile   , clearSpec   , checkFilePragmas-  , keepRawTokenStream-  , ignoreInline-  , lookupTyThings-  , availableTyCons-  , availableVars+  , lookupTyThing   , updLiftedSpec   ) where @@ -62,37 +54,28 @@ import Control.Monad import Control.Monad.Trans.Maybe -import Data.Data import Data.List hiding (intersperse) import Data.Maybe -import Data.Generics.Aliases (mkT)-import Data.Generics.Schemes (everywhere)- import qualified Data.HashSet        as S -import System.IO-import Text.Megaparsec.Error import Text.PrettyPrint.HughesPJ        hiding (first, (<>)) import Language.Fixpoint.Types          hiding (err, panic, Error, Result, Expr) import qualified Language.Fixpoint.Misc as Misc-import qualified Language.Haskell.Liquid.GHC.CoreToLogic as CoreToLogic import Language.Haskell.Liquid.GHC.Misc import Language.Haskell.Liquid.GHC.Types (MGIModGuts(..)) import Language.Haskell.Liquid.GHC.Play import Language.Haskell.Liquid.WiredIn (isDerivedInstance) import qualified Language.Haskell.Liquid.Measure  as Ms-import qualified Language.Haskell.Liquid.Misc     as Misc-import Language.Haskell.Liquid.Parse-import Language.Haskell.Liquid.Types hiding (Spec)--- import Language.Haskell.Liquid.Types.PrettyPrint--- import Language.Haskell.Liquid.Types.Visitors-import Language.Haskell.Liquid.UX.QuasiQuoter+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.PrettyPrint+import Language.Haskell.Liquid.Types.Specs+import Language.Haskell.Liquid.Types.Types+import Language.Haskell.Liquid.Types.Visitors+import Language.Haskell.Liquid.UX.Config import Language.Haskell.Liquid.UX.Tidy -import qualified Debug.Trace as Debug - -------------------------------------------------------------------------------- -- | Extract Ids --------------------------------------------------------------- --------------------------------------------------------------------------------@@ -154,85 +137,12 @@ clearSpec :: Ms.BareSpec -> Ms.BareSpec clearSpec s = s { sigs = [], asmSigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] } -keepRawTokenStream :: ModSummary -> ModSummary-keepRawTokenStream modSummary = modSummary-  { ms_hspp_opts = ms_hspp_opts modSummary `gopt_set` Opt_KeepRawTokenStream }--_impThings :: [Var] -> [TyThing] -> [TyThing]-_impThings vars  = filter ok-  where-    vs          = S.fromList vars-    ok (AnId x) = S.member x vs-    ok _        = True--allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol-allImports = \case-  []-> Debug.trace "WARNING: Missing RenamedSource" mempty-  imps -> S.fromList (symbol . unLoc . ideclName . unLoc <$> imps)--qualifiedImports :: [LImportDecl GhcRn] -> QImports-qualifiedImports = \case-  []   -> Debug.trace "WARNING: Missing RenamedSource" (qImports mempty)-  imps -> qImports [ (qn, n) | i         <- imps-                                          , let decl   = unLoc i-                                          , let m      = unLoc (ideclName decl)-                                          , qm        <- maybeToList (unLoc <$> ideclAs decl)-                                          , let [n,qn] = symbol <$> [m, qm]-                                          ]--qImports :: [(Symbol, Symbol)] -> QImports-qImports qns  = QImports-  { qiNames   = Misc.group qns-  , qiModules = S.fromList (snd <$> qns)-  }--------------------------------------------------------------------------------------------- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC---   for this module; we will use this to create our name-resolution environment---   (see `Bare.Resolve`)-----------------------------------------------------------------------------------------lookupTyThings :: HscEnv -> TcGblEnv -> IO [(Name, Maybe TyThing)]-lookupTyThings hscEnv tcGblEnv = forM names (lookupTyThing hscEnv tcGblEnv)-  where-    names :: [Ghc.Name]-    names  = liftM2 (++)-             (fmap Ghc.greName . Ghc.globalRdrEnvElts . tcg_rdr_env)-             (fmap is_dfun_name . tcg_insts) tcGblEnv--- | Lookup a single 'Name' in the GHC environment, yielding back the 'Name' alongside the 'TyThing',--- if one is found.-lookupTyThing :: HscEnv -> TcGblEnv -> Name -> IO (Name, Maybe TyThing)-lookupTyThing hscEnv tcGblEnv n = do-  mty <- runMaybeT $-         MaybeT (Ghc.hscTcRcLookupName hscEnv n)-         `mplus`-         MaybeT (-           do mi  <- moduleInfoTc hscEnv tcGblEnv-              modInfoLookupNameIO hscEnv mi n-           )-  return (n, mty)--availableTyThings :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [TyThing]-availableTyThings hscEnv tcGblEnv avails =-    fmap catMaybes $-      mapM (fmap snd . lookupTyThing hscEnv tcGblEnv) $-      availableNames avails---- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.-availableTyCons :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [Ghc.TyCon]-availableTyCons hscEnv tcGblEnv avails =-  fmap (\things -> [tyCon | (ATyCon tyCon) <- things]) (availableTyThings hscEnv tcGblEnv avails)---- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.-availableVars :: HscEnv -> TcGblEnv -> [AvailInfo] -> IO [Ghc.Var]-availableVars hscEnv tcGblEnv avails =-  fmap (\things -> [var | (AnId var) <- things]) (availableTyThings hscEnv tcGblEnv avails)--availableNames :: [AvailInfo] -> [Name]-availableNames =-    concatMap $ \case-      Avail n -> [n]-      AvailTC n ns -> n : ns+lookupTyThing :: (GhcMonad m) => Ghc.TypeEnv -> Name -> m (Maybe TyThing)+lookupTyThing tyEnv name = do+    runMaybeT . msum . map MaybeT $+        [ pure (lookupTypeEnv tyEnv name)+        , lookupName name+        ]  _dumpTypeEnv :: TypecheckedModule -> IO () _dumpTypeEnv tm = do@@ -282,7 +192,7 @@ -------------------------------------------------------------------------------- -- | Extract Specifications from GHC ------------------------------------------- ---------------------------------------------------------------------------------extractSpecComments :: ParsedModule -> [(Maybe RealSrcLoc, String)]+extractSpecComments :: HsParsedModule -> [(Maybe RealSrcLoc, String)] extractSpecComments = mapMaybe extractSpecComment . apiComments  -- | 'extractSpecComment' pulls out the specification part from a full comment@@ -304,64 +214,13 @@  extractSpecComment _ = Nothing -extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]-extractSpecQuotes' thisModule getAnns a = mapMaybe extractSpecQuote anns-  where-    anns = map ann_value $-           filter (isOurModTarget . ann_target) $-           getAnns a--    isOurModTarget (ModuleTarget mod1) = mod1 == thisModule a-    isOurModTarget _ = False--extractSpecQuote :: AnnPayload -> Maybe BPspec-extractSpecQuote payload =-  case Ghc.fromSerialized Ghc.deserializeWithData payload of-    Nothing -> Nothing-    Just qt -> Just $ refreshSymbols $ liquidQuoteSpec qt--refreshSymbols :: Data a => a -> a-refreshSymbols = everywhere (mkT refreshSymbol)--refreshSymbol :: Symbol -> Symbol-refreshSymbol = symbol . symbolText- ----------------------------------------------------------------------------------- | Finding & Parsing Files ---------------------------------------------------------------------------------------------------------------------------------------- | Parse a spec file by path.------ On a parse error, we fail.------ TODO, Andres: It would be better to fail more systematically, but currently we--- seem to have an option between throwing an error which will be reported badly,--- or printing the error ourselves.----parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)-parseSpecFile file = do-  contents <- Misc.sayReadFile file-  case specSpecificationP file contents of-    Left peb -> do-      hPutStrLn stderr (errorBundlePretty peb)-      panic Nothing "parsing spec file failed"-    Right x  -> pure x------------------------------------------------------------------------------------- Assemble Information for Spec Extraction ------------------------------------+-- Information for Spec Extraction --------------------------------------------- -------------------------------------------------------------------------------- -makeLogicMap :: IO LogicMap-makeLogicMap = do-  case parseSymbolToLogic "CoreToLogic.coreToLogic" CoreToLogic.coreToLogic of-    Left peb -> do-      hPutStrLn stderr (errorBundlePretty peb)-      panic Nothing "makeLogicMap failed"-    Right lm -> return (lm <> listLMap)- listLMap :: LogicMap -- TODO-REBARE: move to wiredIn-listLMap  = toLogicMap [ (dummyLoc nilName , []     , hNil)-                       , (dummyLoc consName, [x, xs], hCons (EVar <$> [x, xs])) ]+listLMap  = toLogicMap [ (dummyLoc nilName , ([]     , hNil))+                       , (dummyLoc consName, ([x, xs], hCons (EVar <$> [x, xs]))) ]   where     x     = "x"     xs    = "xs"@@ -410,10 +269,6 @@  instance Show TargetInfo where   show = showpp--instance PPrint TargetVars where-  pprintTidy _ AllVars   = text "All Variables"-  pprintTidy k (Only vs) = text "Only Variables: " <+> pprintTidy k vs  ------------------------------------------------------------------------ -- Dealing with Errors ---------------------------------------------------
src/Language/Haskell/Liquid/GHC/Misc.hs view
@@ -29,11 +29,11 @@  import           Prelude                                    hiding (error) import           Liquid.GHC.API            as Ghc hiding-  (L, line, sourceName, showPpr, panic, showSDoc)+  (L, get, line, sourceName, showPpr, panic, showSDoc) import qualified Liquid.GHC.API            as Ghc (GenLocated (L))  -import           Data.Char                                  (isLower, isSpace, isUpper)+import           Data.Char                                  (isDigit, isLower, isSpace, isUpper) import           Data.Maybe                                 (isJust, fromMaybe, fromJust, maybeToList) import           Data.Hashable import qualified Data.HashSet                               as S@@ -105,11 +105,11 @@         name = mkInternalName (mkUnique 'x' uid) occ noSrcSpan         occ = mkVarOcc (T.unpack (symbolText sym)) -stringTyCon :: Char -> Word64 -> String -> TyCon+stringTyCon :: Char -> UniqueId -> String -> TyCon stringTyCon = stringTyConWithKind anyTy  -- FIXME: reusing uniques like this is really dangerous-stringTyConWithKind :: Kind -> Char -> Word64 -> String -> TyCon+stringTyConWithKind :: Kind -> Char -> UniqueId -> String -> TyCon stringTyConWithKind k c n s = Ghc.mkPrimTyCon name [] k []   where     name          = mkInternalName (mkUnique c n) occ noSrcSpan@@ -315,6 +315,9 @@ instance F.Loc Var where   srcSpan v = SS (getSourcePos v) (getSourcePosE v) +instance F.Loc Name where+  srcSpan v = SS (getSourcePos v) (getSourcePosE v)+ namedLocSymbol :: (F.Symbolic a, NamedThing a) => a -> F.Located F.Symbol namedLocSymbol d = F.symbol <$> locNamedThing d @@ -380,15 +383,6 @@ uniqueHash :: Uniquable a => Int -> a -> Int uniqueHash i = hashWithSalt i . getKey . getUnique -ignoreInline :: ParsedModule -> ParsedModule-ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x}-  where-    go  y      = y {hsmodDecls = filter go' (hsmodDecls y) }-    go' :: LHsDecl GhcPs -> Bool-    go' z-      | SigD _ (InlineSig {}) <-  unLoc z = False-      | otherwise                         = True- -------------------------------------------------------------------------------- -- | Symbol Conversions -------------------------------------------------------- --------------------------------------------------------------------------------@@ -508,8 +502,8 @@   where     tailName msg = symbol . safeLast msg -splitModuleUnique :: Symbol -> (Symbol, Word64)-splitModuleUnique x = (dropModuleNamesAndUnique x, base62ToW (takeModuleUnique x))+splitModuleUnique :: Symbol -> (Symbol, UniqueId)+splitModuleUnique x = (dropModuleNamesAndUnique x, toUniqueId $ base62ToW (takeModuleUnique x))  base62ToW :: Symbol -> Word64 base62ToW s =  fromMaybe (errorstar "base62ToW Out Of Range") $ go (F.symbolText s)@@ -577,9 +571,16 @@ mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol mungeNames _ _ _ ""  = "" mungeNames f d msg s'@(symbolText -> s)-  | s' == tupConName = tupConName+  | isTupleSymbol s' = s'   | otherwise        = f (msg ++ T.unpack s) $ T.splitOn d $ stripParens s +isTupleSymbol :: Symbol -> Bool+isTupleSymbol s =+    let t = F.symbolText s+     in T.isPrefixOf "Tuple" t &&+        T.all isDigit (T.drop 5 t) &&+        T.length t > 5+ qualifySymbol :: Symbol -> Symbol -> Symbol qualifySymbol (symbolText -> m) x'@(symbolText -> x)   | isQualified x  = x'@@ -623,16 +624,6 @@ stripParensSym :: Symbol -> Symbol stripParensSym (symbolText -> t) = symbol (stripParens t) -desugarModule :: TypecheckedModule -> Ghc DesugaredModule-desugarModule tcm = do-  let ms = pm_mod_summary $ tm_parsed_module tcm-  -- let ms = modSummary tcm-  let (tcg, _) = tm_internals_ tcm-  hsc_env <- getSession-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  guts <- liftIO $ hscDesugar{- WithLoc -} hsc_env_tmp ms tcg-  return DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }- -------------------------------------------------------------------------------- -- | GHC Compatibility Layer --------------------------------------------------- --------------------------------------------------------------------------------@@ -666,17 +657,6 @@     go (Rec xes)      = [Rec (filter ((`notElem` vs) . fst) xes)]  -findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)-findVarDef sym cbs = case xCbs of-                     (NonRec v def   : _ ) -> Just (v, def)-                     (Rec [(v, def)] : _ ) -> Just (v, def)-                     _                     -> Nothing-  where-    xCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` coreBindSymbols cb ]-    unRec (Rec xes) = [NonRec x es | (x,es) <- xes]-    unRec nonRec    = [nonRec]-- findVarDefMethod :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr) findVarDefMethod sym cbs =   case rcbs  of@@ -1003,7 +983,7 @@     return $ TcWiredIn n Nothing ty  prependGHCRealQual :: FastString -> RdrName-prependGHCRealQual = varQual_RDR gHC_INTERNAL_REAL+prependGHCRealQual = varQual_RDR realModule  isFromGHCReal :: NamedThing a => a -> Bool-isFromGHCReal x = Ghc.nameModule (Ghc.getName x) == gHC_INTERNAL_REAL+isFromGHCReal x = Ghc.nameModule (Ghc.getName x) == realModule
src/Language/Haskell/Liquid/GHC/Play.hs view
@@ -174,14 +174,10 @@   subTy s (Lam b e)      = Lam (subTy s b) (subTy s e)   subTy s (Let b e)      = Let (subTy s b) (subTy s e)   subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a)-  subTy s (Cast e c)     = Cast (subTy s e) (subTy s c)+  subTy s (Cast e _c)    = Cast (subTy s e) $ panic Nothing "subTy Coercion"   subTy s (Tick t e)     = Tick t (subTy s e)   subTy s (Type t)       = Type (subTy s t)-  subTy s (Coercion c)   = Coercion (subTy s c)--instance Subable Coercion where-  sub _ c                = c-  subTy _ _              = panic Nothing "subTy Coercion"+  subTy _s (Coercion _c) = Coercion $ panic Nothing "subTy Coercion"  instance Subable (Alt Var) where  sub s (Alt a b e)   = Alt a (map (sub s) b)   (sub s e)
src/Language/Haskell/Liquid/GHC/Plugin.hs view
@@ -4,10 +4,10 @@ {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE TupleSections              #-}  module Language.Haskell.Liquid.GHC.Plugin ( @@ -19,9 +19,10 @@ import           Liquid.GHC.API         as GHC hiding (Type) import qualified Text.PrettyPrint.HughesPJ               as PJ import qualified Language.Fixpoint.Types                 as F-import qualified  Language.Haskell.Liquid.GHC.Misc        as LH+import qualified Language.Haskell.Liquid.GHC.Misc        as LH import qualified Language.Haskell.Liquid.UX.CmdLine      as LH import qualified Language.Haskell.Liquid.GHC.Interface   as LH+import           Language.Haskell.Liquid.LHNameResolution (resolveLHNames) import qualified Language.Haskell.Liquid.Liquid          as LH import qualified Language.Haskell.Liquid.Types.PrettyPrint as LH ( filterReportErrors                                                                  , filterReportErrorsWith@@ -30,12 +31,13 @@ import qualified Language.Haskell.Liquid.GHC.Logging     as LH   (addTcRnUnknownMessages)  import           Language.Haskell.Liquid.GHC.Plugin.Types-import           Language.Haskell.Liquid.GHC.Plugin.Util as Util+import qualified Language.Haskell.Liquid.GHC.Plugin.Serialisation as Serialisation import           Language.Haskell.Liquid.GHC.Plugin.SpecFinder                                                          as SpecFinder  import           Language.Haskell.Liquid.GHC.Types       (MGIModGuts(..), miModGuts)-import           GHC.LanguageExtensions+import           Language.Haskell.Liquid.Transforms.InlineAux (inlineAux)+import           Language.Haskell.Liquid.Transforms.Rewrite (rewriteBinds)  import           Control.Monad import qualified Control.Monad.Catch as Ex@@ -43,12 +45,10 @@  import           Data.Coerce import           Data.Function                            ((&))-import           Data.Kind                                ( Type )-import           Data.List                               as L-                                                   hiding ( intersperse )+import qualified Data.List                               as L import           Data.IORef-import qualified Data.Set                                as S-import           Data.Set                                 ( Set )+import qualified Data.Map                                as M+import           Data.Map                                 ( Map )   import qualified Data.HashSet                            as HS@@ -65,9 +65,15 @@ import qualified Language.Haskell.Liquid.Measure         as Ms import           Language.Haskell.Liquid.Parse import           Language.Haskell.Liquid.Transforms.ANF-import           Language.Haskell.Liquid.Types     hiding ( getConfig )+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.PrettyPrint+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Visitors import           Language.Haskell.Liquid.Bare+import qualified Language.Haskell.Liquid.Bare.Resolve as Resolve import           Language.Haskell.Liquid.UX.CmdLine+import           Language.Haskell.Liquid.UX.Config  -- | Represents an abnormal but non-fatal state of the plugin. Because it is not -- meant to escape the plugin, it is not thrown in IO but instead carried around@@ -80,11 +86,6 @@ -- | State and configuration management ----------------------------------------- --------------------------------------------------------------------------------- --- | A reference to cache the LH's 'Config' and produce it only /once/, during the dynFlags hook.-cfgRef :: IORef Config-cfgRef = unsafePerformIO $ newIORef defConfig-{-# NOINLINE cfgRef #-}- -- | Set to 'True' to enable debug logging. debugLogs :: Bool debugLogs = False@@ -93,10 +94,6 @@ -- | Useful functions ----------------------------------------------------------- --------------------------------------------------------------------------------- --- | Reads the 'Config' out of a 'IORef'.-getConfig :: IO Config-getConfig = readIORef cfgRef- -- | Combinator which conditionally print on the screen based on the value of 'debugLogs'. debugLog :: MonadIO m => String -> m () debugLog msg = when debugLogs $ liftIO (putStrLn msg)@@ -107,24 +104,32 @@  plugin :: GHC.Plugin plugin = GHC.defaultPlugin {-    typeCheckResultAction = liquidPlugin-  , driverPlugin          = customDynFlags+    driverPlugin          = lhDynFlags+  , parsedResultAction    = parsePlugin+  , typeCheckResultAction = typecheckPlugin   , pluginRecompile       = purePlugin   }   where-    liquidPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv-    liquidPlugin _ summary gblEnv = do-      cfg <- liftIO getConfig-      if skipModule cfg then return gblEnv-      else liquidPluginGo summary gblEnv+    liquidPlugin :: (MonadIO m) => [CommandLineOption] -> a -> (Config -> m a) -> m a+    liquidPlugin opts def go = do+        cfg <- liftIO $ LH.getOpts opts+        if skipModule cfg then return def else go cfg +    parsePlugin :: [CommandLineOption] -> ModSummary -> ParsedResult -> Hsc ParsedResult+    parsePlugin opts ms parsedResult = liquidPlugin opts parsedResult $ \cfg ->+      parsedHook cfg ms parsedResult++    typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv+    typecheckPlugin opts summary gblEnv = liquidPlugin opts gblEnv $ \cfg ->+      typecheckPluginGo cfg summary gblEnv+     -- Unfortunately, we can't make Haddock run the LH plugin, because the former     -- does mangle the '.hi' files, causing annotations to not be persisted in the     -- 'ExternalPackageState' and/or 'HomePackageTable'. For this reason we disable     -- the plugin altogether if the module is being compiled with Haddock.     -- See also: https://github.com/ucsd-progsys/liquidhaskell/issues/1727     -- for a post-mortem.-    liquidPluginGo summary gblEnv = do+    typecheckPluginGo cfg summary gblEnv = do       logger <- getLogger       dynFlags <- getDynFlags       withTiming logger (text "LiquidHaskell" <+> brackets (ppr $ ms_mod_name summary)) (const ()) $ do@@ -139,7 +144,7 @@             liftIO $ printWarning logger warning             pure gblEnv           else do-            newGblEnv <- typecheckHook summary gblEnv+            newGblEnv <- typecheckHook cfg summary gblEnv             case newGblEnv of               -- Exit with success if all expected errors were found               Left (ErrorsOccurred []) -> pure gblEnv@@ -151,63 +156,108 @@                 pure newGblEnv'  ----------------------------------------------------------------------------------- | GHC Configuration & Setup -------------------------------------------------+-- | Inter-phase communication ------------------------------------------------- --------------------------------------------------------------------------------+--+-- Since we have no good way of passing extra data between different+-- phases of our plugin, we resort to leaving breadcrumbs in horrible+-- global mutable state.+--+-- Each module gets a mutable breadcrumb during compilation.+--+-- The @parseResultAction@ sets the breadcumb to @Parsed mod@.+--+-- The @typeCheckResultAction@ clears the breadcrumb on entry.+--+-- If the @typeCheckResultAction@ does not find the breadcrumb, it skips the+-- module, assuming that it has been verified already. This could happen if+-- the plugin is activated more than once on the same module (by passing+-- multiple times @-fplugin=LiquidHaskell@ to GHC). --- | Overrides the default 'DynFlags' options. Specifically, we need the GHC--- lexer not to throw away block comments, as this is where the LH spec comments--- would live. This is why we set the 'Opt_KeepRawTokenStream' option.-customDynFlags :: [CommandLineOption] -> HscEnv -> IO HscEnv-customDynFlags opts hscEnv = do-  cfg <- liftIO $ LH.getOpts opts-  writeIORef cfgRef cfg-  return (hscEnv { hsc_dflags = configureDynFlags (hsc_dflags hscEnv) })-  where-    configureDynFlags :: DynFlags -> DynFlags-    configureDynFlags df =-      df `gopt_set` Opt_ImplicitImportQualified-         `gopt_set` Opt_PIC-         `gopt_set` Opt_DeferTypedHoles-         `gopt_set` Opt_KeepRawTokenStream-         -- Opt_InsertBreakpoints is used during desugaring to prevent the-         -- simple optimizer from inlining local bindings to which we might want-         -- to attach specifications.-         ---         -- https://gitlab.haskell.org/ghc/ghc/-/issues/24386-         `gopt_set` Opt_InsertBreakpoints-         `xopt_set` MagicHash-         `xopt_set` DeriveGeneric-         `xopt_set` StandaloneDeriving+{- HLINT ignore Breadcrumb "Use newtype instead of data" -}+  -- It's basically an accidental detail that we only have one type of+  -- breadcrumb at the moment. We don't want to use a `newtype` to+  -- avoid communicating the false intention that a breadcrumb "is" a+  -- list of `SpecComment`s.+data Breadcrumb+  = Parsed ![SpecComment] +breadcrumbsRef :: IORef (Map Module Breadcrumb)+breadcrumbsRef = unsafePerformIO $ newIORef mempty+{-# NOINLINE breadcrumbsRef #-}++{- HLINT ignore swapBreadcrumb "Use tuple-section" -}+swapBreadcrumb :: (MonadIO m) => Module -> Maybe Breadcrumb -> m (Maybe Breadcrumb)+swapBreadcrumb mod0 new = liftIO $ atomicModifyIORef' breadcrumbsRef $ \breadcrumbs ->+  let (old, breadcrumbs') = M.alterF (\old1 -> (old1, new)) mod0 breadcrumbs+  in (breadcrumbs', old)+ ----------------------------------------------------------------------------------- | \"Unoptimising\" things ----------------------------------------------------+-- | GHC Configuration & Setup ------------------------------------------------- -------------------------------------------------------------------------------- --- | LiquidHaskell requires the unoptimised core binds in order to work correctly, but at the same time the--- user can invoke GHC with /any/ optimisation flag turned out. This is why we grab the core binds by--- desugaring the module during /parsing/ (before that's already too late) and we cache the core binds for--- the rest of the program execution.-class Unoptimise a where-  type UnoptimisedTarget a :: Type-  unoptimise :: a -> UnoptimisedTarget a+lhDynFlags :: [CommandLineOption] -> HscEnv -> IO HscEnv+lhDynFlags _ hscEnv =+    return hscEnv+      { hsc_dflags =+          hsc_dflags hscEnv+           -- Ignore-interface-pragmas need to be unset to have access to+           -- the RHS unfoldings in the `Ghc.Var`s which is+           -- needed as part of the reflection of foreign functions in the logic+           --+           -- This needs to be active before the plugin runs, so pragmas are+           -- read at the time the interface files are loaded.+           `gopt_unset` Opt_IgnoreInterfacePragmas+           -- We need the GHC lexer not to throw away block comments,+           -- as this is where the LH spec comments would live. This+           -- is why we set the 'Opt_KeepRawTokenStream' option.+           `gopt_set` Opt_KeepRawTokenStream+      } -instance Unoptimise DynFlags where-  type UnoptimisedTarget DynFlags = DynFlags-  unoptimise df = updOptLevel 0 df-    { debugLevel   = 1-    , ghcLink      = LinkInMemory-    , backend      = interpreterBackend-    , ghcMode      = CompManager+--------------------------------------------------------------------------------+-- | Desugarer setting tweaks --------------------------------------------------+--------------------------------------------------------------------------------++-- | LiquidHaskell requires the desugarer to keep source note ticks+-- and to export everything.+--+-- TODO: We shouldn't rely on exports to find out what's in a ModGuts+-- https://github.com/ucsd-progsys/liquidhaskell/pull/2388#issuecomment-2411418479+desugarerDynFlags :: DynFlags -> DynFlags+desugarerDynFlags df = (foldl gopt_unset df disabledOpts)+    { debugLevel   = 1                  -- To keep source note ticks+    , backend      = interpreterBackend -- To export everything     }+  where+    disabledOpts =+      [ Opt_EnableRewriteRules -- Prevent the simple optimizer from firing rewrite rules+                               -- during desugaring. See tests/reflect/pos/T2405.hs for+                               -- a discussion of an example where this is unwanted.+      ] -instance Unoptimise ModSummary where-  type UnoptimisedTarget ModSummary = ModSummary-  unoptimise modSummary = modSummary { ms_hspp_opts = unoptimise (ms_hspp_opts modSummary) } -instance Unoptimise (DynFlags, HscEnv) where-  type UnoptimisedTarget (DynFlags, HscEnv) = HscEnv-  unoptimise (unoptimise -> df, env) = env { hsc_dflags = df }+--------------------------------------------------------------------------------+-- | Parsing phase -------------------------------------------------------------+-------------------------------------------------------------------------------- +-- | We hook at this stage of the pipeline to extract the+-- specs. Comments are preserved during parsing because we turn on+-- 'Opt_KeepRawTokenStream'. So we can get the /LH/ specs from+-- there.+parsedHook :: Config -> ModSummary -> ParsedResult -> Hsc ParsedResult+parsedHook _cfg ms parsedResult = do+    -- TODO: we should parse the specs here so we can fail early+    -- (before going through the whole GHC typechecker) if they don't+    -- parse. Alas, LH.filterReportError is TcRn-specific.+    let specComments = map mkSpecComment $ LH.extractSpecComments (parsedResultModule parsedResult)++    -- See 'Breadcrumb' for more information.+    _oldBreadcrumb <- swapBreadcrumb thisModule $ Just (Parsed specComments)++    return parsedResult+  where+    thisModule = ms_mod ms+ -------------------------------------------------------------------------------- -- | Typechecking phase -------------------------------------------------------- --------------------------------------------------------------------------------@@ -221,39 +271,63 @@ --    if we call /LH/ any later than here; -- -- 2. Although /LH/ works on \"Core\", it requires the _unoptimised_ \"Core\" that we---    grab from parsing (again) the module by using the GHC API, so we are really---    independent from the \"normal\" compilation pipeline.+--    grab from desugaring a postprocessed version of the typechecked module, so we are+--    really independent from the \"normal\" compilation pipeline. ---typecheckHook :: ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)-typecheckHook (unoptimise -> modSummary) tcGblEnv = do+typecheckHook  :: Config -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)+typecheckHook cfg0 ms tcGblEnv = swapBreadcrumb thisModule Nothing >>= \case+  Just (Parsed specComments) ->+    typecheckHook' cfg0 ms tcGblEnv specComments+  Nothing ->+    -- The module has been verified by an earlier call to the plugin.+    -- This could happen if multiple @-fplugin=LiquidHaskell@ flags are passed to GHC.+    -- See 'Breadcrumb' for more information.+    pure $ Right tcGblEnv+  where+    thisModule = ms_mod ms++typecheckHook' :: Config -> ModSummary -> TcGblEnv -> [SpecComment] -> TcM (Either LiquidCheckException TcGblEnv)+typecheckHook' cfg ms tcGblEnv specComments = do   debugLog $ "We are in module: " <> show (toStableModule thisModule) -  env             <- env_top <$> getEnv-  parsed          <- liftIO $ parseModuleIO env (LH.keepRawTokenStream modSummary)-  let comments    = LH.extractSpecComments parsed-  -- The LH plugin itself calls the type checker (see following line). This-  -- would lead to a loop if we didn't remove the plugin when calling the type-  -- checker.-  typechecked     <- liftIO $ typecheckModuleIO (dropPlugins env) (LH.ignoreInline parsed)-  resolvedNames   <- liftIO $ LH.lookupTyThings env tcGblEnv-  availTyCons     <- liftIO $ LH.availableTyCons env tcGblEnv (tcg_exports tcGblEnv)-  availVars       <- liftIO $ LH.availableVars env tcGblEnv (tcg_exports tcGblEnv)+  case parseSpecComments (coerce specComments) of+    Left errors ->+      LH.filterReportErrors thisFile GHC.failM continue (getFilters cfg) Full errors+    Right specs ->+      liquidCheckModule cfg ms tcGblEnv specs+  where+    thisModule = ms_mod ms+    thisFile = LH.modSummaryHsFile ms -  unoptimisedGuts <- liftIO $ desugarModuleIO env modSummary typechecked+    continue = pure $ Left (ErrorsOccurred []) -  let tcData = mkTcData (tcg_rn_imports tcGblEnv) resolvedNames availTyCons availVars-  let pipelineData = PipelineData unoptimisedGuts tcData (map mkSpecComment comments)+liquidCheckModule :: Config -> ModSummary -> TcGblEnv -> [BPspec] -> TcM (Either LiquidCheckException TcGblEnv)+liquidCheckModule cfg0 ms tcg specs = do+  withPragmas cfg0 thisFile pragmas $ \cfg -> do+    pipelineData <- do+      env <- getTopEnv+      session <- Session <$> liftIO (newIORef env)+      liftIO $ flip reflectGhc session $ mkPipelineData ms tcg specs+    liquidLib <- setGblEnv tcg $ liquidHaskellCheckWithConfig cfg pipelineData ms+    traverse (serialiseSpec tcg) liquidLib+  where+    thisFile = LH.modSummaryHsFile ms+    pragmas = [ s | Pragma s <- specs ] -  liquidHaskellCheck pipelineData modSummary tcGblEnv+mkPipelineData :: (GhcMonad m) => ModSummary -> TcGblEnv -> [BPspec] -> m PipelineData+mkPipelineData ms tcg0 specs = do+    let tcg = addNoInlinePragmasToBinds tcg0 -  where-    thisModule :: Module-    thisModule = tcg_mod tcGblEnv+    unoptimisedGuts <- withSession $ \hsc_env ->+        let lcl_hsc_env = hscUpdateFlags (noWarnings . desugarerDynFlags) hsc_env in+        liftIO $ hscDesugar lcl_hsc_env ms tcg -    dropPlugins hsc_env = hsc_env { hsc_plugins = emptyPlugins }+    return $ PipelineData unoptimisedGuts specs+  where+    noWarnings dflags = dflags { warningFlags = mempty } -serialiseSpec :: Module -> TcGblEnv -> LiquidLib -> TcM TcGblEnv-serialiseSpec thisModule tcGblEnv liquidLib = do+serialiseSpec :: TcGblEnv -> LiquidLib -> TcM TcGblEnv+serialiseSpec tcGblEnv liquidLib = do   -- ---   -- -- CAN WE 'IGNORE' THE BELOW? TODO:IGNORE -- issue use `emptyLiquidLib` instead of pmrClientLib   -- ProcessModuleResult{..} <- processModule lhContext@@ -274,87 +348,62 @@   -- liftIO $ putStrLn "liquidHaskellCheck 9"   -- --- -  let serialisedSpec = Util.serialiseLiquidLib liquidLib thisModule+  serialisedSpec <- liftIO $ Serialisation.serialiseLiquidLib liquidLib thisModule   debugLog $ "Serialised annotation ==> " ++ (O.showSDocUnsafe . O.ppr $ serialisedSpec)    -- liftIO $ putStrLn "liquidHaskellCheck 10"    pure $ tcGblEnv { tcg_anns = serialisedSpec : tcg_anns tcGblEnv }--processInputSpec :: Config -> PipelineData -> ModSummary -> TcGblEnv -> BareSpec -> TcM (Either LiquidCheckException TcGblEnv)-processInputSpec cfg pipelineData modSummary tcGblEnv inputSpec = do-  hscEnv <- env_top <$> getEnv-  debugLog $ " Input spec: \n" ++ show inputSpec-  debugLog $ "Relevant ===> \n" ++ unlines (renderModule <$> S.toList (relevantModules (hsc_mod_graph hscEnv) modGuts))+  where+    thisModule = tcg_mod tcGblEnv -  logicMap :: LogicMap <- liftIO LH.makeLogicMap+processInputSpec+  :: Config+  -> PipelineData+  -> ModSummary+  -> BareSpecParsed+  -> TcM (Either LiquidCheckException LiquidLib)+processInputSpec cfg pipelineData modSummary inputSpec = do+  tcg <- getGblEnv+  debugLog $ " Input spec: \n" ++ show (fromBareSpecParsed inputSpec)+  debugLog $ "Direct ===> \n" ++ unlines (renderModule <$> directImports tcg)    -- debugLog $ "Logic map:\n" ++ show logicMap    let lhContext = LiquidHaskellContext {         lhGlobalCfg       = cfg       , lhInputSpec       = inputSpec-      , lhModuleLogicMap  = logicMap       , lhModuleSummary   = modSummary-      , lhModuleTcData    = pdTcData pipelineData       , lhModuleGuts      = pdUnoptimisedCore pipelineData-      , lhRelevantModules = relevantModules (hsc_mod_graph hscEnv) modGuts+      , lhRelevantModules = directImports tcg       }    -- liftIO $ putStrLn ("liquidHaskellCheck 6: " ++ show isIg)   if isIgnore inputSpec     then pure $ Left (ErrorsOccurred [])-    else do-      liquidLib' <- checkLiquidHaskellContext lhContext-      traverse (serialiseSpec thisModule tcGblEnv) liquidLib'--  where-    thisModule :: Module-    thisModule = tcg_mod tcGblEnv--    modGuts :: ModGuts-    modGuts = pdUnoptimisedCore pipelineData--liquidHaskellCheckWithConfig :: Config -> PipelineData -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)-liquidHaskellCheckWithConfig globalCfg pipelineData modSummary tcGblEnv = do-  -- The 'specQuotes' contain stuff we need from imported modules, extracted-  -- from the annotations in their interface files.-  let specQuotes :: [BPspec]-      specQuotes = LH.extractSpecQuotes' tcg_mod tcg_anns tcGblEnv+    else checkLiquidHaskellContext lhContext -  -- Here, we are calling Liquid Haskell's parser, acting on the unparsed-  -- spec comments stored in the pipeline data, supported by the specQuotes-  -- obtained from the imported modules.-  inputSpec' :: Either LiquidCheckException BareSpec <--    getLiquidSpec thisFile thisModule (pdSpecComments pipelineData) specQuotes+liquidHaskellCheckWithConfig+  :: Config -> PipelineData -> ModSummary -> TcM (Either LiquidCheckException LiquidLib)+liquidHaskellCheckWithConfig cfg pipelineData modSummary = do+  -- Parse the spec comments stored in the pipeline data.+  let inputSpec = snd $+        hsSpecificationP (moduleName thisModule) (pdSpecComments pipelineData) -  case inputSpec' of-    Left e -> pure $ Left e-    Right inputSpec ->-      withPragmas globalCfg thisFile (Ms.pragmas $ fromBareSpec inputSpec) $ \moduleCfg -> do-        processInputSpec moduleCfg pipelineData modSummary tcGblEnv inputSpec-          `Ex.catch` (\(e :: UserError) -> reportErrs moduleCfg [e])-          `Ex.catch` (\(e :: Error) -> reportErrs moduleCfg [e])-          `Ex.catch` (\(es :: [Error]) -> reportErrs moduleCfg es)+  processInputSpec cfg pipelineData modSummary inputSpec+    `Ex.catch` (\(e :: UserError) -> reportErrs [e])+    `Ex.catch` (\(e :: Error) -> reportErrs [e])+    `Ex.catch` (\(es :: [Error]) -> reportErrs es)    where-    thisFile :: FilePath     thisFile = LH.modSummaryHsFile modSummary+    thisModule = ms_mod modSummary -    continue :: TcM (Either LiquidCheckException TcGblEnv)+    continue :: TcM (Either LiquidCheckException a)     continue = pure $ Left (ErrorsOccurred []) -    reportErrs :: (Show e, F.PPrint e) => Config -> [TError e] -> TcM (Either LiquidCheckException TcGblEnv)-    reportErrs cfg = LH.filterReportErrors thisFile GHC.failM continue (getFilters cfg) Full--    thisModule :: Module-    thisModule = tcg_mod tcGblEnv---- | Partially calls into LiquidHaskell's GHC API.-liquidHaskellCheck :: PipelineData -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)-liquidHaskellCheck pipelineData modSummary tcGblEnv = do-  cfg <- liftIO getConfig-  liquidHaskellCheckWithConfig cfg pipelineData modSummary tcGblEnv+    reportErrs :: (Show e, F.PPrint e) => [TError e] -> TcM (Either LiquidCheckException a)+    reportErrs  = LH.filterReportErrors thisFile GHC.failM continue (getFilters cfg) Full  checkLiquidHaskellContext :: LiquidHaskellContext -> TcM (Either LiquidCheckException LiquidLib) checkLiquidHaskellContext lhContext = do@@ -368,7 +417,7 @@       let bareSpec = lhInputSpec lhContext           file = LH.modSummaryHsFile $ lhModuleSummary lhContext -      withPragmas (lhGlobalCfg lhContext) file (Ms.pragmas $ fromBareSpec bareSpec) $ \moduleCfg ->  do+      withPragmas (lhGlobalCfg lhContext) file (Ms.pragmas bareSpec) $ \moduleCfg ->  do         let filters = getFilters moduleCfg         -- Report the outcome of the checking         LH.reportResult (errorLogger file filters) moduleCfg [giTarget (giSrc pmrTargetInfo)] out@@ -395,54 +444,42 @@                            }     (LH.orMessages outputResult) -isIgnore :: BareSpec -> Bool-isIgnore (MkBareSpec sp) = any ((== "--skip-module") . F.val) (pragmas sp)+isIgnore :: Spec lname ty -> Bool+isIgnore sp = any ((== "--skip-module") . F.val) (pragmas sp)  -------------------------------------------------------------------------------- -- | Working with bare & lifted specs ------------------------------------------ -------------------------------------------------------------------------------- -loadDependencies :: Config-                 -- ^ The 'Config' associated to the /current/ module being compiled.-                 -> Module-                 -> [Module]-                 -> TcM TargetDependencies-loadDependencies currentModuleConfig thisModule mods = do+loadDependencies :: Config -> [Module] -> TcM TargetDependencies+loadDependencies currentModuleConfig mods = do   hscEnv    <- env_top <$> getEnv   results   <- SpecFinder.findRelevantSpecs                  (excludeAutomaticAssumptionsFor currentModuleConfig) hscEnv mods-  deps      <- foldM processResult mempty (reverse results)+  let deps = TargetDependencies $ foldl' processResult mempty (reverse results)   redundant <- liftIO $ configToRedundantDependencies hscEnv currentModuleConfig    debugLog $ "Redundant dependencies ==> " ++ show redundant    pure $ foldl' (flip dropDependency) deps redundant   where-    processResult :: TargetDependencies -> SpecFinderResult -> TcM TargetDependencies-    processResult !acc (SpecNotFound mdl) = do-      debugLog $ "[T:" ++ renderModule thisModule-              ++ "] Spec not found for " ++ renderModule mdl-      pure acc-    processResult _ (SpecFound originalModule location _) = do-      dynFlags <- getDynFlags-      debugLog $ "[T:" ++ show (moduleName thisModule)-              ++ "] Spec found for " ++ renderModule originalModule ++ ", at location " ++ show location-      Util.pluginAbort (O.showSDoc dynFlags $ O.text "A BareSpec was returned as a dependency, this is not allowed, in " O.<+> O.ppr thisModule)-    processResult !acc (LibFound originalModule location lib) = do-      debugLog $ "[T:" ++ show (moduleName thisModule)-              ++ "] Lib found for " ++ renderModule originalModule ++ ", at location " ++ show location-      pure $ TargetDependencies {-          getDependencies = HM.insert (toStableModule originalModule) (libTarget lib) (getDependencies $ acc <> libDeps lib)-        }+    processResult+      :: HM.HashMap StableModule LiftedSpec+      -> SpecFinderResult+      -> HM.HashMap StableModule LiftedSpec+    processResult acc (SpecNotFound _mdl) = acc+    processResult acc (LibFound originalModule lib) =+      HM.insert+        (toStableModule originalModule)+        (libTarget lib)+        (acc <> getDependencies (libDeps lib))  data LiquidHaskellContext = LiquidHaskellContext {     lhGlobalCfg        :: Config-  , lhInputSpec        :: BareSpec-  , lhModuleLogicMap   :: LogicMap+  , lhInputSpec        :: BareSpecParsed   , lhModuleSummary    :: ModSummary-  , lhModuleTcData     :: TcData   , lhModuleGuts       :: ModGuts-  , lhRelevantModules  :: Set Module+  , lhRelevantModules  :: [Module]   }  --------------------------------------------------------------------------------@@ -456,64 +493,64 @@   -- ^ The 'GhcInfo' for the current 'Module' that LiquidHaskell will process.   } --- | Parse the spec comments from one module, supported by the--- spec quotes from the imported module. Also looks for--- "companion specs" for the current module and merges them in--- if it finds one.-getLiquidSpec :: FilePath -> Module -> [SpecComment] -> [BPspec] -> TcM (Either LiquidCheckException BareSpec)-getLiquidSpec thisFile thisModule specComments specQuotes = do-  globalCfg <- liftIO getConfig-  let commSpecE :: Either [Error] (ModName, Spec LocBareType LocSymbol)-      commSpecE = hsSpecificationP (moduleName thisModule) (coerce specComments) specQuotes-  case commSpecE of-    Left errors ->-      LH.filterReportErrors thisFile GHC.failM continue (getFilters globalCfg) Full errors-    Right (toBareSpec . snd -> commSpec) -> do-      env    <- env_top <$> getEnv-      res <- liftIO $ SpecFinder.findCompanionSpec env thisModule-      case res of-        SpecFound _ _ companionSpec -> do-          debugLog $ "Companion spec found for " ++ renderModule thisModule-          pure $ Right $ commSpec <> companionSpec-        _ -> pure $ Right commSpec-  where-    continue = pure $ Left (ErrorsOccurred [])- processModule :: LiquidHaskellContext -> TcM (Either LiquidCheckException ProcessModuleResult) processModule LiquidHaskellContext{..} = do+  let modGuts0   = lhModuleGuts+      thisModule = mg_module modGuts0+   debugLog ("Module ==> " ++ renderModule thisModule)-  hscEnv              <- env_top <$> getEnv -  let bareSpec        = lhInputSpec+  let bareSpec0       = lhInputSpec   -- /NOTE/: For the Plugin to work correctly, we shouldn't call 'canonicalizePath', because otherwise   -- this won't trigger the \"external name resolution\" as part of 'Language.Haskell.Liquid.Bare.Resolve'   -- (cfr. 'allowExtResolution').   let file            = LH.modSummaryHsFile lhModuleSummary -  _                   <- liftIO $ LH.checkFilePragmas $ Ms.pragmas (fromBareSpec bareSpec)+  _                   <- liftIO $ LH.checkFilePragmas $ Ms.pragmas bareSpec0 -  withPragmas lhGlobalCfg file (Ms.pragmas $ fromBareSpec bareSpec) $ \moduleCfg -> do-    dependencies       <- loadDependencies moduleCfg-                                           thisModule-                                           (S.toList lhRelevantModules)+  withPragmas lhGlobalCfg file (Ms.pragmas bareSpec0) $ \moduleCfg -> do+    dependencies <- loadDependencies moduleCfg lhRelevantModules      debugLog $ "Found " <> show (HM.size $ getDependencies dependencies) <> " dependencies:"     when debugLogs $       forM_ (HM.keys . getDependencies $ dependencies) $ debugLog . moduleStableString . unStableModule -    debugLog $ "mg_exports => " ++ O.showSDocUnsafe (O.ppr $ mg_exports modGuts)-    debugLog $ "mg_tcs => " ++ O.showSDocUnsafe (O.ppr $ mg_tcs modGuts)+    debugLog $ "mg_exports => " ++ O.showSDocUnsafe (O.ppr $ mg_exports modGuts0)+    debugLog $ "mg_tcs => " ++ O.showSDocUnsafe (O.ppr $ mg_tcs modGuts0) -    targetSrc  <- liftIO $ makeTargetSrc moduleCfg file lhModuleTcData modGuts hscEnv+    hscEnv <- getTopEnv+    let preNormalizedCore = preNormalizeCore moduleCfg modGuts0+        modGuts = modGuts0 { mg_binds = preNormalizedCore }+    targetSrc  <- liftIO $ makeTargetSrc moduleCfg file modGuts hscEnv     logger <- getLogger      -- See https://github.com/ucsd-progsys/liquidhaskell/issues/1711     -- Due to the fact the internals can throw exceptions from pure code at any point, we need to     -- call 'evaluate' to force any exception and catch it, if we can. -+    tcg <- getGblEnv+    let localVars = Resolve.makeLocalVars preNormalizedCore+        eBareSpec = resolveLHNames+          moduleCfg+          thisModule+          localVars+          (imp_mods $ tcg_imports tcg)+          (tcg_rdr_env tcg)+          bareSpec0+          dependencies     result <--      makeTargetSpec moduleCfg lhModuleLogicMap targetSrc bareSpec dependencies+      case eBareSpec of+        Left errors -> pure $ Left $ mkDiagnostics [] errors+        Right (bareSpec, lnameEnv, lmap') ->+          fmap (,bareSpec) <$>+            makeTargetSpec+              moduleCfg+              localVars+              lnameEnv+              lmap'+              targetSrc+              bareSpec+              dependencies      let continue = pure $ Left (ErrorsOccurred [])         reportErrs :: (Show e, F.PPrint e) => [TError e] -> TcRn (Either LiquidCheckException ProcessModuleResult)@@ -524,7 +561,7 @@       Left diagnostics -> do         liftIO $ mapM_ (printWarning logger)    (allWarnings diagnostics)         reportErrs $ allErrors diagnostics-      Right (warnings, targetSpec, liftedSpec) -> do+      Right ((warnings, targetSpec, liftedSpec), bareSpec) -> do         liftIO $ mapM_ (printWarning logger) warnings         let targetInfo = TargetInfo targetSrc targetSpec @@ -543,28 +580,21 @@       `Ex.catch` (\(e :: Error) -> reportErrs [e])       `Ex.catch` (\(es :: [Error]) -> reportErrs es) -  where-    modGuts    = lhModuleGuts-    thisModule = mg_module modGuts- makeTargetSrc :: Config               -> FilePath-              -> TcData               -> ModGuts               -> HscEnv               -> IO TargetSrc-makeTargetSrc cfg file tcData modGuts hscEnv = do-  coreBinds      <- anormalize cfg hscEnv modGuts+makeTargetSrc cfg file modGuts hscEnv = do+  when (dumpPreNormalizedCore cfg) $ do+    putStrLn "\n*************** Pre-normalized CoreBinds *****************\n"+    putStrLn $ unlines $ L.intersperse "" $ map (GHC.showPpr (GHC.hsc_dflags hscEnv)) (mg_binds modGuts)+  coreBinds <- anormalize cfg hscEnv modGuts -  -- The type constructors for a module are the (nubbed) union of the ones defined and-  -- the ones exported. This covers the case of \"wrapper modules\" that simply re-exports-  -- everything from the imported modules.-  let availTcs    = tcAvailableTyCons tcData-  let allTcs      = L.nub (mgi_tcs mgiModGuts ++ availTcs)+  let allTcs      = mgi_tcs mgiModGuts    let dataCons       = concatMap (map dataConWorkId . tyConDataCons) allTcs   let (fiTcs, fiDcs) = LH.makeFamInstEnv (getFamInstances modGuts)-  let things         = tcResolvedNames tcData   let impVars        = LH.importVars coreBinds ++ LH.classCons (mgi_cls_inst mgiModGuts)    debugLog $ "_gsTcs   => " ++ show allTcs@@ -573,7 +603,6 @@   debugLog $ "dataCons => " ++ show dataCons   debugLog $ "coreBinds => " ++ (O.showSDocUnsafe . O.ppr $ coreBinds)   debugLog $ "impVars => " ++ (O.showSDocUnsafe . O.ppr $ impVars)-  debugLog $ "defVars  => " ++ show (L.nub $ dataCons ++ letVars coreBinds ++ tcAvailableVars tcData)   debugLog $ "useVars  => " ++ (O.showSDocUnsafe . O.ppr $ readVars coreBinds)   debugLog $ "derVars  => " ++ (O.showSDocUnsafe . O.ppr $ HS.fromList (LH.derivedVars cfg mgiModGuts))   debugLog $ "gsExports => " ++ show (mgi_exports  mgiModGuts)@@ -582,15 +611,12 @@   debugLog $ "gsFiTcs   => " ++ (O.showSDocUnsafe . O.ppr $ fiTcs)   debugLog $ "gsFiDcs   => " ++ show fiDcs   debugLog $ "gsPrimTcs => " ++ (O.showSDocUnsafe . O.ppr $ GHC.primTyCons)-  debugLog $ "things   => " ++ (O.showSDocUnsafe . O.vcat . map O.ppr $ things)-  debugLog $ "allImports => " ++ show (tcAllImports tcData)-  debugLog $ "qualImports => " ++ show (tcQualifiedImports tcData)   return $ TargetSrc     { giTarget    = file     , giTargetMod = ModName Target (moduleName (mg_module modGuts))     , giCbs       = coreBinds     , giImpVars   = impVars-    , giDefVars   = L.nub $ dataCons ++ letVars coreBinds ++ tcAvailableVars tcData+    , giDefVars   = L.nub $ dataCons ++ letVars coreBinds     , giUseVars   = readVars coreBinds     , giDerVars   = HS.fromList (LH.derivedVars cfg mgiModGuts)     , gsExports   = mgi_exports  mgiModGuts@@ -599,15 +625,17 @@     , gsFiTcs     = fiTcs     , gsFiDcs     = fiDcs     , gsPrimTcs   = GHC.primTyCons-    , gsQualImps  = tcQualifiedImports tcData-    , gsAllImps   = tcAllImports       tcData-    , gsTyThings  = [ t | (_, Just t) <- things ]     }   where     mgiModGuts :: MGIModGuts     mgiModGuts = miModGuts deriv modGuts       where         deriv   = Just $ instEnvElts $ mg_inst_env modGuts++preNormalizeCore :: Config -> ModGuts -> [CoreBind]+preNormalizeCore cfg modGuts = rewriteBinds cfg inl_cbs+  where+    inl_cbs  = inlineAux cfg (mg_module modGuts) (mg_binds modGuts)  getFamInstances :: ModGuts -> [FamInst] getFamInstances guts = famInstEnvElts (mg_fam_inst_env guts)
+ src/Language/Haskell/Liquid/GHC/Plugin/Serialisation.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.Liquid.GHC.Plugin.Serialisation (+      -- * Serialising and deserialising things from/to specs.+        serialiseLiquidLib+      , deserialiseLiquidLib+      , deserialiseLiquidLibFromEPS++      ) where++import qualified Data.Array                               as Array+import           Data.Foldable                            ( asum )++import           Control.Monad++import qualified Data.Binary                             as B+import qualified Data.Binary.Builder                     as Builder+import qualified Data.Binary.Put                         as B+import qualified Data.ByteString.Lazy                    as B+import           Data.Data (Data)+import           Data.Generics (ext0, gmapAccumT)+import           Data.HashMap.Strict                     as M+import           Data.Maybe                               ( listToMaybe )+import           Data.Word                               (Word8)++import qualified Liquid.GHC.API as GHC+import           Language.Haskell.Liquid.GHC.Plugin.Types (LiquidLib)+import           Language.Haskell.Liquid.Types.Names+++--+-- Serialising and deserialising Specs+--++getLiquidLibBytesFromEPS+  :: GHC.Module+  -> GHC.ExternalPackageState+  -> Maybe LiquidLibBytes+getLiquidLibBytesFromEPS thisModule eps = extractFromEps+  where+    extractFromEps :: Maybe LiquidLibBytes+    extractFromEps = listToMaybe $ GHC.findAnns LiquidLibBytes (GHC.eps_ann_env eps) (GHC.ModuleTarget thisModule)++getLiquidLibBytes :: GHC.Module+                        -> GHC.ExternalPackageState+                        -> GHC.HomePackageTable+                        -> Maybe LiquidLibBytes+getLiquidLibBytes thisModule eps hpt =+    asum [extractFromHpt, getLiquidLibBytesFromEPS thisModule eps]+  where+    extractFromHpt :: Maybe LiquidLibBytes+    extractFromHpt = do+      modInfo <- GHC.lookupHpt hpt (GHC.moduleName thisModule)+      guard (thisModule == (GHC.mi_module . GHC.hm_iface $ modInfo))+      xs <- mapM (GHC.fromSerialized LiquidLibBytes . GHC.ifAnnotatedValue) (GHC.mi_anns . GHC.hm_iface $ modInfo)+      listToMaybe xs++newtype LiquidLibBytes = LiquidLibBytes { unLiquidLibBytes :: [Word8] }++-- | Serialise a 'LiquidLib', removing the termination checks from the target.+serialiseLiquidLib :: LiquidLib -> GHC.Module -> IO GHC.Annotation+serialiseLiquidLib lib thisModule = do+    bs <- encodeLiquidLib lib+    return $ GHC.Annotation+      (GHC.ModuleTarget thisModule)+      (GHC.toSerialized unLiquidLibBytes (LiquidLibBytes $ B.unpack bs))++deserialiseLiquidLib+  :: GHC.Module+  -> GHC.ExternalPackageState+  -> GHC.HomePackageTable+  -> GHC.NameCache+  -> IO (Maybe LiquidLib)+deserialiseLiquidLib thisModule eps hpt nameCache = do+    let mlibbs = getLiquidLibBytes thisModule eps hpt+    case mlibbs of+      Just (LiquidLibBytes ws) -> do+        let bs = B.pack ws+        Just <$> decodeLiquidLib nameCache bs+      _ -> return Nothing++deserialiseLiquidLibFromEPS+  :: GHC.Module+  -> GHC.ExternalPackageState+  -> GHC.NameCache+  -> IO (Maybe LiquidLib)+deserialiseLiquidLibFromEPS thisModule eps nameCache = do+    let mlibbs = getLiquidLibBytesFromEPS thisModule eps+    case mlibbs of+      Just (LiquidLibBytes ws) -> do+        let bs = B.pack ws+        Just <$> decodeLiquidLib nameCache bs+      _ -> return Nothing++encodeLiquidLib :: LiquidLib -> IO B.ByteString+encodeLiquidLib lib0 = do+    let (lib1, ns) = collectLHNames lib0+    bh <- GHC.openBinMem (1024*1024)+    GHC.putWithUserData GHC.QuietBinIFace bh ns+    GHC.withBinBuffer bh $ \bs ->+      return $ Builder.toLazyByteString $ B.execPut (B.put lib1) <> Builder.fromByteString bs++decodeLiquidLib :: GHC.NameCache -> B.ByteString -> IO LiquidLib+decodeLiquidLib nameCache bs0 = do+    case B.decodeOrFail bs0 of+      Left (_, _, err) -> error $ "decodeLiquidLib: decodeOrFail: " ++ err+      Right (bs1, _, lib) -> do+        bh <- GHC.unsafeUnpackBinBuffer $ B.toStrict bs1+        ns <- GHC.getWithUserData nameCache bh+        let n = fromIntegral $ length ns+            arr = Array.listArray (0, n - 1) ns+        return $ mapLHNames (resolveLHNameIndex arr) lib+  where+    resolveLHNameIndex :: Array.Array Word LHResolvedName -> LHName -> LHName+    resolveLHNameIndex arr lhname =+      case getLHNameResolved lhname of+        LHRIndex i ->+          if i <= snd (Array.bounds arr) then+            makeResolvedLHName (arr Array.! i) (getLHNameSymbol lhname)+          else+            error $ "decodeLiquidLib: index out of bounds: " ++ show (i, Array.bounds arr)+        _ ->+          lhname++newtype AccF a b = AccF { unAccF :: a -> b -> (a, b) }++collectLHNames :: Data a => a -> (a, [LHResolvedName])+collectLHNames t =+    let ((_, _, xs), t') = go (0, M.empty, []) t+     in (t', reverse xs)+  where+    go+      :: Data a+      => (Word, M.HashMap LHResolvedName Word, [LHResolvedName])+      -> a+      -> ((Word, M.HashMap LHResolvedName Word, [LHResolvedName]), a)+    go = gmapAccumT $ unAccF $ AccF go `ext0` AccF collectName++    collectName acc@(sz, m, xs) n = case M.lookup n m of+      Just i -> (acc, LHRIndex i)+      Nothing -> ((sz + 1, M.insert n sz m, n : xs), LHRIndex sz)
src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs view
@@ -1,25 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes   #-}  module Language.Haskell.Liquid.GHC.Plugin.SpecFinder     ( findRelevantSpecs-    , findCompanionSpec     , SpecFinderResult(..)-    , SearchLocation(..)     , configToRedundantDependencies     ) where -import qualified Language.Haskell.Liquid.GHC.Plugin.Util as Util+import qualified Language.Haskell.Liquid.GHC.Plugin.Serialisation as Serialisation import           Language.Haskell.Liquid.GHC.Plugin.Types-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.Specs     hiding (Spec)-import qualified Language.Haskell.Liquid.Misc            as Misc-import           Language.Haskell.Liquid.Parse            ( specSpecificationP )-import           Language.Fixpoint.Utils.Files            ( Ext(Spec), withExt )+import           Language.Haskell.Liquid.UX.Config -import qualified Liquid.GHC.API         as O import           Liquid.GHC.API         as GHC  import           Data.Bifunctor@@ -27,27 +19,15 @@ import           Data.IORef import           Data.Maybe -import           Control.Exception-import           Control.Monad                            ( foldM )-import           Control.Monad.Trans                      ( lift ) import           Control.Monad.Trans.Maybe -import           Text.Megaparsec.Error  type SpecFinder m = Module -> MaybeT IO SpecFinderResult  -- | The result of searching for a spec.-data SpecFinderResult = +data SpecFinderResult =     SpecNotFound Module-  | SpecFound Module SearchLocation BareSpec-  | LibFound  Module SearchLocation LiquidLib--data SearchLocation =-    InterfaceLocation-  -- ^ The spec was loaded from the annotations of an interface.-  | DiskLocation-  -- ^ The spec was loaded from disk (e.g. 'Prelude.spec' or similar)-  deriving Show+  | LibFound Module LiquidLib  -- | Load any relevant spec for the input list of 'Module's, by querying both the 'ExternalPackageState' -- and the 'HomePackageTable'.@@ -65,19 +45,19 @@                   -> TcM [SpecFinderResult] findRelevantSpecs lhAssmPkgExcludes hscEnv mods = do     eps <- liftIO $ readIORef (euc_eps $ ue_eps $ hsc_unit_env hscEnv)-    foldM (loadRelevantSpec eps) mempty mods+    mapM (loadRelevantSpec eps) mods   where -    loadRelevantSpec :: ExternalPackageState -> [SpecFinderResult] -> Module -> TcM [SpecFinderResult]-    loadRelevantSpec eps !acc currentModule = do+    loadRelevantSpec :: ExternalPackageState -> Module -> TcM SpecFinderResult+    loadRelevantSpec eps currentModule = do       res <- liftIO $ runMaybeT $-        lookupInterfaceAnnotations eps (ue_hpt $ hsc_unit_env hscEnv) currentModule+        lookupInterfaceAnnotations eps (ue_hpt $ hsc_unit_env hscEnv) (hsc_NC hscEnv) currentModule       case res of         Nothing         -> do           mAssm <- loadModuleLHAssumptionsIfAny currentModule-          return $ fromMaybe (SpecNotFound currentModule) mAssm : acc+          return $ fromMaybe (SpecNotFound currentModule) mAssm         Just specResult ->-          return (specResult : acc)+          return specResult      loadModuleLHAssumptionsIfAny m | isImportExcluded m = return Nothing                                    | otherwise = do@@ -91,7 +71,7 @@           -- read the EPS again           eps2 <- liftIO $ readIORef (euc_eps $ ue_eps $ hsc_unit_env hscEnv)           -- now look up the assumptions-          liftIO $ runMaybeT $ lookupInterfaceAnnotationsEPS eps2 assumptionsMod+          liftIO $ runMaybeT $ lookupInterfaceAnnotationsEPS eps2 (hsc_NC hscEnv) assumptionsMod         FoundMultiple{} -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError [] $                              missingInterfaceErrorDiagnostic (initIfaceMessageOpts $ hsc_dflags hscEnv) $                              cannotFindModule hscEnv assumptionsModName res@@ -104,51 +84,16 @@     assumptionsModuleName m =       mkModuleNameFS $ moduleNameFS (moduleName m) <> "_LHAssumptions" --- | If this module has a \"companion\" '.spec' file sitting next to it, this 'SpecFinder'--- will try loading it.-findCompanionSpec :: HscEnv -> Module -> IO SpecFinderResult-findCompanionSpec hscEnv m = do-  res <- runMaybeT $ lookupCompanionSpec hscEnv m-  case res of-    Nothing -> pure $ SpecNotFound m-    Just s  -> pure s---- | Load a spec by trying to parse the relevant \".spec\" file from the filesystem.-lookupInterfaceAnnotations :: ExternalPackageState -> HomePackageTable -> SpecFinder m-lookupInterfaceAnnotations eps hpt thisModule = do-  lib <- MaybeT $ pure $ Util.deserialiseLiquidLib thisModule eps hpt-  pure $ LibFound thisModule InterfaceLocation lib--lookupInterfaceAnnotationsEPS :: ExternalPackageState -> SpecFinder m-lookupInterfaceAnnotationsEPS eps thisModule = do-  lib <- MaybeT $ pure $ Util.deserialiseLiquidLibFromEPS thisModule eps-  pure $ LibFound thisModule InterfaceLocation lib---- | If this module has a \"companion\" '.spec' file sitting next to it, this 'SpecFinder'--- will try loading it.-lookupCompanionSpec :: HscEnv -> SpecFinder m-lookupCompanionSpec hscEnv thisModule = do--  modSummary <- MaybeT $ pure $ lookupModSummary hscEnv (moduleName thisModule)-  file       <- MaybeT $ pure (ml_hs_file . ms_location $ modSummary)-  parsed     <- MaybeT $ do-    mbSpecContent <- try (Misc.sayReadFile (specFile file))-    case mbSpecContent of-      Left (_e :: SomeException) -> pure Nothing-      Right raw -> pure $ Just $ specSpecificationP (specFile file) raw+-- | Load specs from an interface file.+lookupInterfaceAnnotations :: ExternalPackageState -> HomePackageTable -> NameCache -> SpecFinder m+lookupInterfaceAnnotations eps hpt nameCache thisModule = do+  lib <- MaybeT $ Serialisation.deserialiseLiquidLib thisModule eps hpt nameCache+  pure $ LibFound thisModule lib -  case parsed of-    Left peb -> do-      let errMsg = O.text "Error when parsing "-             O.<+> O.text (specFile file) O.<+> O.text ":"-             O.<+> O.text (errorBundlePretty peb)-      lift $ Util.pluginAbort (O.showSDoc (hsc_dflags hscEnv) errMsg)-    Right (_, spec) -> do-      let bareSpec = toBareSpec spec-      pure $ SpecFound thisModule DiskLocation bareSpec-  where-    specFile :: FilePath -> FilePath-    specFile fp = withExt fp Spec+lookupInterfaceAnnotationsEPS :: ExternalPackageState -> NameCache -> SpecFinder m+lookupInterfaceAnnotationsEPS eps nameCache thisModule = do+  lib <- MaybeT $ Serialisation.deserialiseLiquidLibFromEPS thisModule eps nameCache+  pure $ LibFound thisModule lib  -- | Returns a list of 'StableModule's which can be filtered out of the dependency list, because they are -- selectively \"toggled\" on and off by the LiquidHaskell's configuration, which granularity can be
src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs view
@@ -13,9 +13,6 @@   -- * Passing options   -- $passingOptions -  -- * Understanding LiquidHaskell Spec resolution strategies-  -- $specResolutionStrategies-   -- * Providing specifications for existing packages   -- $specForExisting @@ -162,33 +159,6 @@ {- $usingGHCi  Using GHCi is supported out of the box, and it will work as expected.---}--{- $specResolutionStrategies--Let's revisit our 'Toy.A' module. There are two different ways to annotate an existing Haskell module,-and they are the following:--1. __(Recommended)__ Add the /LH/ annotations directly inside the Haskell file (like in the example above).-   This has the advantage that any changes to the annotations trigger recompilation, and ensure the specs-   will never get stale and go out-of-sync. The disadvantage of this approach is that it can clutter quite a-   bit the target 'Module'.--2. Add the specifications as a separate __companion__ @.spec@ file to be placed alongside the Haskell one.-   To rehash the example above, we could have also added a new @Toy/A.spec@ file living in the same folder-   of our @A.hs@ file, with a content like this:--   @-   module spec Toy.A where--   one :: {v:Int | v = 1 }-   assume notThree :: {v : Nat | v != 3 }-   two :: Nat-   @--   This has the advantage of being more compartmentalised, but it's also a weakness as it might not be-   immediately obvious that a Haskell module has associated refinements.  -}
src/Language/Haskell/Liquid/GHC/Plugin/Types.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}  module Language.Haskell.Liquid.GHC.Plugin.Types@@ -19,25 +19,16 @@     , PipelineData(..)      -- * Acquiring and manipulating data from the typechecking phase-    , TcData-    , tcAllImports-    , tcQualifiedImports-    , tcResolvedNames-    , tcAvailableTyCons-    , tcAvailableVars-    , mkTcData     ) where  import           Data.Binary                             as B+import           Data.Data                               ( Data ) import           GHC.Generics                      hiding ( moduleName ) -import qualified Data.HashSet        as HS-+import           Language.Haskell.Liquid.Parse (BPspec) import           Language.Haskell.Liquid.Types.Specs import           Liquid.GHC.API         as GHC-import qualified Language.Haskell.Liquid.GHC.Interface   as LH import           Language.Haskell.Liquid.GHC.Misc (realSrcLocSourcePos)-import           Language.Fixpoint.Types.Names            ( Symbol ) import           Language.Fixpoint.Types.Spans            ( SourcePos, dummyPos )  @@ -46,7 +37,7 @@   -- ^ The target /LiftedSpec/.   ,  llDeps   :: TargetDependencies   -- ^ The specs which were necessary to produce the target 'BareSpec'.-  } deriving (Show, Generic)+  } deriving (Show, Data, Generic)  instance B.Binary LiquidLib @@ -92,48 +83,5 @@  data PipelineData = PipelineData {     pdUnoptimisedCore :: ModGuts-  , pdTcData :: TcData-  , pdSpecComments :: [SpecComment]-  }---- | Data which can be \"safely\" passed to the \"Core\" stage of the pipeline.--- The notion of \"safely\" here is a bit vague: things like imports are somewhat--- guaranteed not to change, but things like identifiers might, so they shouldn't--- land here.-data TcData = TcData {-    tcAllImports       :: HS.HashSet Symbol-  , tcQualifiedImports :: QImports-  , tcResolvedNames    :: [(Name, Maybe TyThing)]-  , tcAvailableTyCons  :: [GHC.TyCon]-  -- ^ Sometimes we might be in a situation where we have \"wrapper\" modules that-  -- simply re-exports everything from the original module, and therefore when LH-  -- tries to resolve the GHC identifier associated to a data constructor in scope-  -- (from the call to 'lookupTyThings') we might not be able to find a match because-  -- the 'mg_tcs' for the input 'ModGuts' is empty (because the type constructor are not-  -- defined in the /wrapper/ module, but rather in the /wrapped/ module itself). This is-  -- why we look at the 'ModGuts' 's 'AvailInfo' to extract any re-exported 'TyCon' out of that.-  , tcAvailableVars    :: [Var]-  -- ^ Ditto as for 'reflectedTyCons', but for identifiers.-  }--instance Outputable TcData where-    ppr (TcData{..}) =-          text "TcData { imports     = " <+> text (show $ HS.toList tcAllImports)-      <+> text "       , qImports    = " <+> text (show tcQualifiedImports)-      <+> text "       , names       = " <+> ppr tcResolvedNames-      <+> text "       , availTyCons = " <+> ppr tcAvailableTyCons-      <+> text " }"---- | Constructs a 'TcData' out of a 'TcGblEnv'.-mkTcData :: [LImportDecl GhcRn]-         -> [(Name, Maybe TyThing)]-         -> [TyCon]-         -> [Var]-         -> TcData-mkTcData imps resolvedNames availTyCons availVars = TcData {-    tcAllImports       = LH.allImports       imps-  , tcQualifiedImports = LH.qualifiedImports imps-  , tcResolvedNames    = resolvedNames-  , tcAvailableTyCons  = availTyCons-  , tcAvailableVars    = availVars+  , pdSpecComments :: [BPspec]   }
− src/Language/Haskell/Liquid/GHC/Plugin/Util.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Language.Haskell.Liquid.GHC.Plugin.Util (-      -- * Serialising and deserialising things from/to specs.-        serialiseLiquidLib-      , deserialiseLiquidLib-      , deserialiseLiquidLibFromEPS--      -- * Aborting the plugin execution-      , pluginAbort-      ) where--import           Data.Foldable                            ( asum )--import           Control.Monad.IO.Class-import           Control.Monad--import qualified Data.Binary                             as B-import           Data.Binary                              ( Binary )-import qualified Data.ByteString.Lazy                    as B-import           Data.Typeable-import           Data.Maybe                               ( listToMaybe )--import           Liquid.GHC.API-import           Language.Haskell.Liquid.GHC.Plugin.Types (LiquidLib)---pluginAbort :: MonadIO m => String -> m a-pluginAbort = liftIO . throwGhcExceptionIO . ProgramError------- Serialising and deserialising Specs-----deserialiseBinaryObjectFromEPS-  :: forall a. (Typeable a, Binary a)-  => Module-  -> ExternalPackageState-  -> Maybe a-deserialiseBinaryObjectFromEPS thisModule eps = extractFromEps-  where-    extractFromEps :: Maybe a-    extractFromEps = listToMaybe $ findAnns (B.decode . B.pack) (eps_ann_env eps) (ModuleTarget thisModule)--deserialiseBinaryObject :: forall a. (Typeable a, Binary a)-                        => Module-                        -> ExternalPackageState-                        -> HomePackageTable-                        -> Maybe a-deserialiseBinaryObject thisModule eps hpt =-    asum [extractFromHpt, deserialiseBinaryObjectFromEPS thisModule eps]-  where-    extractFromHpt :: Maybe a-    extractFromHpt = do-      modInfo <- lookupHpt hpt (moduleName thisModule)-      guard (thisModule == (mi_module . hm_iface $ modInfo))-      xs <- mapM (fromSerialized deserialise . ifAnnotatedValue) (mi_anns . hm_iface $ modInfo)-      listToMaybe xs--    deserialise :: [B.Word8] -> a-    deserialise payload = B.decode (B.pack payload)--serialiseBinaryObject :: forall a. (Binary a, Typeable a) => a -> Module -> Annotation-serialiseBinaryObject obj thisModule = serialised-  where-    serialised :: Annotation-    serialised = Annotation (ModuleTarget thisModule) (toSerialized (B.unpack . B.encode) obj)---- | Serialise a 'LiquidLib', removing the termination checks from the target.-serialiseLiquidLib :: LiquidLib -> Module -> Annotation-serialiseLiquidLib lib = serialiseBinaryObject @LiquidLib lib--deserialiseLiquidLib :: Module -> ExternalPackageState -> HomePackageTable -> Maybe LiquidLib-deserialiseLiquidLib thisModule = deserialiseBinaryObject @LiquidLib thisModule--deserialiseLiquidLibFromEPS :: Module -> ExternalPackageState -> Maybe LiquidLib-deserialiseLiquidLibFromEPS = deserialiseBinaryObjectFromEPS @LiquidLib
src/Language/Haskell/Liquid/GHC/TypeRep.hs view
@@ -30,14 +30,12 @@ eqType' :: Type -> Type -> Bool  eqType' (LitTy l1) (LitTy l2)    = l1 == l2  -eqType' (CoercionTy c1) (CoercionTy c2) -  = c1 == c2  -eqType'(CastTy t1 c1) (CastTy t2 c2) -  = eqType' t1 t2 && c1 == c2 +eqType' (CoercionTy _c1) (CoercionTy _c2) = True+eqType'(CastTy t1 _c1) (CastTy t2 _c2) = eqType' t1 t2 eqType' (FunTy a1 m1 t11 t12) (FunTy a2 m2 t21 t22)   = a1 == a2 && m1 == m2 && eqType' t11 t21 && eqType' t12 t22   eqType' (ForAllTy (Bndr v1 _) t1) (ForAllTy (Bndr v2 _) t2) -  = eqType' t1 (subst v2 (TyVarTy v1) t2) +  = eqType' t1 (substType v2 (TyVarTy v1) t2) eqType' (TyVarTy v1) (TyVarTy v2)    = v1 == v2  eqType' (AppTy t11 t12) (AppTy t21 t22) @@ -50,10 +48,6 @@  deriving instance (Eq tyvar, Eq argf) => Eq (VarBndr tyvar argf) -instance Eq Coercion where-  _ == _ = True -- showTy :: Type -> String  showTy (TyConApp c ts) = "(RApp   " ++ showPpr c ++ " " ++ sep' ", " (showTy <$> ts) ++ ")" showTy (AppTy t1 t2)   = "(TAppTy " ++ (showTy t1 ++ " " ++ showTy t2) ++ ")" @@ -75,96 +69,29 @@ -- | GHC Type Substitutions --------------------------------------------------- ------------------------------------------------------------------------------- -class SubstTy a where-  subst :: TyVar -> Type -> a -> a-  subst _ _ = id  --instance SubstTy Type where-  subst = substType- substType :: TyVar -> Type -> Type -> Type substType x tx (TyConApp c ts) -  = TyConApp c (subst x tx <$> ts)+  = TyConApp c (substType x tx <$> ts) substType x tx (AppTy t1 t2)   -  = AppTy (subst x tx t1) (subst x tx t2) +  = AppTy (substType x tx t1) (substType x tx t2) substType x tx (TyVarTy y)      | symbol x == symbol y   = tx    | otherwise   = TyVarTy y  substType x tx (FunTy aaf m t1 t2)-  = FunTy aaf m (subst x tx t1) (subst x tx t2)+  = FunTy aaf m (substType x tx t1) (substType x tx t2) substType x tx f@(ForAllTy b@(Bndr y _) t)     | symbol x == symbol y    = f   | otherwise -  = ForAllTy b (subst x tx t)+  = ForAllTy b (substType x tx t) substType x tx (CastTy t c)    -  = CastTy (subst x tx t) (subst x tx c)+  = let ss = extendSubstInScopeSet (zipTvSubst [x] [tx]) (tyCoVarsOfCo c)+     in CastTy (substType x tx t) (substCo ss c) substType x tx (CoercionTy c)  -  = CoercionTy $ subst x tx c +  = let ss = extendSubstInScopeSet (zipTvSubst [x] [tx]) (tyCoVarsOfCo c)+     in CoercionTy $ substCo ss c substType _ _  (LitTy l)   = LitTy l   --instance SubstTy Coercion where-  subst = substCoercion--substCoercion :: TyVar -> Type -> Coercion -> Coercion-substCoercion x tx (TyConAppCo r c cs)-  = TyConAppCo (subst x tx r) c (subst x tx <$> cs)-substCoercion x tx (AppCo c1 c2)-  = AppCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (FunCo r afl afr cN c1 c2)-  = FunCo r afl afr cN (subst x tx c1) (subst x tx c2) -- TODO(adinapoli) Is this the correct substitution?-substCoercion x tx (ForAllCo y f1 f2 c1 c2)-  | symbol x == symbol y -  = ForAllCo y f1 f2 c1 c2-  | otherwise -  = ForAllCo y f1 f2 (subst x tx c1) (subst x tx c2)-substCoercion _ _ (CoVarCo y)-  = CoVarCo y -substCoercion x tx (AxiomInstCo co bi cs)-  = AxiomInstCo (subst x tx co) bi (subst x tx <$> cs)  -substCoercion x tx (UnivCo y r t1 t2)-  = UnivCo (subst x tx y) (subst x tx r) (subst x tx t1) (subst x tx t2)-substCoercion x tx (SymCo c)-  = SymCo (subst x tx c)-substCoercion x tx (TransCo c1 c2)-  = TransCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (AxiomRuleCo ca cs)-  = AxiomRuleCo (subst x tx ca)  (subst x tx <$> cs)  -substCoercion x tx (SelCo i c)-  = SelCo i (subst x tx c)-substCoercion x tx (LRCo i c)-  = LRCo i (subst x tx c)-substCoercion x tx (InstCo c1 c2)-  = InstCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (KindCo c)-  = KindCo (subst x tx c)-substCoercion x tx (SubCo c)-  = SubCo (subst x tx c)-substCoercion _x _tx (Refl t)-  = Refl t-substCoercion _x _tx (GRefl r t c)-  = GRefl r t c-substCoercion _x _tx (HoleCo c)-  = HoleCo c--instance SubstTy Role where-instance SubstTy (CoAxiom Branched) where--instance SubstTy UnivCoProvenance where-  subst x tx (PhantomProv c)-    = PhantomProv $ subst x tx c -  subst x tx (ProofIrrelProv c)-    = ProofIrrelProv $ subst x tx c -  subst _ _ ch -    = ch --instance SubstTy CoAxiomRule where-  subst x tx (CoAxiomRule n rs r ps) -    = CoAxiomRule n (subst x tx <$> rs) (subst x tx r) (\eq -> subst x tx (ps (subst x tx eq)))--instance (SubstTy a, Functor m) => SubstTy (m a) where-  subst x tx xs = subst x tx <$> xs
+ src/Language/Haskell/Liquid/LHNameResolution.hs view
@@ -0,0 +1,834 @@+-- | This module provides functions to resolve names in specs.+--+-- There are two major namespaces in LH:+--+-- 1) The names of Haskell entities+-- 2) The names of logic entities+--+-- At the moment LH resolves names to Haskell entities, while resolving logic+-- entities remains work in progress.+--+-- Haskell entities include all functions that LH might reflect, or types that+-- might be referred in refinment types, type aliases or other annotations.+--+-- Logic entities include the names of reflected functions, inlined functions,+-- uninterpreted functions, predefined functions, local bindings, reflected data+-- constructors and parameters of Haskell functions in specs of other local+-- bindings.+--+-- The resolution pipeline goes as follows.+--+-- * First the module specs are parsed into a 'BareSpecParsed'.+--   Here all names are unresolved.+-- * Next the names of Haskell entities are resolved by 'resolveLHNames'.+--   For now, this pass doesn't change the type of the names.+-- * Next the names of logic entities are resolved. This pass produces+--   a 'BareSpecLHName', where 'Symbol's are replaced with 'LHName'. At+--   the moment most LHNames are just wrappers over the symbols. As name+--   resolution is implemented for logic names, the wrappers will be+--   replaced with the actual result of name resolution.+--+-- 'BareSpecLHName' has a bijection to 'BareSpec' via a 'LogicNameEnv'+-- which allows to convert 'LHName' to an unambiguous form of 'Symbol'+-- and back. The bijection is implemented with the functions 'toBareSpecLHName'+-- and 'fromBareSpecLHName'. This allows to use liquid-fixpoint functions+-- unmodified as they will continue to operate on (now unambiguous) Symbols.+--+-- At the same time, the 'BareSpecLHName' form is kept to serialize and to+-- resolve names of modules that import the specs.+--++{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeApplications           #-}++module Language.Haskell.Liquid.LHNameResolution+  ( resolveLHNames+  , resolveSymbolToTcName+  , exprArg+  , fromBareSpecLHName+  , toBareSpecLHName+  , LogicNameEnv(..)+  ) where++import qualified Liquid.GHC.API         as GHC hiding (Expr, panic)+import qualified Language.Haskell.Liquid.GHC.Interface   as LH+import qualified Language.Haskell.Liquid.GHC.Misc        as LH+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp++import           Control.Monad ((<=<), mplus, unless, void)+import           Control.Monad.Identity+import           Control.Monad.State.Strict+import           Data.Bifunctor (first)+import qualified Data.Char                               as Char+import           Data.Coerce (coerce)+import           Data.Data (Data, gmapT)+import           Data.Generics (extT)+++import qualified Data.HashSet                            as HS+import qualified Data.HashMap.Strict                     as HM+import           Data.List (find, isSuffixOf, nubBy)+import           Data.List.Extra (dropEnd)+import           Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList)+import qualified Data.Text                               as Text+import qualified GHC.Types.Name.Occurrence++import           Language.Fixpoint.Types as F hiding (Error, panic)+import qualified Language.Haskell.Liquid.Bare.Resolve as Resolve+import           Language.Haskell.Liquid.Bare.Types (LocalVars(lvNames), LocalVarDetails(lvdLclEnv))+import           Language.Haskell.Liquid.Name.LogicNameEnv+import qualified Language.Haskell.Liquid.Types.DataDecl as DataDecl+import           Language.Haskell.Liquid.Types.Errors (TError(ErrDupNames, ErrResolve), panic)+import           Language.Haskell.Liquid.Types.Specs as Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.UX.Config+import           Language.Haskell.Liquid.WiredIn++import qualified Text.PrettyPrint.HughesPJ as PJ+import qualified Text.Printf               as Printf++-- | Collects type aliases from the current module and its dependencies.+--+-- It doesn't matter at the moment in which module a type alias is defined.+-- Type alias names cannot be qualified at the moment, and therefore their+-- names identify them uniquely.+collectTypeAliases+  :: GHC.Module+  -> BareSpecParsed+  -> TargetDependencies+  -> HM.HashMap Symbol (GHC.Module, RTAlias Symbol ())+collectTypeAliases m spec deps =+    let bsAliases = [ (rtName a, (m, void a)) | a <- map val (aliases spec) ]+        depAliases =+          [ (rtName a, (GHC.unStableModule sm, void a))+          | (sm, lspec) <- HM.toList (getDependencies deps)+          , a <- map val (HS.toList $ liftedAliases lspec)+          ]+     in+        HM.fromList $ bsAliases ++ depAliases++collectExprAliases+  :: BareSpecParsed+  -> TargetDependencies+  -> HS.HashSet Symbol+collectExprAliases spec deps =+    let bsAliases = HS.fromList $ map (rtName . val) (ealiases spec)+        depAliases =+          [ HS.map (rtName . val) $ liftedEaliases lspec+          | (_, lspec) <- HM.toList (getDependencies deps)+          ]+     in+        HS.unions $ bsAliases : depAliases++-- | Converts occurrences of LHNUnresolved to LHNResolved using the provided+-- type aliases and GlobalRdrEnv.+resolveLHNames+  :: Config+  -> GHC.Module+  -> LocalVars+  -> GHC.ImportedMods+  -> GHC.GlobalRdrEnv+  -> BareSpecParsed+  -> TargetDependencies+  -> Either [Error] (BareSpec, LogicNameEnv, LogicMap)+resolveLHNames cfg thisModule localVars impMods globalRdrEnv bareSpec0 dependencies = do+    let ((bs, logicNameEnv, lmap2), ro) =+          flip runState RenameOutput {roErrors = [], roUsedNames = [], roUsedDataCons = mempty} $ do+            -- A generic traversal that resolves names of Haskell entities+            sp1 <- mapMLocLHNames (\l -> (<$ l) <$> resolveLHName l) $+                     fixExpressionArgsOfTypeAliases taliases bareSpec0+            -- Data decls contain fieldnames that introduce measures with the+            -- same names. We resolved them before constructing the logic+            -- environment.+            dataDecls <- mapM (mapDataDeclFieldNamesM resolveFieldLogicName) (dataDecls sp1)+            let sp2 = sp1 {dataDecls}++            es0 <- gets roErrors+            if null es0 then do++              -- Now we do a second traversal to resolve logic names+              let (inScopeEnv, logicNameEnv0, privateReflectNames, unhandledNames) =+                    makeLogicEnvs impMods thisModule sp2 dependencies+              -- Add resolved local defines to the logic map+                  lmap1 =+                    lmap <> mkLogicMap (HM.fromList $+                                         (\(k , v) ->+                                             let k' = lhNameToResolvedSymbol <$> k in+                                             (F.val k', (val <$> v) { lmVar = k' }))+                                         <$> defines sp2)+              sp3 <- fromBareSpecLHName <$>+                       resolveLogicNames+                         cfg+                         inScopeEnv+                         globalRdrEnv+                         unhandledNames+                         lmap1+                         localVars+                         logicNameEnv0+                         privateReflectNames+                         allEaliases+                         sp2+              dcs <- gets roUsedDataCons+              return (sp3 {usedDataCons = dcs} , logicNameEnv0, lmap1)+            else+              return ( error "resolveLHNames: invalid spec"+                     , error "resolveLHNames: invalid logic environment"+                     , error "resolveLHNames: invalid logic map")+        logicNameEnv' = extendLogicNameEnv logicNameEnv (roUsedNames ro)+    if null (roErrors ro) then+      Right (bs, logicNameEnv', lmap2)+    else+      Left (roErrors ro)+  where+    taliases = collectTypeAliases thisModule bareSpec0 dependencies+    allEaliases = collectExprAliases bareSpec0 dependencies++    -- add defines from dependencies to the logical map+    lmap =+        (LH.listLMap <>) $+        mconcat $+        map (mkLogicMap . HM.map (fmap lhNameToResolvedSymbol) . liftedDefines) $+        HM.elems $+        getDependencies dependencies++    resolveFieldLogicName n =+      case n of+        LHNUnresolved LHLogicNameBinder s -> pure $ makeLogicLHName s thisModule Nothing+        _ -> panic Nothing $ "unexpected name: " ++ show n++    resolveLHName lname =+      case val lname of+        LHNUnresolved LHTcName s+          | isTuple s ->+            pure $ LHNResolved (LHRGHC $ GHC.tupleTyConName GHC.BoxedTuple (tupleArity s)) s+          | isList s ->+            pure $ LHNResolved (LHRGHC GHC.listTyConName) s+          | s == "*" ->+            pure $ LHNResolved (LHRGHC GHC.liftedTypeKindTyConName) s+          | otherwise ->+            case HM.lookup s taliases of+              Just (m, _) -> pure $ LHNResolved (LHRLogic $ LogicName s m Nothing) s+              Nothing -> lookupGRELHName LHTcName lname s listToMaybe+        LHNUnresolved ns@(LHVarName lcl) s+          | isDataCon s ->+              lookupGRELHName (LHDataConName lcl) lname s listToMaybe+          | otherwise ->+              lookupGRELHName ns lname s+                (fmap (either id GHC.getName) . Resolve.lookupLocalVar localVars (atLoc lname s))+        LHNUnresolved LHLogicNameBinder s ->+          pure $ makeLogicLHName s thisModule Nothing+        n@(LHNUnresolved LHLogicName _) ->+          -- This one will be resolved by resolveLogicNames+          pure n+        LHNUnresolved ns s -> lookupGRELHName ns lname s listToMaybe+        n -> pure n++    lookupGRELHName ns lname s localNameLookup =+      case maybeDropImported ns $ GHC.lookupGRE globalRdrEnv (mkLookupGRE ns s) of+        [e] -> do+          let n = GHC.greName e+              n' = fromMaybe n $ localNameLookup [n]+          pure $ LHNResolved (LHRGHC n') s+        es@(_:_) -> do+          let topLevelNames = map GHC.greName es+          case localNameLookup topLevelNames of+            Just n | notElem n topLevelNames ->+              pure $ LHNResolved (LHRGHC n) s+            _ -> do+              addError+                (ErrDupNames+                   (LH.fSrcSpan lname)+                   (pprint s)+                   (map (PJ.text . GHC.showPprUnsafe) es)+                )+              pure $ val lname+        [] ->+          case localNameLookup [] of+            Just n' ->+              pure $ LHNResolved (LHRGHC n') s+            Nothing -> do+              addError+                (errResolve (nameSpaceKind ns) "Cannot resolve name" (s <$ lname))+              pure $ val lname++    maybeDropImported ns es+      | localNameSpace ns = filter GHC.isLocalGRE es+      | otherwise = es++    localNameSpace = \case+      LHDataConName lcl -> lcl == LHThisModuleNameF+      LHVarName lcl -> lcl == LHThisModuleNameF+      LHTcName -> False+      LHLogicNameBinder -> False+      LHLogicName -> False++    nameSpaceKind :: LHNameSpace -> PJ.Doc+    nameSpaceKind = \case+      LHTcName -> "type constructor"+      LHDataConName LHAnyModuleNameF -> "data constructor"+      LHDataConName LHThisModuleNameF -> "locally-defined data constructor"+      LHVarName LHAnyModuleNameF -> "variable"+      LHVarName LHThisModuleNameF -> "variable from the current module"+      LHLogicNameBinder -> "logic name binder"+      LHLogicName -> "logic name"++    isDataCon s = case Text.uncons (Text.takeWhileEnd (/= '.') (symbolText s)) of+      Just (c, _) -> Char.isUpper c || c == ':'+      Nothing -> False++tupleArity :: Symbol -> Int+tupleArity s =+      let a = read $ drop 5 $ symbolString s+       in if a > 64 then+            error $ "tupleArity: Too large (more than 64): " ++ show a+          else+            a++errResolve :: PJ.Doc -> String -> LocSymbol -> Error+errResolve k msg lx = ErrResolve (LH.fSrcSpan lx) k (pprint (val lx)) (PJ.text msg)++-- | Produces an LHName from a symbol by looking it in the rdr environment.+resolveSymbolToTcName :: GHC.GlobalRdrEnv -> LocSymbol -> Either Error (Located LHName)+resolveSymbolToTcName globalRdrEnv lx+    | isTuple s =+      pure $ LHNResolved (LHRGHC $ GHC.tupleTyConName GHC.BoxedTuple (tupleArity s)) s <$ lx+    | isList s =+      pure $ LHNResolved (LHRGHC GHC.listTyConName) s <$ lx+    | s == "*" =+      pure $ LHNResolved (LHRGHC GHC.liftedTypeKindTyConName) s <$ lx+    | otherwise =+      case GHC.lookupGRE globalRdrEnv (mkLookupGRE LHTcName s) of+        [e] -> Right $ LHNResolved (LHRGHC $ GHC.greName e) s <$ lx+        [] -> Left $ errResolve "type constructor" "Cannot resolve name" lx+        es -> Left $ ErrDupNames+                (LH.fSrcSpan lx)+                (pprint s)+                (map (PJ.text . GHC.showPprUnsafe) es)+  where+    s = val lx++-- | Resolving logic names can produce errors and new names to add to the+-- environment. New names might be produced when encountering data constructors+-- or functions from the logic map.+data RenameOutput = RenameOutput+    { roErrors :: [Error]+      -- | Names of used data constructors, and names of used reflected+      -- functions and used logic map names+    , roUsedNames :: [LHName]+      -- | Names of used data constructors+    , roUsedDataCons :: HS.HashSet LHName+    }++addError :: Error -> State RenameOutput ()+addError e = modify (\ro -> ro { roErrors = e : roErrors ro })++addName :: LHName -> State RenameOutput ()+addName n = modify (\ro -> ro { roUsedNames = n : roUsedNames ro })++addDataConsName :: LHName -> State RenameOutput ()+addDataConsName n = modify (\ro -> ro { roUsedDataCons = HS.insert n (roUsedDataCons ro) })++mkLookupGRE :: LHNameSpace -> Symbol -> GHC.LookupGRE GHC.GREInfo+mkLookupGRE ns s =+    let m = LH.takeModuleNames s+        n = LH.dropModuleNames s+        nString = symbolString n+        oname = GHC.mkOccName (mkGHCNameSpace ns) nString+        rdrn =+          if m == "" then+            GHC.mkRdrUnqual oname+          else+            GHC.mkRdrQual (GHC.mkModuleName $ symbolString m) oname+     in GHC.LookupRdrName rdrn (mkWhichGREs ns)+  where+    mkWhichGREs :: LHNameSpace -> GHC.WhichGREs GHC.GREInfo+    mkWhichGREs = \case+      LHTcName -> GHC.SameNameSpace+      LHDataConName _ -> GHC.SameNameSpace+      LHVarName _ -> GHC.RelevantGREs+        { GHC.includeFieldSelectors = GHC.WantNormal+        , GHC.lookupVariablesForFields = True+        , GHC.lookupTyConsAsWell = False+        }+      LHLogicNameBinder -> panic Nothing "mkWhichGREs: unexpected namespace LHLogicNameBinder"+      LHLogicName -> panic Nothing "mkWhichGREs: unexpected namespace LHLogicName"++    mkGHCNameSpace = \case+      LHTcName -> GHC.tcName+      LHDataConName _ -> GHC.dataName+      LHVarName _ -> GHC.Types.Name.Occurrence.varName+      LHLogicNameBinder -> panic Nothing "mkGHCNameSpace: unexpected namespace LHLogicNameBinder"+      LHLogicName -> panic Nothing "mkGHCNameSpace: unexpected namespace LHLogicName"++-- | Changes unresolved names to local resolved names in the body of type+-- aliases.+resolveBoundVarsInTypeAliases :: BareSpecParsed -> BareSpecParsed+resolveBoundVarsInTypeAliases = updateAliases resolveBoundVars+  where+    resolveBoundVars boundVars = \case+      LHNUnresolved LHTcName s ->+        if elem s boundVars then+          LHNResolved (LHRLocal s) s+        else+          LHNUnresolved LHTcName s+      n ->+        error $ "resolveLHNames: Unexpected resolved name: " ++ show n++    -- Applies a function to the body of type aliases, passes to every call the+    -- arguments of the alias.+    updateAliases f spec =+       spec+            { aliases = [ Loc sp0 sp1 (a { rtBody = mapLHNames (f args) (rtBody a) })+                        | Loc sp0 sp1 a <- aliases spec+                        , let args = rtTArgs a ++ rtVArgs a+                        ]+            }++-- | The expression arguments of type aliases are initially parsed as+-- types. This function converts them to expressions.+--+-- For instance, in @Prop (Ev (plus n n))@ where `Prop` is the alias+--+-- > {-@ type Prop E = {v:_ | prop v = E} @-}+--+-- the parser builds a type for @Ev (plus n n)@.+--+fixExpressionArgsOfTypeAliases+  :: HM.HashMap Symbol (GHC.Module, RTAlias Symbol ())+  -> BareSpecParsed+  -> BareSpecParsed+fixExpressionArgsOfTypeAliases taliases =+    mapBareTypes go . resolveBoundVarsInTypeAliases+  where+    go :: BareTypeParsed -> BareTypeParsed+    go (RApp c@(BTyCon { btc_tc = Loc _ _ (LHNUnresolved LHTcName s) }) ts rs r)+      | Just (_, rta) <- HM.lookup s taliases =+        RApp c (fixExprArgs (btc_tc c) rta (map go ts)) (map goRef rs) r+    go (RApp c ts rs r) =+        RApp c (map go ts) (map goRef rs) r+    go (RAppTy t1 t2 r)  = RAppTy (go t1) (go t2) r+    go (RFun  x i t1 t2 r) = RFun  x i (go t1) (go t2) r+    go (RAllT a t r)     = RAllT a (go t) r+    go (RAllP a t)       = RAllP a (go t)+    go (RAllE x t1 t2)   = RAllE x (go t1) (go t2)+    go (REx x t1 t2)     = REx   x (go t1) (go t2)+    go (RRTy e r o t)    = RRTy  e r o     (go t)+    go t@RHole{}         = t+    go t@RVar{}          = t+    go t@RExprArg{}      = t+    goRef (RProp ss t)   = RProp ss (go t)++    fixExprArgs lname rta ts =+      let n = length (rtTArgs rta)+          (targs, eargs) = splitAt n ts+          msg = "FIX-EXPRESSION-ARG: " ++ showpp (rtName rta)+          toExprArg = exprArg (LH.fSourcePos lname) msg+       in targs ++ [ RExprArg $ toExprArg e <$ lname | e <- eargs ]++mapBareTypes :: (BareTypeParsed -> BareTypeParsed) -> BareSpecParsed -> BareSpecParsed+mapBareTypes f  = go+  where+    go :: Data a => a -> a+    go = gmapT (go `extT` f)++-- | exprArg converts a tyVar to an exprVar because parser cannot tell+--   this function allows us to treating (parsed) "types" as "value"+--   arguments, e.g. type Matrix a Row Col = List (List a Row) Col+--   Note that during parsing, we don't necessarily know whether a+--   string is a type or a value expression. E.g. in tests/pos/T1189.hs,+--   the string `Prop (Ev (plus n n))` where `Prop` is the alias:+--     {-@ type Prop E = {v:_ | prop v = E} @-}+--   the parser will chomp in `Ev (plus n n)` as a `BareType` and so+--   `exprArg` converts that `BareType` into an `Expr`.+exprArg :: SourcePos -> String -> BareTypeParsed -> ExprV LocSymbol+exprArg l msg = notracepp ("exprArg: " ++ msg) . go+  where+    go :: BareTypeParsed -> ExprV LocSymbol+    go (RExprArg e)     = val e+    go (RVar (BTV x) _)       = EVar x+    go (RApp x [] [] _) = EVar (getLHNameSymbol <$> btc_tc x)+    go (RApp f ts [] _) = eApps (EVar (getLHNameSymbol <$> btc_tc f)) (go <$> ts)+    go (RAppTy t1 t2 _) = EApp (go t1) (go t2)+    go z                = panic sp $ Printf.printf "Unexpected expression parameter: %s in %s" (show $ parsedToBareType z) msg+    sp                  = Just (LH.sourcePosSrcSpan l)++-- | An environment of names in scope+--+-- For each symbol we have the aliases with which it is imported and the+-- name corresponding to each alias.+type InScopeNonReflectedEnv = SEnv [(GHC.ModuleName, (GHC.Module, LHName))]++-- | Looks the names in scope with the given symbol.+-- Returns a list of close but different symbols or a non empty list+-- with the matched names.+lookupInScopeNonReflectedEnv+  :: InScopeNonReflectedEnv -> Symbol -> Either [Symbol] [(GHC.Module, LHName)]+lookupInScopeNonReflectedEnv env s = do+    let n = LH.dropModuleNames s+    case lookupSEnvWithDistance n env of+      Alts closeSyms -> Left closeSyms+      F.Found xs -> do+         let q = LH.takeModuleNames s+         case filter ((GHC.mkFastString (symbolString q) ==) . GHC.moduleNameFS . fst) xs of+           [] -> Left $ map (maybeQualifySymbol n . symbol . GHC.moduleNameString . fst) xs+           ys -> Right $ map snd ys+  where+    maybeQualifySymbol n m =+      if m == "" then n else LH.qualifySymbol m n++-- | Builds an environment of non-reflected names in scope from the module+-- aliases for the current module, the spec of the current module, and the specs+-- of the dependencies.+--+-- Also returns a LogicNameEnv constructed from the same names.+-- Also returns the names of reflected private functions.+-- Also returns the set of all names that aren't handled yet by name resolution.+makeLogicEnvs+  :: GHC.ImportedMods+  -> GHC.Module+  -> BareSpecParsed+  -> TargetDependencies+  -> ( InScopeNonReflectedEnv+     , LogicNameEnv+     , HS.HashSet LocSymbol+     , HS.HashSet Symbol+     )+makeLogicEnvs impAvails thisModule spec dependencies =+    let unqualify s =+          if s == LH.qualifySymbol (symbol $ GHC.moduleName thisModule) (LH.dropModuleNames s) then+            LH.dropModuleNames s+          else+            s++        -- Names should be removed from this list as they are supported+        -- by renaming.+        unhandledNames = HS.fromList $+          map unqualify unhandledNamesList ++ map (LH.qualifySymbol (symbol $ GHC.moduleName thisModule)) unhandledNamesList+        unhandledNamesList =+          map (rtName . val) (ealiases spec)+          ++ concatMap (map getLHNameSymbol . snd) unhandledLogicNames+        unhandledLogicNames =+          map (fmap collectUnhandledLiftedSpecLogicNames) dependencyPairs+        logicNames =+          (thisModule, thisModuleNames) :+          map (fmap collectLiftedSpecLogicNames) dependencyPairs+          ++ unhandledLogicNames+        thisModuleNames = concat+          [ [ reflectLHName thisModule (val n)+            | n <- concat+              [ map fst (asmReflectSigs spec)+              , HS.toList (reflects spec)+              , HS.toList (opaqueReflects spec)+              , HS.toList (inlines spec)+              , HS.toList (hmeas spec)+              ]+            ]+          , [ val (msName m) | m <- measures spec ]+          , [ val (msName m) | m <- cmeasures spec ]+          , map fst $+             concatMap DataDecl.dcFields $ concat $+             mapMaybe DataDecl.tycDCons $+             dataDecls spec+          ]+        privateReflectNames =+          mconcat $+            privateReflects spec : map (liftedPrivateReflects . snd) dependencyPairs+     in+        ( unionAliasEnvs $ map mkAliasEnv logicNames+        , mkLogicNameEnv (concatMap snd logicNames)+        , privateReflectNames+        , unhandledNames+        )+  where+    dependencyPairs = map (first GHC.unStableModule) $ HM.toList $ getDependencies dependencies++    mkAliasEnv (m, lhnames) =+      let aliases = moduleAliases m+       in fromListSEnv+            [ (s, map (,(m, lhname)) aliases)+              -- Note that only non-reflected names go to the InScope environment.+              -- See the local function resolveVarName for more details.+            | lhname@(LHNResolved (LHRLogic (LogicName s _ Nothing)) _) <- lhnames+            ]++    unionAliasEnvs :: [InScopeNonReflectedEnv] -> InScopeNonReflectedEnv+    unionAliasEnvs =+      coerce .+      HM.map (nubBy (\(alias1, (_, n1)) (alias2, (_, n2)) -> alias1 == alias2 && n1 == n2)) .+      foldl' (HM.unionWith (++)) HM.empty .+      coerce @_ @[HM.HashMap Symbol [(GHC.ModuleName, (GHC.Module, LHName))]]++    moduleAliases m =+      case GHC.lookupModuleEnv impAvails m of+        Just impBys -> concatMap imvAliases $ GHC.importedByUser impBys+        Nothing+          | thisModule == m ->+            -- Aliases for the current module+            [GHC.moduleName m, GHC.mkModuleName ""]+          | otherwise ->+            -- Use the aliases of the unsuffixed module+            concatMap imvAliases $ GHC.importedByUser $+              concat $ maybeToList $ do+                pString <- dropLHAssumptionsSuffix m+                pMod <- findDependency pString+                GHC.lookupModuleEnv impAvails pMod++    dropLHAssumptionsSuffix m =+      let mString = GHC.moduleNameString (GHC.moduleName m)+          sfx = "_LHAssumptions"+       in if isSuffixOf sfx mString then+            Just $ dropEnd (length sfx) mString+          else+            Nothing++    findDependency ms =+      find ((ms ==) . GHC.moduleNameString . GHC.moduleName) $+      GHC.moduleEnvKeys impAvails++    imvAliases imv+      | GHC.imv_qualified imv = [GHC.imv_name imv]+      | otherwise = [GHC.imv_name imv, GHC.mkModuleName ""]++    mkLogicNameEnv names =+      LogicNameEnv+        { lneLHName = fromListSEnv [ (lhNameToResolvedSymbol n, n) | n <- names ]+        , lneReflected = GHC.mkNameEnv [(rn, n) | n <- names, Just rn <- [maybeReflectedLHName n]]+        }++{- HLINT ignore collectUnhandledLiftedSpecLogicNames "Use ++" -}+collectUnhandledLiftedSpecLogicNames :: LiftedSpec -> [LHName]+collectUnhandledLiftedSpecLogicNames sp =+    map (makeLocalLHName . LH.dropModuleNames . rtName . val) $ HS.toList $ liftedEaliases sp++collectLiftedSpecLogicNames :: LiftedSpec -> [LHName]+collectLiftedSpecLogicNames sp = concat+    [ map fst (HS.toList $ liftedExpSigs sp)+    , map (val . msName) (HM.elems $ liftedMeasures sp)+    , map (val . msName) (HM.elems $ liftedCmeasures sp)+    , map fst $ concatMap DataDecl.dcFields $ concat $+        mapMaybe DataDecl.tycDCons $+        HS.toList $ liftedDataDecls sp+    ]++-- | Resolves names in the logic namespace+--+-- Returns the renamed spec.+-- Adds in the monadic state the errors about ambiguous or missing names, and+-- the names of data constructors that are found during renaming.+resolveLogicNames+  :: Config+  -> InScopeNonReflectedEnv+  -> GHC.GlobalRdrEnv+  -> HS.HashSet Symbol+  -> LogicMap+  -> LocalVars+  -> LogicNameEnv+  -> HS.HashSet LocSymbol+  -> HS.HashSet Symbol+  -> BareSpecParsed+  -> State RenameOutput BareSpecLHName+resolveLogicNames cfg env globalRdrEnv unhandledNames lmap0 localVars lnameEnv privateReflectNames allEaliases sp = do+    -- Instance measures must be defined for names of class measures.+    -- The names of class measures should be in @env@+    imeasures <- mapM (mapMeasureNamesM resolveIMeasLogicName) (imeasures sp)+    emapSpecM+      (bscope cfg)+      (map localVarToSymbol . maybe [] lvdLclEnv . (GHC.lookupNameEnv (lvNames localVars) <=< getLHGHCName))+      resolveLogicName+      (emapBareTypeVM (bscope cfg) resolveLogicName)+      sp {imeasures}+  where+    resolveIMeasLogicName lx =+      case val lx of+        LHNUnresolved LHLogicName s -> (<$ lx) <$> resolveLogicName [] (s <$ lx)+        _ -> panic (Just $ LH.fSrcSpan lx) $ "unexpected name: " ++ show lx++    localVarToSymbol = F.symbol . GHC.occNameString . GHC.nameOccName . GHC.varName++    resolveLogicName :: [Symbol] -> LocSymbol -> State RenameOutput LHName+    resolveLogicName ss ls+        -- The name is local+      | elem s ss = return $ makeLocalLHName s+      | otherwise =+        case lookupInScopeNonReflectedEnv env s of+          Left alts ->+            -- If names are not in the environment, they must be data constructors,+            -- or they must be reflected functions, or they must be in the logicmap.+            case resolveDataConName ls `mplus` resolveVarName lmap0 ls of+              Just m -> m+              Nothing+                | elem s wiredInNames ->+                  return $ makeLocalLHName s+                | otherwise -> do+                  unless (HS.member s unhandledNames) $+                    addError (errResolveLogicName ls alts)+                  return $ makeLocalLHName s+          Right [(_, lhname)] ->+            return lhname+          Right names -> do+            addError $+              ErrDupNames+                (LH.fSrcSpan ls)+                (pprint s)+                [ pprint (lhNameToResolvedSymbol n) PJ.<+>+                  PJ.text+                    ("imported from " ++ GHC.moduleNameString (GHC.moduleName m))+                | (m, n) <- names+                ]+            return $ makeLocalLHName s+      where+        s = val ls+        wiredInNames =+           map fst wiredSortedSyms +++           map (lhNameToResolvedSymbol . fst) (concatMap (DataDecl.dcpTyArgs . val) wiredDataCons)++    errResolveLogicName s alts =+      ErrResolve+        (LH.fSrcSpan s)+        (PJ.text "logic name")+        (pprint $ val s)+        (if null alts then+           PJ.text "Cannot resolve name"+         else+           PJ.text "Cannot resolve name" PJ.$$+           PJ.sep (PJ.text "Maybe you meant one of:" : map pprint alts)+        )++    resolveDataConName ls+      | unqualifiedS == ":" = Just $+        return $ makeLogicLHName unqualifiedS (GHC.nameModule consDataConName) (Just consDataConName)+      | unqualifiedS == "[]" = Just $+        return $ makeLogicLHName unqualifiedS (GHC.nameModule nilDataConName) (Just nilDataConName)+      | Just arity <- isTupleDC (symbolText s) = Just $+          let dcName = tupleDataConName arity+           in return $ makeLogicLHName s (GHC.nameModule dcName) (Just dcName)+      where+        unqualifiedS = LH.dropModuleNames s+        nilDataConName = GHC.getName $ GHC.dataConWorkId GHC.nilDataCon+        consDataConName = GHC.getName $ GHC.dataConWorkId GHC.consDataCon+        tupleDataConName = GHC.getName . GHC.dataConWorkId . GHC.tupleDataCon GHC.Boxed+        s = val ls+        isTupleDC t+          | Text.isPrefixOf "(" t && Text.isSuffixOf ")" t &&+            Text.all (== ',') (Text.init $ Text.tail t)+          = Just $ Text.length t - 2+          | otherwise+          = Nothing+    resolveDataConName s =+      case GHC.lookupGRE globalRdrEnv (mkLookupGRE (LHDataConName LHAnyModuleNameF) $ val s) of+        [e] -> do+          let n = GHC.greName e+          Just $ do+            let lhName = makeLogicLHName (symbol $ GHC.getOccString n) (GHC.nameModule n) (Just n)+            addName lhName+            addDataConsName lhName+            return lhName+        [] ->+          Nothing+        es ->+          Just $ do+            addError+              (ErrDupNames+                 (LH.fSrcSpan s)+                 (pprint $ val s)+                 (map (PJ.text . GHC.showPprUnsafe) es)+              )+            return $ makeLocalLHName $ val s++    -- Resolves names of reflected functions or names in the logic map+    --+    -- Names of reflected functions are resolved here because, to be in scope,+    -- we ask the corresponding Haskell name to be in scope. In contrast, the+    -- @InScopeNonReflectedEnv@ indicates where the reflect annotations were+    -- imported from, but not where the Haskell names were imported from.+    resolveVarName lmap s = do+      let gres =+            GHC.lookupGRE globalRdrEnv $+            mkLookupGRE (LHVarName LHAnyModuleNameF) (val s)+          refls = mapMaybe (findReflection . GHC.greName) gres+      case refls of+        [lhName] -> Just $ return lhName+        _ | HS.member s privateReflectNames+          -> Just $ return $ makeLocalLHName (val s)+          | otherwise+          -> case gres of+          [e] -> do+            let n = GHC.greName e+            -- TODO: The check for allEaliases should be redundant when+            -- ealiases are put in the logic environments+            if HM.member (symbol n) (lmSymDefs lmap) || HS.member (symbol n) allEaliases then+              Just $ do+                let lhName = makeLogicLHName (symbol $ GHC.getOccString n) (GHC.nameModule n) Nothing+                addName lhName+                return lhName+            else+              Nothing+          [] ->+            Nothing+          es ->+            Just $ do+              addError+                 (ErrDupNames+                   (LH.fSrcSpan s)+                   (pprint $ val s)+                   (map (PJ.text . GHC.showPprUnsafe) es)+                 )+              return $ makeLocalLHName $ val s++    findReflection :: GHC.Name -> Maybe LHName+    findReflection n = GHC.lookupNameEnv (lneReflected lnameEnv) n++mapMeasureNamesM :: Monad m => (Located LHName -> m (Located LHName)) -> MeasureV v ty ctor -> m (MeasureV v ty ctor)+mapMeasureNamesM f m = do+    msName <- f (msName m)+    msEqns <- mapM mapDefNameM (msEqns m)+    return m {msName, msEqns}+  where+    mapDefNameM d = do+      measure <- f (measure d)+      return d {measure}++mapDataDeclFieldNamesM :: Monad m => (LHName -> m LHName) -> DataDecl.DataDeclP v ty -> m (DataDecl.DataDeclP v ty)+mapDataDeclFieldNamesM f d = do+    tycDCons <- traverse (mapM (mapDataCtorFieldsM f)) (DataDecl.tycDCons d)+    return d{DataDecl.tycDCons}+  where+    mapDataCtorFieldsM :: Monad m => (LHName -> m LHName) -> DataDecl.DataCtorP ty -> m (DataDecl.DataCtorP ty)+    mapDataCtorFieldsM f1 c = do+      dcFields <- mapM (\(n, t) -> (, t) <$> f1 n) (DataDecl.dcFields c)+      return c{DataDecl.dcFields}++toBareSpecLHName :: Config -> LogicNameEnv -> BareSpec -> BareSpecLHName+toBareSpecLHName cfg env sp0 = runIdentity $ go sp0+  where+    -- This is implemented with a monadic traversal to reuse the logic+    -- that collects the local symbols in scope.+    go :: BareSpec -> Identity BareSpecLHName+    go sp =+      emapSpecM+        (bscope cfg)+        (const [])+        symbolToLHName+        (emapBareTypeVM (bscope cfg) symbolToLHName)+        sp++    unhandledNames = HS.fromList $ map fst $ expSigs sp0++    symbolToLHName :: [Symbol] -> Symbol -> Identity LHName+    symbolToLHName ss s+      | elem s ss = return $ makeLocalLHName s+      | otherwise =+        case lookupSEnv s (lneLHName env) of+          Nothing -> do+            unless (HS.member s unhandledNames) $+              panic Nothing $ "toBareSpecLHName: cannot find " ++ show s+            return $ makeLocalLHName s+          Just lhname -> return lhname
− src/Language/Haskell/Liquid/LawInstances.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Language.Haskell.Liquid.LawInstances ( checkLawInstances ) where--import qualified Data.List                                  as L-import qualified Data.Maybe                                 as Mb-import           Text.PrettyPrint.HughesPJ                  hiding ((<>))--import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Types.Equality-import           Liquid.GHC.API            hiding ((<+>), text)-import qualified Language.Fixpoint.Types                    as F--checkLawInstances :: GhcSpecLaws -> Diagnostics-checkLawInstances speclaws = foldMap go (gsLawInst speclaws)-  where go l = checkOneInstance (lilName l) (Mb.fromMaybe [] $ L.lookup (lilName l) (gsLawDefs speclaws)) l--checkOneInstance :: Class -> [(Var, LocSpecType)] -> LawInstance -> Diagnostics-checkOneInstance c laws li-  = checkExtra c li ((fst <$> laws) ++ classMethods c) (lilEqus li) <> foldMap (\l -> checkOneLaw c l li) laws--checkExtra :: Class-           -> LawInstance-           -> [Var]-           -> [(VarOrLocSymbol, (VarOrLocSymbol, Maybe LocSpecType))]-           -> Diagnostics-checkExtra c li _laws insts =-    let allMsgs = {- (msgExtra <$> extra) ++ -} (msgUnfoundLaw <$> unfoundLaws) ++ (msgUnfoundInstance <$> unfoundInstances)-    in mkDiagnostics mempty (mkError <$> allMsgs)-    where-        unfoundInstances = [ x | (_, (Right x,_)) <- insts]-        unfoundLaws = [ x | (Right x, _) <- insts]-        _extra = [] -- this breaks on extra super requirements [ (x,i) | (Left x, (Left i, _)) <- insts, not (x `L.elem` laws)] -        mkError = ErrILaw (lilPos li) (pprint c) (pprint $ lilTyArgs li)-        _msgExtra (x,_)      = pprint x <+> text "is not a defined law."-        msgUnfoundLaw i      = pprint i <+> text "is not a defined law."-        msgUnfoundInstance i = pprint i <+> text "is not a defined instance."--checkOneLaw :: Class -> (Var, LocSpecType) -> LawInstance -> Diagnostics-checkOneLaw c (x, t) li-  | Just (Left _, Just ti) <- lix-  = unify mkError c li t ti-  | Just (Right _l, _) <- lix-  = mkDiagnostics mempty [mkError (text "is not found.")]-  | otherwise-  = mkDiagnostics mempty [mkError (text "is not defined.")]-  where-    lix = L.lookup (Left x) (lilEqus li)-    mkError txt = ErrILaw (lilPos li) (pprint c) (pprintXs $ lilTyArgs li)-                          (text "The instance for the law" <+> pprint x <+> txt)-    pprintXs [l] = pprint l-    pprintXs xs  = pprint xs--unify :: (Doc -> Error) -> Class -> LawInstance -> LocSpecType -> LocSpecType -> Diagnostics-unify mkError c li t1 t2-  = if t11 =*= t22 then emptyDiagnostics else err-  where-    err = mkDiagnostics mempty [mkError (text "is invalid:\nType" <+> pprint t1 <+> text "\nis different than\n" <+> pprint t2-       --  text "\nesubt1 = " <+> pprint esubst1  -       -- text "\nesubt = " <+> pprint esubst  -       -- text "\ncompared\n" <+> pprint t11 <+> text "\nWITH\n" <+> pprint t22 -           )]--    t22 = fromRTypeRep (trep2 {ty_vars = [], ty_binds = fst <$> args2, ty_args = snd <$> args2, ty_refts = drop (length tc2) (ty_refts trep2)})-    t11 = fromRTypeRep (trep1 { ty_vars = []-                              , ty_binds = fst <$> args2-                              , ty_args = tx . snd <$> args1-                              , ty_refts = F.subst esubst <$> drop (length tc1) (ty_refts trep1)-                              , ty_res = tx $ ty_res trep1})-    tx = subtsSpec tsubst . F.subst esubst-    subtsSpec = subts :: ([(TyVar, Type)] -> SpecType -> SpecType)--    trep1 = toRTypeRep $ val t1 -    trep2 = toRTypeRep $ val t2 -    (tc1, args1) = splitTypeConstraints $ zip (ty_binds trep1) (ty_args trep1)-    (tc2, args2) = splitTypeConstraints $ zip (ty_binds trep2) (ty_args trep2)-    esubst = F.mkSubst (esubst1-                 ++  [(F.symbol x, F.EVar (F.symbol y)) | (Left x, (Left y, _)) <- lilEqus li]-                     )-    esubst1 = zip  (fst <$> args1) (F.EVar . fst <$> args2)--    tsubst = reverse $ zip ((\(RTV v) -> v) <$> (findTyVars tc1 ++ (ty_var_value <$> concat argVars)))-                 (toType False <$> (argBds ++ ((`RVar` mempty) . ty_var_value <$> (fst <$> ty_vars trep2))))--    (argVars, argBds) = unzip (splitForall [] . val <$> lilTyArgs li)--    splitForall vs (RAllT v t _) = splitForall (v:vs) t -    splitForall vs  t            = (vs, t) --    findTyVars (((_x, RApp cc as _ _):_ts)) | rtc_tc cc == classTyCon c -      = [v | RVar v _ <- as ]-    findTyVars (_:ts) = findTyVars ts -    findTyVars [] = [] ---splitTypeConstraints :: [(F.Symbol, SpecType)] -> ([(F.Symbol, SpecType)], [(F.Symbol, SpecType)])-splitTypeConstraints = go []  -  where  -    go cs (b@(_x, RApp c _ _ _):ts) -      | isClass c-      = go (b:cs) ts -    go cs r = (reverse cs, map (\(x, t) -> (x, shiftVV t x)) r)
src/Language/Haskell/Liquid/Liquid.hs view
@@ -11,18 +11,22 @@ import           Data.Bifunctor import qualified Data.HashSet as S  import           Text.PrettyPrint.HughesPJ-import           System.Console.CmdArgs.Verbosity (whenLoud, whenNormal)-import           Control.Monad (when, unless)+import           Control.Monad (when) import qualified Data.Maybe as Mb import qualified Data.List  as L  import qualified Language.Haskell.Liquid.UX.DiffCheck as DC import           Language.Haskell.Liquid.Misc-import           Language.Fixpoint.Misc+import qualified Language.Fixpoint.Misc as F import           Language.Fixpoint.Solver import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Visitors import           Language.Haskell.Liquid.UX.Errors import           Language.Haskell.Liquid.UX.CmdLine+import           Language.Haskell.Liquid.UX.Config import           Language.Haskell.Liquid.UX.Tidy import           Language.Haskell.Liquid.GHC.Misc (showCBs, ignoreCoreBinds) -- howPpr) import           Language.Haskell.Liquid.Constraint.Generate@@ -38,7 +42,7 @@ -------------------------------------------------------------------------------- checkTargetInfo info = do   out <- check-  unless (compileSpec cfg) $ DC.saveResult tgt out+  when (diffcheck cfg && not (compileSpec cfg)) $ DC.saveResult tgt out   pure out   where     check :: IO (Output Doc)@@ -47,16 +51,13 @@         -- donePhase Loud "Only compiling specifications [skipping verification]"         pure mempty { o_result = F.Safe mempty }       | otherwise = do-        whenNormal $ donePhase Loud "Extracted Core using GHC"-        -- whenLoud  $ do putStrLn $ showpp info-                     -- putStrLn "*************** Original CoreBinds ***************************"-                     -- putStrLn $ render $ pprintCBs (cbs info)-        whenNormal $ donePhase Loud "Transformed Core"-        whenLoud  $ do donePhase Loud "transformRecExpr-1773-hoho"-                       putStrLn "*************** Transform Rec Expr CoreBinds *****************"-                       putStrLn $ showCBs (untidyCore cfg) cbs'-                       -- putStrLn $ render $ pprintCBs cbs'-                       -- putStrLn $ showPpr cbs'+        when (loggingVerbosity cfg == Normal) $ do+          F.donePhase F.Loud "Extracted Core using GHC"+          F.donePhase F.Loud "Transformed Core"+        when (loggingVerbosity cfg == Loud) $ do+          F.donePhase F.Loud "transformRecExpr-1773-hoho"+          putStrLn "*************** Transform Rec Expr CoreBinds *****************"+          putStrLn $ showCBs (untidyCore cfg) cbs'         edcs <- newPrune cfg cbs' tgt info         liquidQueries cfg tgt info edcs
src/Language/Haskell/Liquid/Measure.hs view
@@ -31,42 +31,50 @@ import qualified Data.HashMap.Strict                    as M import qualified Data.List                              as L import qualified Data.Maybe                             as Mb -- (fromMaybe, isNothing)+import GHC.Stack  import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types                hiding (panic, R, DataDecl, SrcSpan, LocSymbol)+import           Language.Fixpoint.Types                as F hiding (panic, R, DataDecl, SrcSpan, LocSymbol) import           Liquid.GHC.API        as Ghc hiding (Expr, showPpr, panic, (<+>)) import           Language.Haskell.Liquid.GHC.Misc--- import qualified Language.Haskell.Liquid.Misc as Misc-import           Language.Haskell.Liquid.Types.Types    -- hiding (GhcInfo(..), GhcSpec (..))+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.RefType -- import           Language.Haskell.Liquid.Types.Variance -- import           Language.Haskell.Liquid.Types.Bounds-import           Language.Haskell.Liquid.Types.Specs hiding (BareSpec)+import           Language.Haskell.Liquid.Types.Specs import           Language.Haskell.Liquid.UX.Tidy --- /FIXME/: This needs to be removed once the port to the new API is complete.-type BareSpec = Spec LocBareType LocSymbol -mkM ::  LocSymbol -> ty -> [Def ty bndr] -> MeasureKind -> UnSortedExprs -> Measure ty bndr+mkM :: HasCallStack => F.Located LHName -> ty -> [DefV v ty bndr] -> MeasureKind -> UnSortedExprs -> MeasureV v ty bndr mkM name typ eqns kind u   | all ((name ==) . measure) eqns   = M name typ eqns kind u   | otherwise   = panic Nothing $ "invalid measure definition for " ++ show name -mkMSpec' :: Symbolic ctor => [Measure ty ctor] -> MSpec ty ctor+mkMSpec' :: [Measure ty DataCon] -> MSpec ty DataCon mkMSpec' ms = MSpec cm mm M.empty []   where-    cm     = groupMap (symbol . ctor) $ concatMap msEqns ms+    cm     = groupMap (makeGHCLHNameFromId . dataConWorkId . ctor) $ concatMap msEqns ms     mm     = M.fromList [(msName m, m) | m <- ms ] -mkMSpec :: [Measure t LocSymbol] -> [Measure t ()] -> [Measure t LocSymbol] -> MSpec t LocSymbol-mkMSpec ms cms ims = MSpec cm mm cmm ims+-- Note [Duplicate measures and opaque reflection]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Note that only ms are checked for duplicates! `oms` are the opaque reflections, they are automatically generated+-- so we don't care about duplicates (any two opaque-reflection measures with the same name will refer to the same thing,+-- since their names are fully qualified). Whence the need for a separate field for opaque reflections vs usual measures.+mkMSpec :: [Measure t (F.Located LHName)] -> [Measure t ()] -> [Measure t (F.Located LHName)] -> [Measure t (F.Located LHName)] -> MSpec t (F.Located LHName)+mkMSpec ms cms ims oms = MSpec cm mm cmm ims   where     cm     = groupMap (val . ctor) $ concatMap msEqns (ms'++ims)     mm     = M.fromList [(msName m, m) | m <- ms' ]     cmm    = M.fromList [(msName m, m) | m <- cms ]-    ms'    = checkDuplicateMeasure ms+    ms'    = checkDuplicateMeasure ms ++ oms   checkDuplicateMeasure :: [Measure ty ctor] -> [Measure ty ctor]@@ -80,7 +88,7 @@       mkError m ms = ErrDupMeas (fSrcSpan m) (pprint (val m)) (fSrcSpan <$> ms)  -dataConTypes :: Bool -> MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)])+dataConTypes :: Bool -> MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(F.Located LHName, RRType Reft)]) dataConTypes allowTC  s = (ctorTys, measTys)   where     measTys     = [(msName m, msSort m) | m <- M.elems (measMap s) ++ imeas s]@@ -232,14 +240,15 @@  refineWithCtorBody :: Outputable a                    => a-                   -> LocSymbol+                   -> F.Located LHName                    -> Body                    -> RType c tv Reft                    -> RType c tv Reft refineWithCtorBody dc f body t =   case stripRTypeBase t of     Just (Reft (v, _)) ->-      strengthen t $ Reft (v, bodyPred (mkEApp f [eVar v]) body)+      strengthen t $+        Reft (v, bodyPred (eApps (EVar $ lhNameToResolvedSymbol $ val f) [eVar v]) body)     Nothing ->       panic Nothing $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc
src/Language/Haskell/Liquid/Misc.hs view
@@ -119,10 +119,6 @@ third4 :: (t, t1, t2, t3) -> t2 third4  (_,_,x,_) = x -mapSndM :: (Applicative m) => (b -> m c) -> (a, b) -> m (a, c)--- mapSndM f (x, y) = return . (x,) =<< f y-mapSndM f (x, y) = (x, ) <$> f y- firstM :: Functor f => (t -> f a) -> (t, t1) -> f (a, t1) firstM  f (a,b) = (,b) <$> f a @@ -202,6 +198,11 @@ zipWithDef f (x:xs) (y:ys) = f x y : zipWithDef f xs ys  +foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b+foldMapM f xs = foldr step return xs mempty+  where+    step x r z = f x >>= \y -> r $! z `mappend` y+ -------------------------------------------------------------------------------- -- Originally part of Fixpoint's Misc: --------------------------------------------------------------------------------@@ -211,9 +212,6 @@  mapFst3 :: (t -> t1) -> (t, t2, t3) -> (t1, t2, t3) mapFst3 f (x, y, z) = (f x, y, z)--mapSnd3 :: (t -> t2) -> (t1, t, t3) -> (t1, t2, t3)-mapSnd3 f (x, y, z) = (x, f y, z)  mapThd3 :: (t -> t3) -> (t1, t2, t) -> (t1, t2, t3) mapThd3 f (x, y, z) = (x, y, f z)
+ src/Language/Haskell/Liquid/Name/LogicNameEnv.hs view
@@ -0,0 +1,26 @@+module Language.Haskell.Liquid.Name.LogicNameEnv+  ( LogicNameEnv(..)+  , extendLogicNameEnv+  ) where++import qualified Liquid.GHC.API         as GHC+import           Language.Fixpoint.Types+import           Language.Haskell.Liquid.Types.Names+++-- | For every symbol tells the corresponding LHName and Sort+--+-- Symbols are expected to have been created by 'lhNameToResolvedSymbol'.+--+data LogicNameEnv = LogicNameEnv+       { lneLHName :: SEnv LHName+         -- | Haskell names that have a reflected counterpart+       , lneReflected :: GHC.NameEnv LHName+       }++extendLogicNameEnv :: LogicNameEnv -> [LHName] -> LogicNameEnv+extendLogicNameEnv env ns =+    env+      { lneLHName =+          foldr (uncurry insertSEnv) (lneLHName env) [ (lhNameToResolvedSymbol n, n) | n <- ns]+      }
src/Language/Haskell/Liquid/Parse.hs view
@@ -6,14 +6,13 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE ScopedTypeVariables       #-}+{-# OPTIONS_GHC -Wno-orphans           #-}  module Language.Haskell.Liquid.Parse   ( hsSpecificationP-  , specSpecificationP+  , parseSpecComments   , singleSpecP-  , BPspec-  , Pspec(..)-  , parseSymbolToLogic+  , BPspec (..)   , parseTest'   )   where@@ -21,6 +20,8 @@ import           Control.Arrow                          (second) import           Control.Monad import           Control.Monad.Identity+import           Data.Bifunctor                         (first)+import qualified Data.Char                              as Char import qualified Data.Foldable                          as F import           Data.String import           Data.Void@@ -33,38 +34,44 @@ import qualified Data.Maybe                             as Mb -- (isNothing, fromMaybe) import           Data.Char                              (isSpace, isAlphaNum) import           Data.List                              (partition)-import           GHC                                    (ModuleName, mkModuleName) import qualified Text.PrettyPrint.HughesPJ              as PJ import           Text.PrettyPrint.HughesPJ.Compat       ((<+>)) import           Language.Fixpoint.Types                hiding (panic, SVar, DDecl, DataDecl, DataCtor (..), Error, R, Predicate) import           Language.Haskell.Liquid.GHC.Misc       hiding (getSourcePos)-import           Language.Haskell.Liquid.Types--- import           Language.Haskell.Liquid.Types.Errors-import qualified Language.Fixpoint.Misc                 as Misc+import           Language.Haskell.Liquid.Types.Bounds+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.PredType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Variance import qualified Language.Haskell.Liquid.Misc           as Misc import qualified Language.Haskell.Liquid.Measure        as Measure-import           Language.Fixpoint.Parse                hiding (defineP, dataDeclP, refBindP, refP, refDefP, parseTest')+import           Language.Fixpoint.Parse                hiding (Parser, dataDeclP, refBindP, refP, refDefP, parseTest')+import qualified Liquid.GHC.API                         as GHC  import Control.Monad.State --- import Debug.Trace- -- * Top-level parsing API --- | Used to parse .hs and .lhs files (via ApiAnnotations).-hsSpecificationP :: ModuleName-                 -> [(SourcePos, String)]-                 -> [BPspec]-                 -> Either [Error] (ModName, Measure.BareSpec)-hsSpecificationP modName specComments specQuotes =+hsSpecificationP :: GHC.ModuleName -> [BPspec] -> (ModName, BareSpecParsed)+hsSpecificationP modName specs = (ModName SrcImport modName, mkSpec specs)++-- | Parse comments in .hs and .lhs files+parseSpecComments :: [(SourcePos, String)] -> Either [Error] [BPspec]+parseSpecComments specComments =   case go ([], []) initPStateWithList specComments of     ([], specs) ->-      Right $ mkSpec (ModName SrcImport modName) (specs ++ specQuotes)+      Right specs     (errors, _) ->       Left errors   where     go :: ([Error], [BPspec])   -- accumulated errors and parsed specs (in reverse order)-       -> PState                -- parser state (primarily infix operator priorities)+       -> LHPState              -- parser state (primarily infix operator priorities)        -> [(SourcePos, String)] -- remaining unparsed spec comments        -> ([Error], [BPspec])   -- final errors and parsed specs     go (errors, specs) _ []@@ -76,34 +83,24 @@           Left err'       -> go (parseErrorBundleToErrors err' ++ errors, specs) pstate xs           Right (st,spec) -> go (errors,spec ++ specs) st xs -initPStateWithList :: PState+type LHPState = PStateV LocSymbol+type Parser = ParserV LocSymbol++instance ParseableV LocSymbol where+  parseV = locSymbolP+  mkSu = Su . M.fromList . reverse . filter notTrivial+    where+      notTrivial (x, EVar y) = x /= val y+      notTrivial _           = True+  vFromString = fmap symbol++initPStateWithList :: LHPState initPStateWithList   = (initPState composeFun)-               { empList    = Just (EVar ("GHC.Types.[]" :: Symbol))-               , singList   = Just (\e -> EApp (EApp (EVar ("GHC.Types.:"  :: Symbol)) e) (EVar ("GHC.Types.[]" :: Symbol)))+               { empList    = Just $ \lx -> EVar ("GHC.Types.[]" <$ lx)+               , singList   = Just (\lx e -> EApp (EApp (EVar ("GHC.Types.:" <$ lx)) e) (EVar ("GHC.Types.[]" <$ lx)))                }-  where composeFun = Just $ EVar functionComposisionSymbol---- | Used to parse .spec files.-specSpecificationP  :: SourceName -> String -> Either (ParseErrorBundle String Void) (ModName, Measure.BareSpec)----------------------------------------------------------------------------specSpecificationP f s = mapRight snd $  parseWithError initPStateWithList (specificationP <* eof) (initialPos f) s---- | Parses a module spec.------ A module spec is a module only containing spec constructs for Liquid Haskell,--- and no "normal" Haskell code.----specificationP :: Parser (ModName, Measure.BareSpec)-specificationP = do-  reserved "module"-  reserved "spec"-  name   <- symbolP-  reserved "where"-  xs     <- block specP-  return $ mkSpec (ModName SpecImport $ mkModuleName $ symbolString name) xs---- debugP = grabs (specP <* whiteSpace)+  where composeFun = Nothing  ------------------------------------------------------------------------------- singleSpecP :: SourcePos -> String -> Either (ParseErrorBundle String Void) BPspec@@ -139,7 +136,7 @@ -- start at different columns, and we do not want layout info to carry -- across different such comments. ---parseWithError :: forall a. PState -> Parser a -> SourcePos -> String -> Either (ParseErrorBundle String Void) (PState, a)+parseWithError :: forall a. LHPState -> Parser a -> SourcePos -> String -> Either (ParseErrorBundle String Void) (LHPState, a) parseWithError pstate parser p s =   case snd (runIdentity (runParserT' (runStateT doParse pstate{supply = 0, layoutStack = Empty}) internalParserState)) of     Left peb -> Left peb@@ -183,30 +180,6 @@     msg             = "Error Parsing Specification from:" <+> PJ.text (sourceName pos)  ----------------------------------------------------------------------------------- Parse to Logic  ------------------------------------------------------------------------------------------------------------------------------------------------parseSymbolToLogic :: SourceName -> String -> Either (ParseErrorBundle String Void) LogicMap-parseSymbolToLogic f = mapRight snd . parseWithError initPStateWithList toLogicP (initialPos f)--toLogicP :: Parser LogicMap-toLogicP-  = toLogicMap <$> many toLogicOneP--toLogicOneP :: Parser  (LocSymbol, [Symbol], Expr)-toLogicOneP-  = do reserved "define"-       (x:xs) <- some locSymbolP-       reservedOp "="-       e      <- exprP <|> predP-       return (x, val <$> xs, e)---defineP :: Parser (LocSymbol, Symbol)-defineP =-  (,) <$> locBinderP <* reservedOp "=" <*> binderP---------------------------------------------------------------------------------- -- | BareTypes ----------------------------------------------------------------- -------------------------------------------------------------------------------- @@ -232,15 +205,14 @@ -}  data ParamComp = PC { _pci :: PcScope-                    , _pct :: BareType }-                    deriving (Show)+                    , _pct :: BareTypeParsed }  data PcScope = PcImplicit Symbol              | PcExplicit Symbol              | PcNoSymbol              deriving (Eq,Show) -nullPC :: BareType -> ParamComp+nullPC :: BareTypeParsed -> ParamComp nullPC bt = PC PcNoSymbol bt  btP :: Parser ParamComp@@ -256,20 +228,26 @@       (do             reservedOp "->"             PC _ t2 <- btP-            return (PC sb (rFun sy t1 t2)))+            return (PC sb (mkRFun sy t1 t2)))         <|>          (do             reservedOp "=>"             PC _ t2 <- btP             -- TODO:AZ return an error if s == PcExplicit-            return $ PC sb $ foldr (rFun dummySymbol) t2 (getClasses t1))+            return $ PC sb $ foldr (mkRFun dummySymbol) t2 (getClasses t1))          <|>           (do              b <- locInfixSymbolP              PC _ t2 <- btP-             return $ PC sb $ RApp (mkBTyCon b) [t1,t2] [] mempty)+             return $ PC sb $ RApp+               (mkBTyCon $ fmap (makeUnresolvedLHName LHTcName) b)+               [t1,t2]+               []+               trueURef+          )          <|> return c +    mkRFun b t t' = RFun b defRFInfo t t' trueURef  compP :: Parser ParamComp compP = circleP <|> parens btP <?> "compP"@@ -290,7 +268,7 @@   = angles $ do       PC sb t <- parens btP       p       <- monoPredicateP-      return   $ PC sb (t `strengthen` MkUReft mempty p)+      return   $ PC sb (t `strengthenUReft` MkUReft trueReft p)  holePC :: Parser ParamComp holePC = do@@ -306,7 +284,7 @@      PC (PcExplicit b) <$> bareArgP b     <|> do       b <- dummyBindP-      PC (PcImplicit b) <$> dummyP (lowerIdTail (val lb))+      PC (PcImplicit b) <$> dummyP (lowerIdTail lb)  unnamedCircleP :: Parser ParamComp unnamedCircleP = do@@ -320,7 +298,7 @@ -- | The top-level parser for "bare" refinement types. If refinements are -- not supplied, then the default "top" refinement is used. -bareTypeP :: Parser BareType+bareTypeP :: Parser BareTypeParsed bareTypeP = do   PC _ v <- btP   return v@@ -357,7 +335,7 @@       return (Left $ nullPC t)  -bareArgP :: Symbol -> Parser BareType+bareArgP :: Symbol -> Parser BareTypeParsed bareArgP vvv   =  refDefP vvv refasHoleP bbaseP    -- starts with '{'  <|> holeP                            -- starts with '_'@@ -366,15 +344,16 @@                                       -- starts with '_', '[', '(', lower, upper  <?> "bareArgP" -bareAtomP :: (Parser Expr -> Parser (Reft -> BareType) -> Parser BareType)-          -> Parser BareType+bareAtomP+  :: (Parser (ExprV LocSymbol) -> Parser (ReftV LocSymbol -> BareTypeParsed) -> Parser BareTypeParsed)+  -> Parser BareTypeParsed bareAtomP ref   =  ref refasHoleP bbaseP  <|> holeP  <|> dummyP bbaseP  <?> "bareAtomP" -bareAtomBindP :: Parser BareType+bareAtomBindP :: Parser BareTypeParsed bareAtomBindP = bareAtomP refBindBindP  @@ -382,9 +361,9 @@ --  { x : t | ra } -- or --  { ra }-refBindBindP :: Parser Expr-             -> Parser (Reft -> BareType)-             -> Parser BareType+refBindBindP :: Parser (ExprV LocSymbol)+             -> Parser (ReftV LocSymbol -> BareTypeParsed)+             -> Parser BareTypeParsed refBindBindP rp kindP'   = braces (       (do@@ -405,9 +384,9 @@   refDefP :: Symbol-        -> Parser Expr-        -> Parser (Reft -> BareType)-        -> Parser BareType+        -> Parser (ExprV LocSymbol)+        -> Parser (ReftV LocSymbol -> BareTypeParsed)+        -> Parser BareTypeParsed refDefP sy rp kindP' = braces $ do   x       <- optBindP sy   -- NOSUBST i       <- freshIntP@@ -421,10 +400,10 @@        -- substa su . t . Reft . (x,) <$> (rp <* spaces))       --  <|> ((RHole . uTop . Reft . ("VV",)) <$> (rp <* spaces)) -refP :: Parser (Reft -> BareType) -> Parser BareType+refP :: Parser (ReftV LocSymbol -> BareTypeParsed) -> Parser BareTypeParsed refP = refBindBindP refaP -relrefaP :: Parser RelExpr+relrefaP :: Parser (RelExprV LocSymbol) relrefaP =   try (ERUnChecked <$> refaP <* reserved ":=>" <*> relrefaP)     <|> try (ERChecked <$> refaP <* reserved "!=>" <*> relrefaP)@@ -434,23 +413,23 @@ optBindP :: Symbol -> Parser Symbol optBindP x = try bindP <|> return x -holeP :: Parser BareType+holeP :: Parser BareTypeParsed holeP    = reserved "_" >> return (RHole $ uTop $ Reft ("VV", hole)) -holeRefP :: Parser (Reft -> BareType)+holeRefP :: Parser (ReftV v -> BareTypeV v) holeRefP = reserved "_" >> return (RHole . uTop)  -- NOPROP refasHoleP :: Parser Expr -- NOPROP refasHoleP  = try refaP -- NOPROP          <|> (reserved "_" >> return hole) -refasHoleP :: Parser Expr+refasHoleP :: Parser (ExprV LocSymbol) refasHoleP   =  (reserved "_" >> return hole)  <|> refaP  <?> "refasHoleP" -bbaseP :: Parser (Reft -> BareType)+bbaseP :: Parser (ReftV LocSymbol -> BareTypeParsed) bbaseP   =  holeRefP  -- Starts with '_'  <|> liftM2 bLst (brackets (optional bareTypeP)) predicatesP@@ -461,7 +440,7 @@  <?> "bbaseP"  where    parseHelper = do-     l <- lowerIdP+     l <- located lowerIdP      lowerIdTail l  maybeBind :: Parser a -> Parser (Maybe Symbol, a)@@ -470,52 +449,57 @@     maybeP' p = try (Just <$> p)              <|> return Nothing -lowerIdTail :: Symbol -> Parser (Reft -> BareType)+lowerIdTail :: LocSymbol -> Parser (ReftV LocSymbol -> BareTypeParsed) lowerIdTail l =           fmap (bAppTy (bTyVar l)) (some bareTyArgP)       <|> fmap (bRVar (bTyVar l)) monoPredicateP  bTyConP :: Parser BTyCon bTyConP-  =  (reservedOp "'" >> (mkPromotedBTyCon <$> locUpperIdP))- <|> mkBTyCon <$> locUpperIdP- <|> (reserved "*" >> return (mkBTyCon (dummyLoc $ symbol ("*" :: String))))+  =  (reservedOp "'" >> mkPromotedBTyCon <$> locUpperIdLHNameP (LHDataConName LHAnyModuleNameF))+ <|> mkBTyCon <$> locUpperIdLHNameP LHTcName+ <|> (reserved "*" >>+        return (mkBTyCon (dummyLoc $ makeUnresolvedLHName LHTcName $ symbol ("*" :: String)))+     )  <?> "bTyConP" -mkPromotedBTyCon :: LocSymbol -> BTyCon+locUpperIdLHNameP :: LHNameSpace -> Parser (Located LHName)+locUpperIdLHNameP ns = fmap (makeUnresolvedLHName ns) <$> locUpperIdP++mkPromotedBTyCon :: Located LHName -> BTyCon mkPromotedBTyCon x = BTyCon x False True -- (consSym '\'' <$> x) False True  classBTyConP :: Parser BTyCon-classBTyConP = mkClassBTyCon <$> locUpperIdP+classBTyConP = mkClassBTyCon <$> locUpperIdLHNameP LHTcName -mkClassBTyCon :: LocSymbol -> BTyCon+mkClassBTyCon :: Located LHName -> BTyCon mkClassBTyCon x = BTyCon x True False -bbaseNoAppP :: Parser (Reft -> BareType)+bbaseNoAppP :: Parser (ReftV LocSymbol -> BareTypeParsed) bbaseNoAppP   =  holeRefP  <|> liftM2 bLst (brackets (optional bareTypeP)) predicatesP  <|> liftM2 bTup (parens $ sepBy (maybeBind bareTypeP) comma) predicatesP- <|> try (liftM4 bCon bTyConP predicatesP (return []) (return mempty))- <|> liftM2 bRVar (bTyVar <$> lowerIdP) monoPredicateP+ <|> try (liftM4 bCon bTyConP predicatesP (return []) (return $ Pr []))+ <|> liftM2 bRVar (bTyVar <$> located lowerIdP) monoPredicateP  <?> "bbaseNoAppP" -bareTyArgP :: Parser BareType+bareTyArgP :: Parser BareTypeParsed bareTyArgP-  =  (RExprArg . fmap expr <$> locNatural)+  =  (RExprArg . fmap (ECon . I) <$> locNatural)  <|> try (braces $ RExprArg <$> located exprP)  <|> try bareAtomNoAppP  <|> try (parens bareTypeP)  <?> "bareTyArgP" -bareAtomNoAppP :: Parser BareType+bareAtomNoAppP :: Parser BareTypeParsed bareAtomNoAppP   =  refP bbaseNoAppP  <|> dummyP bbaseNoAppP  <?> "bareAtomNoAppP"  -constraintP :: Parser BareType+constraintP :: Parser BareTypeParsed constraintP   = do xts <- constraintEnvP        t1  <- bareTypeP@@ -523,10 +507,13 @@        fromRTypeRep . RTypeRep [] []                                ((val . fst <$> xts) ++ [dummySymbol])                                (replicate (length xts + 1) defRFInfo)-                               (replicate (length xts + 1) mempty)+                               (replicate (length xts + 1) trueURef)                                ((snd <$> xts) ++ [t1]) <$> bareTypeP -constraintEnvP :: Parser [(LocSymbol, BareType)]+trueURef :: UReftV v (ReftV v)+trueURef = MkUReft trueReft (Pr [])++constraintEnvP :: Parser [(LocSymbol, BareTypeParsed)] constraintEnvP    =  try (do xts <- sepBy tyBindNoLocP comma               reservedOp "|-"@@ -534,8 +521,8 @@   <|> return []   <?> "constraintEnvP" -rrTy :: Monoid r => RType c tv r -> RType c tv r -> RType c tv r-rrTy ct = RRTy (xts ++ [(dummySymbol, tr)]) mempty OCons+rrTy :: BareTypeParsed -> BareTypeParsed -> BareTypeParsed+rrTy ct = RRTy (xts ++ [(dummySymbol, tr)]) trueURef OCons   where     tr   = ty_res trep     xts  = zip (ty_binds trep) (ty_args trep)@@ -544,7 +531,7 @@ --  "forall <z w> . TYPE" -- or --  "forall x y <z :: Nat, w :: Int> . TYPE"-bareAllP :: Parser BareType+bareAllP :: Parser BareTypeParsed bareAllP = do   sp <- getSourcePos   as  <- tyVarDefsP@@ -554,11 +541,11 @@   t <- bareTypeP   return $ foldr rAllT (foldr (rAllP sp) t ps) (makeRTVar <$> as)   where-    rAllT a t = RAllT a t mempty+    rAllT a t = RAllT a t trueURef     inAngles  = try  (sepBy  predVarDefP comma)  -- See #1907 for why we have to alpha-rename pvar binders-rAllP :: SourcePos -> PVar BSort -> BareType -> BareType+rAllP :: SourcePos -> PVarV LocSymbol (BSortV LocSymbol) -> BareTypeParsed -> BareTypeParsed rAllP sp p t = RAllP p' ({- F.tracepp "rAllP" $ -} substPVar p p' t)   where     p'  = p { pname = pn' }@@ -568,8 +555,8 @@  tyVarDefsP :: Parser [BTyVar] tyVarDefsP-  = parens (many (bTyVar <$> tyKindVarIdP))- <|> many (bTyVar <$> tyVarIdP)+  = parens (many (bTyVar <$> located tyKindVarIdP))+ <|> many (bTyVar <$> located tyVarIdP)  <?> "tyVarDefsP"  tyKindVarIdP :: Parser Symbol@@ -577,16 +564,16 @@    tv <- tyVarIdP    do reservedOp "::"; _ <- kindP; return tv <|> return tv -kindP :: Parser BareType+kindP :: Parser BareTypeParsed kindP = bareAtomBindP -predVarDefsP :: Parser [PVar BSort]+predVarDefsP :: Parser [PVarV LocSymbol (BSortV LocSymbol)] predVarDefsP   =  angles (sepBy1 predVarDefP comma)  <|> return []  <?> "predVarDefP" -predVarDefP :: Parser (PVar BSort)+predVarDefP :: Parser (PVarV LocSymbol (BSortV LocSymbol)) predVarDefP   = bPVar <$> predVarIdP <*> reservedOp "::" <*> propositionSortP @@ -594,28 +581,28 @@ predVarIdP   = symbol <$> tyVarIdP -bPVar :: Symbol -> t -> [(Symbol, t1)] -> PVar t1-bPVar p _ xts  = PV p (PVProp τ) dummySymbol τxs+bPVar :: Symbol -> t -> [(Symbol, t1)] -> PVarV LocSymbol t1+bPVar p _ xts  = PV p τ dummySymbol τxs   where     (_, τ) = safeLast "bPVar last" xts-    τxs    = [ (τ', x, EVar x) | (x, τ') <- init xts ]+    τxs    = [ (τ', x, EVar (dummyLoc x)) | (x, τ') <- init xts ]     safeLast _ xs@(_:_) = last xs     safeLast msg _      = panic Nothing $ "safeLast with empty list " ++ msg -propositionSortP :: Parser [(Symbol, BSort)]-propositionSortP = map (Misc.mapSnd toRSort) <$> propositionTypeP+propositionSortP :: Parser [(Symbol, BSortV LocSymbol)]+propositionSortP = map (fmap toRSort) <$> propositionTypeP -propositionTypeP :: Parser [(Symbol, BareType)]+propositionTypeP :: Parser [(Symbol, BareTypeParsed)] propositionTypeP = either fail return . mkPropositionType =<< bareTypeP -mkPropositionType :: BareType -> Either String [(Symbol, BareType)]+mkPropositionType :: BareTypeParsed -> Either String [(Symbol, BareTypeParsed)] mkPropositionType t   | isOk      = Right $ zip (ty_binds tRep) (ty_args tRep)   | otherwise = Left mkErr   where     isOk      = isPropBareType (ty_res tRep)     tRep      = toRTypeRep t-    mkErr     = "Proposition type with non-Bool output: " ++ showpp t+    mkErr     = "Proposition type with non-Bool output: " ++ showpp (parsedToBareType t)  xyP :: Parser x -> Parser a -> Parser y -> Parser (x, y) xyP lP sepP rP =@@ -624,14 +611,14 @@ dummyBindP :: Parser Symbol dummyBindP = tempSymbol "db" <$> freshIntP -isPropBareType :: RType BTyCon t t1 -> Bool-isPropBareType  = isPrimBareType boolConName--isPrimBareType :: Symbol -> RType BTyCon t t1 -> Bool-isPrimBareType n (RApp tc [] _ _) = val (btc_tc tc) == n-isPrimBareType _ _                = False+isPropBareType :: RTypeV v BTyCon t t1 -> Bool+isPropBareType (RApp tc [] _ _) =+    case val (btc_tc tc) of+      LHNUnresolved _ s -> s == boolConName+      _ -> False+isPropBareType _ = False -getClasses :: RType BTyCon t t1 -> [RType BTyCon t t1]+getClasses :: RTypeV v BTyCon t t1 -> [RTypeV v BTyCon t t1] getClasses (RApp tc ts ps r)   | isTuple tc   = concatMap getClasses ts@@ -640,12 +627,12 @@ getClasses t   = [t] -dummyP ::  Monad m => m (Reft -> b) -> m b+dummyP ::  Monad m => m (ReftV LocSymbol -> b) -> m b dummyP fm-  = fm `ap` return dummyReft+  = fm `ap` return trueReft -symsP :: (IsString tv, Monoid r)-      => Parser [(Symbol, RType c tv r)]+symsP :: Monoid r+      => Parser [(Symbol, RTypeV v c BTyVar r)] symsP   = do reservedOp "\\"        ss <- many symbolP@@ -654,19 +641,19 @@  <|> return []  <?> "symsP" -dummyRSort :: (IsString tv, Monoid r) => RType c tv r+dummyRSort :: Monoid r => RTypeV v c BTyVar r dummyRSort-  = RVar "dummy" mempty+  = RVar (BTV "dummy") mempty -predicatesP :: (IsString tv, Monoid r)-            => Parser [Ref (RType c tv r) BareType]+predicatesP :: Monoid r+            => Parser [Ref (RTypeV LocSymbol c BTyVar r) BareTypeParsed] predicatesP    =  angles (sepBy1 predicate1P comma)   <|> return []   <?> "predicatesP" -predicate1P :: (IsString tv, Monoid r)-            => Parser (Ref (RType c tv r) BareType)+predicate1P :: Monoid r+            => Parser (Ref (RTypeV LocSymbol c BTyVar r) BareTypeParsed) predicate1P    =  try (RProp <$> symsP <*> refP bbaseP)   <|> (rPropP [] . predUReft <$> monoPredicate1P)@@ -678,38 +665,38 @@                       return $ zip ss fs     refreshSym s = intSymbol s <$> freshIntP -mmonoPredicateP :: Parser Predicate+mmonoPredicateP :: Parser (PredicateV LocSymbol) mmonoPredicateP    = try (angles $ angles monoPredicate1P)-  <|> return mempty+  <|> return (Pr [])   <?> "mmonoPredicateP" -monoPredicateP :: Parser Predicate+monoPredicateP :: Parser (PredicateV LocSymbol) monoPredicateP    = try (angles monoPredicate1P)-  <|> return mempty+  <|> return (Pr [])   <?> "monoPredicateP" -monoPredicate1P :: Parser Predicate+monoPredicate1P :: Parser (PredicateV LocSymbol) monoPredicate1P-   =  (reserved "True" >> return mempty)+   =  (reserved "True" >> return (Pr []))   <|> (pdVar <$> parens predVarUseP)   <|> (pdVar <$>        predVarUseP)   <?> "monoPredicate1P" -predVarUseP :: Parser (PVar String)+predVarUseP :: Parser (PVarV LocSymbol String) predVarUseP   = do (p, xs) <- funArgsP-       return   $ PV p (PVProp dummyTyId) dummySymbol [ (dummyTyId, dummySymbol, x) | x <- xs ]+       return   $ PV p dummyTyId dummySymbol [ (dummyTyId, dummySymbol, x) | x <- xs ] -funArgsP :: Parser (Symbol, [Expr])+funArgsP :: Parser (Symbol, [ExprV LocSymbol]) funArgsP  = try realP <|> empP <?> "funArgsP"   where     empP  = (,[]) <$> predVarIdP     realP = do (EVar lp, xs) <- splitEApp <$> funAppP-               return (lp, xs)+               return (val lp, xs) -boundP :: Parser (Bound (Located BareType) Expr)+boundP :: Parser (Bound (Located BareTypeParsed) (ExprV LocSymbol)) boundP = do   name   <- locUpperIdP   reservedOp "="@@ -726,9 +713,11 @@            <|> return []            <?> "bargsP"     bvsP   =     ( do reserved "forall"-                      xs <- many (fmap bTyVar <$> locSymbolP)+                      xs <- many $ do+                        ls <- locSymbolP+                        pure $ bTyVar ls <$ ls                       reservedOp  "."-                      return (fmap (`RVar` mempty) <$> xs)+                      return (fmap (`RVar` trueURef) <$> xs)                  )            <|> return [] @@ -758,41 +747,52 @@ ------------------------------------------------------------------------  bRProp :: [((Symbol, τ), Symbol)]-       -> Expr -> Ref τ (RType c BTyVar (UReft Reft))+       -> ExprV LocSymbol -> Ref τ (RTypeV LocSymbol c BTyVar (UReftV LocSymbol (ReftV LocSymbol))) bRProp []    _    = panic Nothing "Parse.bRProp empty list"-bRProp syms' epr  = RProp ss $ bRVar (BTV dummyName) mempty r+bRProp syms' epr  = RProp ss $ bRVar (BTV $ dummyLoc dummyName) (Pr []) r   where     (ss, (v, _))  = (init symsf, last symsf)     symsf         = [(y, s) | ((_, s), y) <- syms']-    su            = mkSubst [(x, EVar y) | ((x, _), y) <- syms']-    r             = su `subst` Reft (v, epr)+    su            = mkSubstLocSymbol [(x, EVar $ dummyLoc y) | ((x, _), y) <- syms', x /= v]+    r             = Reft (v, substExprV val su epr) -bRVar :: tv -> Predicate -> r -> RType c tv (UReft r)+mkSubstLocSymbol :: [(Symbol, ExprV LocSymbol)] -> SubstV LocSymbol+mkSubstLocSymbol = Su . M.fromList . reverse . filter notTrivial+  where+    notTrivial (x, EVar y) = x /= val y+    notTrivial _           = True++bRVar :: tv -> PredicateV v -> r -> RTypeV v c tv (UReftV v r) bRVar α p r = RVar α (MkUReft r p) -bLst :: Maybe (RType BTyCon tv (UReft r))-     -> [RTProp BTyCon tv (UReft r)]+bLst :: Maybe (RTypeV v BTyCon tv (UReftV v r))+     -> [RTPropV v BTyCon tv (UReftV v r)]      -> r-     -> RType BTyCon tv (UReft r)-bLst (Just t) rs r = RApp (mkBTyCon $ dummyLoc listConName) [t] rs (reftUReft r)-bLst Nothing  rs r = RApp (mkBTyCon $ dummyLoc listConName) []  rs (reftUReft r)+     -> RTypeV v BTyCon tv (UReftV v r)+bLst (Just t) rs r = RApp (mkBTyCon $ dummyLoc $ makeUnresolvedLHName LHTcName listConName) [t] rs (reftUReft r)+bLst Nothing  rs r = RApp (mkBTyCon $ dummyLoc $ makeUnresolvedLHName LHTcName listConName) []  rs (reftUReft r) -bTup :: (PPrint r, Reftable r, Reftable (RType BTyCon BTyVar (UReft r)), Reftable (RTProp BTyCon BTyVar (UReft r)))-     => [(Maybe Symbol, RType BTyCon BTyVar (UReft r))]-     -> [RTProp BTyCon BTyVar (UReft r)]-     -> r-     -> RType BTyCon BTyVar (UReft r)+bTup :: [(Maybe Symbol, BareTypeParsed)]+     -> [RTPropV LocSymbol BTyCon BTyVar (UReftV LocSymbol (ReftV LocSymbol))]+     -> ReftV LocSymbol+     -> BareTypeParsed bTup [(_,t)] _ r-  | isTauto r  = t-  | otherwise  = t `strengthen` reftUReft r+  | isTauto (fmap val r)  = t+  | otherwise  = t `strengthenUReft` reftUReft r bTup ts rs r   | all Mb.isNothing (fst <$> ts) || length ts < 2-  = RApp (mkBTyCon $ dummyLoc tupConName) (snd <$> ts) rs (reftUReft r)+  = RApp+      (mkBTyCon $ dummyLoc $ makeUnresolvedLHName LHTcName $ fromString $ "Tuple" ++ show (length ts))+      (snd <$> ts) rs (reftUReft r)   | otherwise-  = RApp (mkBTyCon $ dummyLoc tupConName) (top . snd <$> ts) rs' (reftUReft r)+  = RApp+      (mkBTyCon $ dummyLoc $ makeUnresolvedLHName LHTcName $ fromString $ "Tuple" ++ show (length ts))+      (mapReft (const trueURef) . snd <$> ts)+      rs'+      (reftUReft r)   where     args       = [(Mb.fromMaybe dummySymbol x, mapReft mempty t) | (x,t) <- ts]-    makeProp i = RProp (take i args) ((snd <$> ts)!!i)+    makeProp i = RProp (reverse $ take i args) ((snd <$> ts)!!i)     rs'        = makeProp <$> [1..(length ts-1)]  @@ -801,127 +801,162 @@ -- TODO RApp Int [] [p] true should be syntactically different than RApp Int [] [] p -- bCon b s [RProp _ (RHole r1)] [] _ r = RApp b [] [] $ r1 `meet` (MkUReft r mempty s) bCon :: c-     -> [RTProp c tv (UReft r)]-     -> [RType c tv (UReft r)]-     -> Predicate+     -> [RTPropV v c tv (UReftV v r)]+     -> [RTypeV v c tv (UReftV v r)]+     -> PredicateV v      -> r-     -> RType c tv (UReft r)+     -> RTypeV v c tv (UReftV v r) bCon b rs ts p r = RApp b ts rs $ MkUReft r p -bAppTy :: (Foldable t, PPrint r, Reftable r)-       => tv -> t (RType c tv (UReft r)) -> r -> RType c tv (UReft r)-bAppTy v ts r  = ts' `strengthen` reftUReft r+bAppTy :: Foldable t => BTyVar -> t BareTypeParsed -> ReftV LocSymbol -> BareTypeParsed+bAppTy v ts r  = strengthenUReft ts' (reftUReft r)   where-    ts'        = foldl' (\a b -> RAppTy a b mempty) (RVar v mempty) ts+    ts'        = foldl' (\a b -> RAppTy a b (uTop trueReft)) (RVar v (uTop trueReft)) ts -reftUReft :: r -> UReft r-reftUReft r    = MkUReft r mempty+strengthenUReft+  :: BareTypeParsed -> UReftV LocSymbol (ReftV LocSymbol) -> BareTypeParsed+strengthenUReft = strengthenWith meetUReft+  where+    meetUReft (MkUReft r0 (Pr p0)) (MkUReft r1 (Pr p1)) =+       MkUReft (meetReftV r0 r1) (Pr $ p0 <> p1) -predUReft :: Monoid r => Predicate -> UReft r-predUReft p    = MkUReft dummyReft p+    meetReftV :: ReftV LocSymbol -> ReftV LocSymbol -> ReftV LocSymbol+    meetReftV (Reft (v, ra)) (Reft (v', ra'))+      | v == v'          = Reft (v , pAnd [ra, ra'])+      | v == dummySymbol = Reft (v', pAnd [ra', substExprV val (Su $ M.fromList [(v , EVar (dummyLoc v'))]) ra])+      | otherwise        = Reft (v , pAnd [ra, substExprV val (Su $ M.fromList [(v', EVar (dummyLoc v))]) ra']) -dummyReft :: Monoid a => a-dummyReft      = mempty+substExprV :: (v -> Symbol) -> SubstV v -> ExprV v -> ExprV v+substExprV toSym su0 = go+  where+    go (EApp f e) = EApp (go f) (go e)+    go (ELam x e) = ELam x (substExprV toSym (removeSubst su0 (fst x)) e)+    go (ECoerc a t e) = ECoerc a t (go e)+    go (ENeg e) = ENeg (go e)+    go (EBin op e1 e2) = EBin op (go e1) (go e2)+    go (EIte p e1 e2) = EIte (go p) (go e1) (go e2)+    go (ECst e so) = ECst (go e) so+    go (EVar x) = appSubst su0 x+    go (PAnd ps) = PAnd $ map go ps+    go (POr  ps) = POr $ map go ps+    go (PNot p) = PNot (go p)+    go (PImp p1 p2) = PImp (go p1) (go p2)+    go (PIff p1 p2) = PIff (go p1) (go p2)+    go (PAtom r e1 e2) = PAtom r (go e1) (go e2)+    go (PKVar k su') = PKVar k $ su' `appendSubst` su0+    go (PGrad k su' i e) = PGrad k (su' `appendSubst` su0) i (go e)+    go (PAll _ _) = panic Nothing "substExprV: PAll"+    go (PExist _ _) = panic Nothing "substExprV: PExist"+    go p = p -dummyTyId :: IsString a => a-dummyTyId      = ""+    appSubst (Su s) x = Mb.fromMaybe (EVar x) (M.lookup (toSym x) s) +    removeSubst (Su su) x = Su $ M.delete x su++    appendSubst (Su s1) θ2@(Su s2) = Su $ M.union s1' s2+      where+        s1' = substExprV toSym θ2 <$> s1+++reftUReft :: r -> UReftV v r+reftUReft r    = MkUReft r (Pr [])++predUReft :: PredicateV v -> UReftV v (ReftV v)+predUReft = MkUReft trueReft++dummyTyId :: String+dummyTyId = ""+ ------------------------------------------------------------------ --------------------------- Measures ----------------------------- ------------------------------------------------------------------ -type BPspec = Pspec LocBareType LocSymbol- -- | The AST for a single parsed spec.-data Pspec ty ctor-  = Meas    (Measure ty ctor)                             -- ^ 'measure' definition-  | Assm    (LocSymbol, ty)                               -- ^ 'assume' signature (unchecked)-  | AssmReflect (LocSymbol, LocSymbol)                    -- ^ 'assume reflects' signature (unchecked)-  | Asrt    (LocSymbol, ty)                               -- ^ 'assert' signature (checked)-  | LAsrt   (LocSymbol, ty)                               -- ^ 'local' assertion -- TODO RJ: what is this-  | Asrts   ([LocSymbol], (ty, Maybe [Located Expr]))     -- ^ TODO RJ: what is this-  | Impt    Symbol                                        -- ^ 'import' a specification module-  | DDecl   DataDecl                                      -- ^ refined 'data'    declaration-  | NTDecl  DataDecl                                      -- ^ refined 'newtype' declaration-  | Relational (LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr) -- ^ relational signature-  | AssmRel (LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr) -- ^ 'assume' relational signature-  | Class   (RClass ty)                                   -- ^ refined 'class' definition-  | CLaws   (RClass ty)                                   -- ^ 'class laws' definition-  | ILaws   (RILaws ty)-  | RInst   (RInstance ty)                                -- ^ refined 'instance' definition-  | Incl    FilePath                                      -- ^ 'include' a path -- TODO: deprecate-  | Invt    ty                                            -- ^ 'invariant' specification-  | Using  (ty, ty)                                       -- ^ 'using' declaration (for local invariants on a type)-  | Alias   (Located (RTAlias Symbol BareType))           -- ^ 'type' alias declaration-  | EAlias  (Located (RTAlias Symbol Expr))               -- ^ 'predicate' alias declaration-  | Embed   (LocSymbol, FTycon, TCArgs)                   -- ^ 'embed' declaration-  | Qualif  Qualifier                                     -- ^ 'qualif' definition-  | LVars   LocSymbol                                     -- ^ 'lazyvar' annotation, defer checks to *use* sites-  | Lazy    LocSymbol                                     -- ^ 'lazy' annotation, skip termination check on binder-  | Fail    LocSymbol                                     -- ^ 'fail' annotation, the binder should be unsafe-  | Rewrite LocSymbol                                     -- ^ 'rewrite' annotation, the binder generates a rewrite rule-  | Rewritewith (LocSymbol, [LocSymbol])                  -- ^ 'rewritewith' annotation, the first binder is using the rewrite rules of the second list,-  | Insts   (LocSymbol, Maybe Int)                        -- ^ 'auto-inst' or 'ple' annotation; use ple locally on binder-  | HMeas   LocSymbol                                     -- ^ 'measure' annotation; lift Haskell binder as measure-  | Reflect LocSymbol                                     -- ^ 'reflect' annotation; reflect Haskell binder as function in logic-  | Inline  LocSymbol                                     -- ^ 'inline' annotation;  inline (non-recursive) binder as an alias-  | Ignore  LocSymbol                                     -- ^ 'ignore' annotation; skip all checks inside this binder-  | ASize   LocSymbol                                     -- ^ 'autosize' annotation; automatically generate size metric for this type-  | HBound  LocSymbol                                     -- ^ 'bound' annotation; lift Haskell binder as an abstract-refinement "bound"-  | PBound  (Bound ty Expr)                               -- ^ 'bound' definition+data BPspec+  = Meas    (MeasureV LocSymbol LocBareTypeParsed (Located LHName)) -- ^ 'measure' definition+  | Assm    (Located LHName, LocBareTypeParsed)              -- ^ 'assume' signature (unchecked)+  | AssmReflect (Located LHName, Located LHName)             -- ^ 'assume reflects' signature (unchecked)+  | Asrt    (Located LHName, LocBareTypeParsed)              -- ^ 'assert' signature (checked)+  | Asrts   ([Located LHName], (LocBareTypeParsed, Maybe [Located (ExprV LocSymbol)])) -- ^ sym0, ..., symn :: ty / [m0,..., mn]+  | DDecl   DataDeclParsed                                -- ^ refined 'data'    declaration+  | NTDecl  DataDeclParsed                                -- ^ refined 'newtype' declaration+  | Relational (Located LHName, Located LHName, LocBareTypeParsed, LocBareTypeParsed, RelExprV LocSymbol, RelExprV LocSymbol) -- ^ relational signature+  | AssmRel (Located LHName, Located LHName, LocBareTypeParsed, LocBareTypeParsed, RelExprV LocSymbol, RelExprV LocSymbol) -- ^ 'assume' relational signature+  | Class   (RClass LocBareTypeParsed)                    -- ^ refined 'class' definition+  | RInst   (RInstance LocBareTypeParsed)                 -- ^ refined 'instance' definition+  | Invt    LocBareTypeParsed                             -- ^ 'invariant' specification+  | Using  (LocBareTypeParsed, LocBareTypeParsed)         -- ^ 'using' declaration (for local invariants on a type)+  | Alias   (Located (RTAlias Symbol BareTypeParsed))     -- ^ 'type' alias declaration+  | EAlias  (Located (RTAlias Symbol (ExprV LocSymbol)))  -- ^ 'predicate' alias declaration+  | Embed   (Located LHName, FTycon, TCArgs)              -- ^ 'embed' declaration+  | Qualif  (QualifierV LocSymbol)                        -- ^ 'qualif' definition+  | LVars   (Located LHName)                              -- ^ 'lazyvar' annotation, defer checks to *use* sites+  | Lazy    (Located LHName)                              -- ^ 'lazy' annotation, skip termination check on binder+  | Fail    (Located LHName)                              -- ^ 'fail' annotation, the binder should be unsafe+  | Rewrite (Located LHName)                              -- ^ 'rewrite' annotation, the binder generates a rewrite rule+  | Rewritewith (Located LHName, [Located LHName])        -- ^ 'rewritewith' annotation, the first binder is using the rewrite rules of the second list,+  | Insts   (Located LHName)                              -- ^ 'auto-inst' or 'ple' annotation; use ple locally on binder+  | HMeas   (Located LHName)                              -- ^ 'measure' annotation; lift Haskell binder as measure+  | Reflect (Located LHName)                              -- ^ 'reflect' annotation; reflect Haskell binder as function in logic+  | PrivateReflect LocSymbol                              -- ^ 'private-reflect' annotation+  | OpaqueReflect (Located LHName)                        -- ^ 'opaque-reflect' annotation+  | Inline  (Located LHName)                              -- ^ 'inline' annotation;  inline (non-recursive) binder as an alias+  | Ignore  (Located LHName)                              -- ^ 'ignore' annotation; skip all checks inside this binder+  | ASize   (Located LHName)                              -- ^ 'autosize' annotation; automatically generate size metric for this type+  | PBound  (Bound LocBareTypeParsed (ExprV LocSymbol))   -- ^ 'bound' definition   | Pragma  (Located String)                              -- ^ 'LIQUID' pragma, used to save configuration options in source files-  | CMeas   (Measure ty ())                               -- ^ 'class measure' definition-  | IMeas   (Measure ty ctor)                             -- ^ 'instance measure' definition-  | Varia   (LocSymbol, [Variance])                       -- ^ 'variance' annotations, marking type constructor params as co-, contra-, or in-variant-  | DSize   ([ty], LocSymbol)                             -- ^ 'data size' annotations, generating fancy termination metric+  | CMeas   (MeasureV LocSymbol LocBareTypeParsed ())     -- ^ 'class measure' definition+  | IMeas   (MeasureV LocSymbol LocBareTypeParsed (Located LHName)) -- ^ 'instance measure' definition+  | Varia   (Located LHName, [Variance])                  -- ^ 'variance' annotations, marking type constructor params as co-, contra-, or in-variant+  | DSize   ([LocBareTypeParsed], LocSymbol)              -- ^ 'data size' annotations, generating fancy termination metric   | BFix    ()                                            -- ^ fixity annotation-  | Define  (LocSymbol, Symbol)                           -- ^ 'define' annotation for specifying aliases c.f. `include-CoreToLogic.lg`-  deriving (Data, Show, Typeable)+  | Define  (Located LHName, ([Symbol], ExprV LocSymbol)) -- ^ 'define' annotation for specifying logic aliases+  deriving (Data, Typeable) -instance (PPrint ty, PPrint ctor) => PPrint (Pspec ty ctor) where+instance PPrint BPspec where   pprintTidy = ppPspec  splice :: PJ.Doc -> [PJ.Doc] -> PJ.Doc splice sep = PJ.hcat . PJ.punctuate sep -ppAsserts :: (PPrint t) => Tidy -> [LocSymbol] -> t -> Maybe [Located Expr] -> PJ.Doc+ppAsserts :: (PPrint t) => Tidy -> [Located LHName] -> t -> Maybe [Located (ExprV LocSymbol)] -> PJ.Doc ppAsserts k lxs t mles-  = PJ.hcat [ splice ", " (pprintTidy k <$> (val <$> lxs))+  = PJ.hcat [ splice ", " (map (pprintTidy k . val) lxs)             , " :: "             , pprintTidy k t             , ppLes mles             ]   where     ppLes Nothing    = ""-    ppLes (Just les) = "/" <+> pprintTidy k (val <$> les)+    ppLes (Just les) = "/" <+> pprintTidy k (fmap val . val <$> les) -ppPspec :: (PPrint t, PPrint c) => Tidy -> Pspec t c -> PJ.Doc+pprintSymbolWithParens :: LHName -> PJ.Doc+pprintSymbolWithParens lhname =+    case symbolString $ getLHNameSymbol lhname of+      n@(c:_) | not (Char.isAlpha c) -> "(" <> PJ.text n <> ")"+      n -> PJ.text n++ppPspec :: Tidy -> BPspec -> PJ.Doc ppPspec k (Meas m)-  = "measure" <+> pprintTidy k m+  = "measure" <+> pprintTidy k (val <$> unLocMeasureV m) ppPspec k (Assm (lx, t))-  = "assume"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t+  = "assume"  <+> pprintSymbolWithParens (val lx) <+> "::" <+> pprintTidy k (parsedToBareType <$> t) ppPspec k (AssmReflect (lx, ly))   = "assume reflect"  <+> pprintTidy k (val lx) <+> "as" <+> pprintTidy k (val ly) ppPspec k (Asrt (lx, t))-  = "assert"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t-ppPspec k (LAsrt (lx, t))-  = "local assert"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t+  = "assert"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k (parsedToBareType <$> t) ppPspec k (Asrts (lxs, (t, les)))-  = ppAsserts k lxs t les-ppPspec k (Impt  x)-  = "import" <+> pprintTidy k x+  = ppAsserts k lxs (parsedToBareType <$> t) les ppPspec k (DDecl d)-  = pprintTidy k d+  = pprintTidy k (parsedToBareType <$> mapDataDeclV val d) ppPspec k (NTDecl d)-  = "newtype" <+> pprintTidy k d-ppPspec _ (Incl f)-  = "include" <+> "<" PJ.<> PJ.text f PJ.<> ">"+  = "newtype" <+> pprintTidy k (parsedToBareType <$> mapDataDeclV val d) ppPspec k (Invt t)-  = "invariant" <+> pprintTidy k t+  = "invariant" <+> pprintTidy k (parsedToBareType <$> t) ppPspec k (Using (t1, t2))-  = "using" <+> pprintTidy k t1 <+> "as" <+> pprintTidy k t2+  = "using" <+> pprintTidy k (parsedToBareType <$> t1) <+> "as" <+> pprintTidy k (parsedToBareType <$> t2) ppPspec k (Alias   (Loc _ _ rta))-  = "type" <+> pprintTidy k rta+  = "type" <+> pprintTidy k (fmap parsedToBareType rta) ppPspec k (EAlias  (Loc _ _ rte))   = "predicate" <+> pprintTidy k rte ppPspec k (Embed   (lx, tc, NoArgs))@@ -942,67 +977,65 @@     go s = pprintTidy k $ val s ppPspec k (Fail   lx)   = "fail" <+> pprintTidy k (val lx)-ppPspec k (Insts   (lx, mbN))-  = "automatic-instances" <+> pprintTidy k (val lx) <+> maybe "" (("with" <+>) . pprintTidy k) mbN+ppPspec k (Insts   lx)+  = "automatic-instances" <+> pprintTidy k (val lx) ppPspec k (HMeas   lx)   = "measure" <+> pprintTidy k (val lx) ppPspec k (Reflect lx)   = "reflect" <+> pprintTidy k (val lx)+ppPspec k (PrivateReflect lx)+  = "private-reflect" <+> pprintTidy k (val lx)+ppPspec k (OpaqueReflect lx)+  = "opaque-reflect" <+> pprintTidy k (val lx) ppPspec k (Inline  lx)   = "inline" <+> pprintTidy k (val lx) ppPspec k (Ignore  lx)   = "ignore" <+> pprintTidy k (val lx)-ppPspec k (HBound  lx)-  = "bound" <+> pprintTidy k (val lx) ppPspec k (ASize   lx)   = "autosize" <+> pprintTidy k (val lx) ppPspec k (PBound  bnd)-  = pprintTidy k bnd+  = pprintTidy k $ mapBoundTy (fmap parsedToBareType) bnd ppPspec _ (Pragma  (Loc _ _ s))   = "LIQUID" <+> PJ.text s ppPspec k (CMeas   m)-  = "class measure" <+> pprintTidy k m+  = "class measure" <+> pprintTidy k (unLocMeasureV m) ppPspec k (IMeas   m)-  = "instance  measure" <+> pprintTidy k m+  = "instance measure" <+> pprintTidy k (val <$> unLocMeasureV m) ppPspec k (Class   cls)-  = pprintTidy k cls-ppPspec k (CLaws  cls)-  = pprintTidy k cls+  = pprintTidy k $ fmap (fmap parsedToBareType) cls ppPspec k (RInst   inst)-  = pprintTidy k inst+  = pprintTidy k $ fmap (fmap parsedToBareType) inst ppPspec k (Varia   (lx, vs))   = "data variance" <+> pprintTidy k (val lx) <+> splice " " (pprintTidy k <$> vs) ppPspec k (DSize   (ds, ss))-  = "data size" <+> splice " " (pprintTidy k <$> ds) <+> pprintTidy k (val ss)+  = "data size" <+> splice " " (pprintTidy k <$> map (fmap parsedToBareType) ds) <+> pprintTidy k (val ss) ppPspec _ (BFix    _)           --   = "fixity"-ppPspec k (Define  (lx, y))-  = "define" <+> pprintTidy k (val lx) <+> "=" <+> pprintTidy k y-ppPspec _ ILaws{}-  = "TBD-INSTANCE-LAWS"+ppPspec k (Define  (lx, (ys, e)))+  = "define" <+> pprintTidy k (val lx) <+> " " <+> pprintTidy k ys <+> "=" <+> pprintTidy k e ppPspec k (Relational (lxl, lxr, tl, tr, q, p))   = "relational"-        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k tl <+> "~"-        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k tr <+> "|"-        <+> pprintTidy k q <+> "=>" <+> pprintTidy k p+        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k (parsedToBareType <$> tl) <+> "~"+        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k (parsedToBareType <$> tr) <+> "|"+        <+> pprintTidy k (fmap val q) <+> "=>" <+> pprintTidy k (fmap val p) ppPspec k (AssmRel (lxl, lxr, tl, tr, q, p))   = "assume relational"-        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k tl <+> "~"-        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k tr <+> "|"-        <+> pprintTidy k q <+> "=>" <+> pprintTidy k p+        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k (parsedToBareType <$> tl) <+> "~"+        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k (parsedToBareType <$> tr) <+> "|"+        <+> pprintTidy k (fmap val q) <+> "=>" <+> pprintTidy k (fmap val p) +unLocMeasureV :: MeasureV LocSymbol LocBareTypeParsed v -> MeasureV Symbol LocBareType v+unLocMeasureV = mapMeasureV val . mapMeasureTy (fmap parsedToBareType)  -- | For debugging {-instance Show (Pspec a b) where   show (Meas   _) = "Meas"   show (Assm   _) = "Assm"   show (Asrt   _) = "Asrt"-  show (LAsrt  _) = "LAsrt"   show (Asrts  _) = "Asrts"   show (Impt   _) = "Impt"   shcl  _) = "DDecl"   show (NTDecl _) = "NTDecl"-  show (Incl   _) = "Incl"   show (Invt   _) = "Invt"   show (Using _) = "Using"   show (Alias  _) = "Alias"@@ -1013,10 +1046,8 @@   show (LVars  _) = "LVars"   show (Lazy   _) = "Lazy"   -- show (Axiom  _) = "Axiom"-  show (Insts  _) = "Insts"   show (Reflect _) = "Reflect"   show (HMeas  _) = "HMeas"-  show (HBound _) = "HBound"   show (Inline _) = "Inline"   show (Pragma _) = "Pragma"   show (CMeas  _) = "CMeas"@@ -1029,14 +1060,6 @@   show (BFix   _) = "BFix"   show (Define _) = "Define"-} -qualifySpec :: Symbol -> Spec ty bndr -> Spec ty bndr-qualifySpec name sp = sp { sigs      = [ (tx x, t)  | (x, t)  <- sigs sp]-                         -- , asmSigs   = [ (tx x, t)  | (x, t)  <- asmSigs sp]-                         }-  where-    tx :: Located Symbol -> Located Symbol-    tx = fmap (qualifySymbol name)- -- | Turns a list of parsed specifications into a "bare spec". -- -- This is primarily a rearrangement, as the bare spec is a record containing@@ -1047,45 +1070,34 @@ -- signatues) are being qualified, i.e., the binding occurrences are prefixed -- with the module name. ----- Andres: It is unfortunately totally unclear to me what the justification--- for the qualification is, and in particular, why it is being done for--- the asserted signatures only. My trust is not exactly improved by the--- commented out line in 'qualifySpec'.----mkSpec :: ModName -> [BPspec] -> (ModName, Measure.Spec LocBareType LocSymbol)-mkSpec name xs         = (name,) $ qualifySpec (symbol name) Measure.Spec+mkSpec :: [BPspec] -> Measure.Spec LocSymbol BareTypeParsed+mkSpec xs = Measure.Spec   { Measure.measures   = [m | Meas   m <- xs]   , Measure.asmSigs    = [a | Assm   a <- xs]   , Measure.asmReflectSigs = [(l, r) | AssmReflect (l, r) <- xs]   , Measure.sigs       = [a | Asrt   a <- xs]                       ++ [(y, t) | Asrts (ys, (t, _)) <- xs, y <- ys]-  , Measure.localSigs  = []-  , Measure.reflSigs   = []-  , Measure.impSigs    = []   , Measure.expSigs    = []   , Measure.invariants = [(Nothing, t) | Invt   t <- xs]   , Measure.ialiases   = [t | Using t <- xs]-  , Measure.imports    = [i | Impt   i <- xs]   , Measure.dataDecls  = [d | DDecl  d <- xs] ++ [d | NTDecl d <- xs]   , Measure.newtyDecls = [d | NTDecl d <- xs]-  , Measure.includes   = [q | Incl   q <- xs]   , Measure.aliases    = [a | Alias  a <- xs]   , Measure.ealiases   = [e | EAlias e <- xs]   , Measure.embeds     = tceFromList [(c, (fTyconSort tc, a)) | Embed (c, tc, a) <- xs]   , Measure.qualifiers = [q | Qualif q <- xs]   , Measure.lvars      = S.fromList [d | LVars d  <- xs]-  , Measure.autois     = M.fromList [s | Insts s <- xs]+  , Measure.autois     = S.fromList [s | Insts s <- xs]   , Measure.pragmas    = [s | Pragma s <- xs]   , Measure.cmeasures  = [m | CMeas  m <- xs]   , Measure.imeasures  = [m | IMeas  m <- xs]+  , Measure.omeasures  = []   , Measure.classes    = [c | Class  c <- xs]   , Measure.relational = [r | Relational r <- xs]   , Measure.asmRel     = [r | AssmRel r <- xs]-  , Measure.claws      = [c | CLaws  c <- xs]   , Measure.dvariance  = [v | Varia  v <- xs]   , Measure.dsize      = [v | DSize  v <- xs]   , Measure.rinstance  = [i | RInst  i <- xs]-  , Measure.ilaws      = [i | ILaws  i <- xs]   , Measure.termexprs  = [(y, es) | Asrts (ys, (_, Just es)) <- xs, y <- ys]   , Measure.lazy       = S.fromList [s | Lazy   s <- xs]   , Measure.fails      = S.fromList [s | Fail   s <- xs]@@ -1093,13 +1105,15 @@   , Measure.rewriteWith = M.fromList [s | Rewritewith s <- xs]   , Measure.bounds     = M.fromList [(bname i, i) | PBound i <- xs]   , Measure.reflects   = S.fromList [s | Reflect s <- xs]+  , Measure.privateReflects = S.fromList [s | PrivateReflect s <- xs]+  , Measure.opaqueReflects = S.fromList [s | OpaqueReflect s <- xs]   , Measure.hmeas      = S.fromList [s | HMeas  s <- xs]   , Measure.inlines    = S.fromList [s | Inline s <- xs]   , Measure.ignores    = S.fromList [s | Ignore s <- xs]   , Measure.autosize   = S.fromList [s | ASize  s <- xs]-  , Measure.hbounds    = S.fromList [s | HBound s <- xs]-  , Measure.defs       = M.fromList [d | Define d <- xs]   , Measure.axeqs      = []+  , Measure.defines    = [ toLMapV d | Define d <- xs]+  , Measure.usedDataCons = mempty   }  -- | Parse a single top level liquid specification@@ -1107,44 +1121,39 @@ specP   = fallbackSpecP "assume" ((reserved "reflect" >> fmap AssmReflect assmReflectBindP)         <|> (reserved "relational" >>  fmap AssmRel relationalP)-        <|>                            fmap Assm   tyBindP  )-    <|> fallbackSpecP "assert"      (fmap Asrt    tyBindP  )-    <|> fallbackSpecP "autosize"    (fmap ASize   asizeP   )-    <|> (reserved "local"         >> fmap LAsrt   tyBindP  )+        <|>                            fmap Assm   tyBindLHNameP  )+    <|> fallbackSpecP "assert"      (fmap Asrt    tyBindLocalLHNameP)+    <|> fallbackSpecP "autosize"    (fmap ASize   tyConBindLHNameP)      -- TODO: These next two are synonyms, kill one-    <|> fallbackSpecP "axiomatize"  (fmap Reflect axiomP   )-    <|> fallbackSpecP "reflect"     (fmap Reflect axiomP   )+    <|> fallbackSpecP "axiomatize"  (fmap Reflect locBinderLHNameP)+    <|> fallbackSpecP "reflect"     (fmap Reflect locBinderLHNameP)+    <|> (reserved "private-reflect" >> fmap PrivateReflect axiomP  )+    <|> (reserved "opaque-reflect" >> fmap OpaqueReflect locBinderLHNameP  ) -    <|> fallbackSpecP "measure"    hmeasureP+    <|> fallbackSpecP "define"  logDefineP+    <|> fallbackSpecP "measure" hmeasureP -    <|> fallbackSpecP "define"      (fmap Define  defineP  )     <|> (reserved "infixl"        >> fmap BFix    infixlP  )     <|> (reserved "infixr"        >> fmap BFix    infixrP  )     <|> (reserved "infix"         >> fmap BFix    infixP   )-    <|> fallbackSpecP "inline"      (fmap Inline  inlineP  )-    <|> fallbackSpecP "ignore"      (fmap Ignore  inlineP  )+    <|> fallbackSpecP "inline"      (fmap Inline locBinderThisModuleLHNameP)+    <|> fallbackSpecP "ignore"      (fmap Ignore  locBinderThisModuleLHNameP) -    <|> fallbackSpecP "bound"       (fmap PBound  boundP-                                 <|> fmap HBound  hboundP  )+    <|> fallbackSpecP "bound"       (fmap PBound  boundP)     <|> (reserved "class"          >> ((reserved "measure"  >> fmap CMeas  cMeasureP )-         <|> (reserved "laws"     >> fmap CLaws  classP)          <|> fmap Class  classP                            ))     <|> (reserved "instance"          >> ((reserved "measure"  >> fmap IMeas  iMeasureP )-         <|> (reserved "laws"     >> fmap ILaws instanceLawP)          <|> fmap RInst  instanceP )) -    <|> (reserved "import"        >> fmap Impt   symbolP   )-     <|> (reserved "data"         >> ((reserved "variance"  >> fmap Varia  datavarianceP)         <|> (reserved "size"      >> fmap DSize  dsizeP)         <|> fmap DDecl  dataDeclP ))     <|> (reserved "newtype"       >> fmap NTDecl dataDeclP )     <|> (reserved "relational"    >> fmap Relational relationalP )-    <|> (reserved "include"       >> fmap Incl   filePathP )     <|> fallbackSpecP "invariant"   (fmap Invt   invariantP)     <|> (reserved "using"          >> fmap Using invaliasP )     <|> (reserved "type"          >> fmap Alias  aliasP    )@@ -1155,14 +1164,14 @@      <|> fallbackSpecP "embed"       (fmap Embed  embedP    )     <|> fallbackSpecP "qualif"      (fmap Qualif (qualifierP sortP))-    <|> (reserved "lazyvar"       >> fmap LVars  lazyVarP  )+    <|> (reserved "lazyvar"       >> fmap LVars  locBinderThisModuleLHNameP) -    <|> (reserved "lazy"          >> fmap Lazy   lazyVarP  )-    <|> (reserved "rewrite"       >> fmap Rewrite   rewriteVarP )+    <|> (reserved "lazy"          >> fmap Lazy   locBinderLHNameP)+    <|> (reserved "rewrite"       >> fmap Rewrite locBinderLHNameP)     <|> (reserved "rewriteWith"   >> fmap Rewritewith   rewriteWithP )-    <|> (reserved "fail"          >> fmap Fail   failVarP  )-    <|> (reserved "ple"           >> fmap Insts autoinstP  )-    <|> (reserved "automatic-instances" >> fmap Insts autoinstP  )+    <|> (reserved "fail"          >> fmap Fail locBinderThisModuleLHNameP )+    <|> (reserved "ple"           >> fmap Insts locBinderThisModuleLHNameP  )+    <|> (reserved "automatic-instances" >> fmap Insts locBinderThisModuleLHNameP  )     <|> (reserved "LIQUID"        >> fmap Pragma pragmaP   )     <|> (reserved "liquid"        >> fmap Pragma pragmaP   )     <|> {- DEFAULT -}                fmap Asrts  tyBindsP@@ -1174,10 +1183,12 @@ fallbackSpecP :: String -> Parser BPspec -> Parser BPspec fallbackSpecP kw p = do   (Loc l1 l2 _) <- locReserved kw-  p <|> fmap Asrts (tyBindsRemP (Loc l1 l2 (symbol kw)) )+  p <|> fmap Asrts (tyBindsRemP (Loc l1 l2 (makeUnresolvedLHName (LHVarName LHThisModuleNameF) (symbol kw))))  -- | Same as tyBindsP, except the single initial symbol has already been matched-tyBindsRemP :: LocSymbol -> Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))+tyBindsRemP+  :: Located LHName+  -> Parser ([Located LHName], (Located BareTypeParsed, Maybe [Located (ExprV LocSymbol)])) tyBindsRemP sy = do   reservedOp "::"   tb <- termBareTypeP@@ -1186,49 +1197,16 @@ pragmaP :: Parser (Located String) pragmaP = locStringLiteral -autoinstP :: Parser (LocSymbol, Maybe Int)-autoinstP = do x <- locBinderP-               i <- optional (reserved "with" >> natural)-               return (x, fromIntegral <$> i)--lazyVarP :: Parser LocSymbol-lazyVarP = locBinderP---rewriteVarP :: Parser LocSymbol-rewriteVarP = locBinderP--rewriteWithP :: Parser (LocSymbol, [LocSymbol])-rewriteWithP = (,) <$> locBinderP <*> brackets (sepBy1 locBinderP comma)--failVarP :: Parser LocSymbol-failVarP = locBinderP+rewriteWithP :: Parser (Located LHName, [Located LHName])+rewriteWithP = (,) <$> locBinderLHNameP <*> brackets (sepBy1 locBinderLHNameP comma)  axiomP :: Parser LocSymbol axiomP = locBinderP -hboundP :: Parser LocSymbol-hboundP = locBinderP--inlineP :: Parser LocSymbol-inlineP = locBinderP--asizeP :: Parser LocSymbol-asizeP = locBinderP--filePathP     :: Parser FilePath-filePathP     = angles $ some pathCharP-  where-    pathCharP :: Parser Char-    pathCharP = choice $ char <$> pathChars--    pathChars :: [Char]-    pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/']--datavarianceP :: Parser (Located Symbol, [Variance])-datavarianceP = liftM2 (,) locUpperIdP (many varianceP)+datavarianceP :: Parser (Located LHName, [Variance])+datavarianceP = liftM2 (,) (locUpperIdLHNameP LHTcName) (many varianceP) -dsizeP :: Parser ([Located BareType], Located Symbol)+dsizeP :: Parser ([Located BareTypeParsed], Located Symbol) dsizeP = liftM2 (,) (parens $ sepBy (located genBareTypeP) comma) locBinderP  @@ -1239,29 +1217,47 @@         <|> (reserved "contravariant" >> return Contravariant)         <?> "Invalid variance annotation\t Use one of bivariant, invariant, covariant, contravariant" -tyBindsP :: Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))+tyBindsP :: Parser ([Located LHName], (Located BareTypeParsed, Maybe [Located (ExprV LocSymbol)])) tyBindsP =-  xyP (sepBy1 locBinderP comma) (reservedOp "::") termBareTypeP+  xyP (sepBy1 locBinderThisModuleLHNameP comma) (reservedOp "::") termBareTypeP -tyBindNoLocP :: Parser (LocSymbol, BareType)+tyBindNoLocP :: Parser (LocSymbol, BareTypeParsed) tyBindNoLocP = second val <$> tyBindP  -- | Parses a type signature as it occurs in "assume" and "assert" directives.-tyBindP :: Parser (LocSymbol, Located BareType)+tyBindP :: Parser (LocSymbol, Located BareTypeParsed) tyBindP =   (,) <$> locBinderP <* reservedOp "::" <*> located genBareTypeP +tyBindLogicNameP :: Parser (Located LHName, Located BareTypeParsed)+tyBindLogicNameP =+  (,) <$> locBinderLogicNameP <* reservedOp "::" <*> located genBareTypeP++tyBindLHNameP :: Parser (Located LHName, Located BareTypeParsed)+tyBindLHNameP = do+    x <- locBinderLHNameP+    _ <- reservedOp "::"+    t <- located genBareTypeP+    return (x, t)++tyBindLocalLHNameP :: Parser (Located LHName, Located BareTypeParsed)+tyBindLocalLHNameP = do+    x <- locBinderThisModuleLHNameP+    _ <- reservedOp "::"+    t <- located genBareTypeP+    return (x, t)+ -- | Parses a loc symbol.-assmReflectBindP :: Parser (LocSymbol, LocSymbol)+assmReflectBindP :: Parser (Located LHName, Located LHName) assmReflectBindP =-  (,) <$> locBinderP <* reservedOp "as" <*> locBinderP+  (,) <$> locBinderLHNameP <* reservedOp "as" <*> locBinderLHNameP -termBareTypeP :: Parser (Located BareType, Maybe [Located Expr])+termBareTypeP :: Parser (Located BareTypeParsed, Maybe [Located (ExprV LocSymbol)]) termBareTypeP = do   t <- located genBareTypeP   termTypeP t <|> return (t, Nothing) -termTypeP :: Located BareType ->Parser (Located BareType, Maybe [Located Expr])+termTypeP :: Located BareTypeParsed -> Parser (Located BareTypeParsed, Maybe [Located (ExprV LocSymbol)]) termTypeP t   = do        reservedOp "/"@@ -1270,22 +1266,22 @@  -- ------------------------------------- -invariantP :: Parser (Located BareType)+invariantP :: Parser (Located BareTypeParsed) invariantP = located genBareTypeP -invaliasP :: Parser (Located BareType, Located BareType)+invaliasP :: Parser (Located BareTypeParsed, Located BareTypeParsed) invaliasP   = do t  <- located genBareTypeP        reserved "as"        ta <- located genBareTypeP        return (t, ta) -genBareTypeP :: Parser BareType+genBareTypeP :: Parser BareTypeParsed genBareTypeP = bareTypeP -embedP :: Parser (Located Symbol, FTycon, TCArgs)+embedP :: Parser (Located LHName, FTycon, TCArgs) embedP = do-  x <- locUpperIdP+  x <- locUpperIdLHNameP LHTcName   a <- try (reserved "*" >> return WithArgs) <|> return NoArgs -- TODO: reserved "*" looks suspicious   _ <- reserved "as"   t <- fTyConP@@ -1293,10 +1289,10 @@   --  = xyP locUpperIdP symbolTCArgs (reserved "as") fTyConP  -aliasP :: Parser (Located (RTAlias Symbol BareType))+aliasP :: Parser (Located (RTAlias Symbol BareTypeParsed)) aliasP  = rtAliasP id     bareTypeP <?> "aliasP" -ealiasP :: Parser (Located (RTAlias Symbol Expr))+ealiasP :: Parser (Located (RTAlias Symbol (ExprV LocSymbol))) ealiasP = try (rtAliasP symbol predP)       <|> rtAliasP symbol exprP       <?> "ealiasP"@@ -1313,114 +1309,101 @@        let (tArgs, vArgs) = partition (isSmall . headSym) args        return $ Loc pos posE (RTA name (f <$> tArgs) vArgs body) +logDefineP :: Parser BPspec+logDefineP =+    do s <- locBinderLHNameP+       args <- many locSymbolP+       reservedOp "="+       e <- exprP <|> predP+       return (Define (s, (val <$> args, e)))+ hmeasureP :: Parser BPspec hmeasureP = do   setLayout-  b <- locBinderP-  (do reservedOp "::"-      ty <- located genBareTypeP-      popLayout >> popLayout-      eqns <- block $ try $ measureDefP (rawBodyP <|> tyBodyP ty)-      return (Meas $ Measure.mkM b ty eqns MsMeasure mempty))-    <|> (popLayout >> popLayout >> return (HMeas b))+  do b <- try (locBinderLogicNameP <* reservedOp "::")+     ty <- located genBareTypeP+     popLayout >> popLayout+     eqns <- block $ try $ measureDefP LHLogicNameBinder (rawBodyP <|> tyBodyP ty)+     return (Meas $ Measure.mkM b ty eqns MsMeasure mempty)+    <|>+   do b <- locBinderLHNameP+      popLayout >> popLayout >> return (HMeas b) -measureP :: Parser (Measure (Located BareType) LocSymbol)-measureP = do+iMeasureP :: Parser (MeasureV LocSymbol (Located BareTypeParsed) (Located LHName))+iMeasureP = do   (x, ty) <- indentedLine tyBindP   _ <- optional semi-  eqns    <- block $ measureDefP (rawBodyP <|> tyBodyP ty)-  return   $ Measure.mkM x ty eqns MsMeasure mempty+  eqns    <- block $ measureDefP LHLogicName (rawBodyP <|> tyBodyP ty)+  return   $ Measure.mkM (makeUnresolvedLHName LHLogicName <$> x) ty eqns MsMeasure mempty  -- | class measure-cMeasureP :: Parser (Measure (Located BareType) ())+cMeasureP :: Parser (MeasureV LocSymbol (Located BareTypeParsed) ()) cMeasureP-  = do (x, ty) <- tyBindP+  = do (x, ty) <- tyBindLogicNameP        return $ Measure.mkM x ty [] MsClass mempty -iMeasureP :: Parser (Measure (Located BareType) LocSymbol)-iMeasureP = measureP---oneClassArg :: Parser [Located BareType]+oneClassArg :: Parser [Located BareTypeParsed] oneClassArg   = sing <$> located (rit <$> classBTyConP <*> (map val <$> classParams))   where-    rit t as    = RApp t ((`RVar` mempty) <$> as) [] mempty+    rit t as    = RApp t ((`RVar` trueURef) <$> as) [] trueURef     classParams =  (reserved "where" >> return [])-               <|> ((:) <$> (fmap bTyVar <$> locLowerIdP) <*> classParams)+               <|> ((:) <$> ((\ls -> bTyVar ls <$ ls) <$> locLowerIdP) <*> classParams)     sing x      = [x]  -superP :: Parser (Located BareType)+superP :: Parser (Located BareTypeParsed) superP = located (toRCls <$> bareAtomBindP)   where toRCls x = x -instanceLawP :: Parser (RILaws (Located BareType))-instanceLawP-  = do l1   <- getSourcePos-       sups <- supersP-       c    <- classBTyConP-       tvs  <- manyTill (located bareTypeP) (try $ reserved "where")-       ms   <- block eqBinderP-       l2   <- getSourcePos-       return $ RIL c sups tvs ms (Loc l1 l2 ())-  where-    supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)-                       <* reservedOp "=>")-               <|> return []--    eqBinderP = xyP xP (reservedOp "=") xP--    xP = locBinderP--instanceP :: Parser (RInstance (Located BareType))+instanceP :: Parser (RInstance (Located BareTypeParsed)) instanceP   = do _    <- supersP        c    <- classBTyConP        tvs  <- try oneClassArg <|> manyTill iargsP (try $ reserved "where")        ms   <- block riMethodSigP-       return $ RI c tvs ms+       return $ RI c Nothing tvs ms   where     supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)                        <* reservedOp "=>")                <|> return [] -    iargsP   =   (mkVar . bTyVar <$> tyVarIdP)+    iargsP   =   (mkVar . bTyVar <$> located tyVarIdP)             <|> parens (located bareTypeP)  -    mkVar v  = dummyLoc $ RVar v mempty+    mkVar v  = dummyLoc $ RVar v (uTop trueReft)  -riMethodSigP :: Parser (LocSymbol, RISig (Located BareType))+riMethodSigP :: Parser (Located LHName, RISig (Located BareTypeParsed)) riMethodSigP   = try (do reserved "assume"-            (x, t) <- tyBindP+            (x, t) <- tyBindLHNameP             return (x, RIAssumed t) )- <|> do (x, t) <- tyBindP+ <|> do (x, t) <- tyBindLHNameP         return (x, RISig t)  <?> "riMethodSigP" -classP :: Parser (RClass (Located BareType))+classP :: Parser (RClass (Located BareTypeParsed)) classP   = do sups <- supersP        c    <- classBTyConP-       tvs  <- manyTill (bTyVar <$> tyVarIdP) (try $ reserved "where")-       ms   <- block tyBindP -- <|> sepBy tyBindP semi+       tvs  <- manyTill (bTyVar <$> located tyVarIdP) (try $ reserved "where")+       ms   <- block tyBindLHNameP -- <|> sepBy tyBindP semi        return $ RClass c sups tvs ms   where     supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)                        <* reservedOp "=>")                <|> return [] -rawBodyP :: Parser Body+rawBodyP :: Parser (BodyV LocSymbol) rawBodyP   = braces $ do       v <- symbolP       reservedOp "|"       R v <$> predP -tyBodyP :: Located BareType -> Parser Body+tyBodyP :: Located BareTypeParsed -> Parser (BodyV LocSymbol) tyBodyP ty   = case outTy (val ty) of       Just bt | isPropBareType bt@@ -1438,6 +1421,18 @@ locBinderP =   located binderP -- TODO +locBinderLogicNameP :: Parser (Located LHName)+locBinderLogicNameP =+  fmap (makeUnresolvedLHName LHLogicNameBinder) <$> located binderP++locBinderLHNameP :: Parser (Located LHName)+locBinderLHNameP =+  located $ makeUnresolvedLHName (LHVarName LHAnyModuleNameF) <$> binderP++locBinderThisModuleLHNameP :: Parser (Located LHName)+locBinderThisModuleLHNameP =+  located $ makeUnresolvedLHName (LHVarName LHThisModuleNameF) <$> binderP+ -- | LHS of the thing being defined -- -- TODO, Andres: this is still very broken@@ -1454,71 +1449,66 @@ -} binderP :: Parser Symbol binderP =-      symbol . (\ x -> "(" <> x <> ")") . symbolText <$> parens infixBinderIdP+      parens infixBinderIdP   <|> binderIdP   -- Note: It is important that we do *not* use the LH/fixpoint reserved words here,   -- because, for example, we must be able to use "assert" as an identifier.-  ---  -- TODO, Andres: I have no idea why we make the parens part of the symbol here.-  -- But I'm reproducing this behaviour for now, as it is backed up via a few tests. -measureDefP :: Parser Body -> Parser (Def (Located BareType) LocSymbol)-measureDefP bodyP-  = do mname   <- locSymbolP+measureDefP :: LHNameSpace -> Parser (BodyV LocSymbol) -> Parser (DefV LocSymbol (Located BareTypeParsed) (Located LHName))+measureDefP ns bodyP+  = do mname   <- fmap (makeUnresolvedLHName ns) <$> locSymbolP        (c, xs) <- measurePatP        reservedOp "="        body    <- bodyP        let xs'  = symbol . val <$> xs-       return   $ Def mname (symbol <$> c) Nothing ((, Nothing) <$> xs') body+       return   $ Def mname c Nothing ((, Nothing) <$> xs') body -measurePatP :: Parser (LocSymbol, [LocSymbol])+measurePatP :: Parser (Located LHName, [LocSymbol]) measurePatP   =  parens (try conPatP <|> try consPatP <|> nilPatP <|> tupPatP)  <|> nullaryConPatP  <?> "measurePatP" -tupPatP :: Parser (Located Symbol, [Located Symbol])-tupPatP  = mkTupPat  <$> sepBy1 locLowerIdP comma+tupPatP :: Parser (Located LHName, [Located Symbol])+tupPatP  = mkTupPat  <$> located (sepBy1 locLowerIdP comma) -conPatP :: Parser (Located Symbol, [Located Symbol])-conPatP  = (,)       <$> dataConNameP <*> many locLowerIdP+conPatP :: Parser (Located LHName, [Located Symbol])+conPatP  = (,)       <$> dataConLHNameP <*> many locLowerIdP -consPatP :: IsString a-         => Parser (Located a, [Located Symbol])-consPatP = mkConsPat <$> locLowerIdP  <*> reservedOp ":" <*> locLowerIdP+consPatP :: Parser (Located LHName, [Located Symbol])+consPatP = mkConsPat <$> locLowerIdP  <*> located (reservedOp ":") <*> locLowerIdP -nilPatP :: IsString a-        => Parser (Located a, [t])-nilPatP  = mkNilPat  <$> brackets (pure ())+nilPatP :: Parser (Located LHName, [t])+nilPatP  = mkNilPat  <$> located (brackets (pure ())) -nullaryConPatP :: Parser (Located Symbol, [t])-nullaryConPatP = nilPatP <|> ((,[]) <$> dataConNameP)+nullaryConPatP :: Parser (Located LHName, [t])+nullaryConPatP = nilPatP <|> ((,[]) <$> dataConLHNameP)                  <?> "nullaryConPatP" -mkTupPat :: Foldable t => t a -> (Located Symbol, t a)-mkTupPat zs     = (tupDataCon (length zs), zs)--mkNilPat :: IsString a => t -> (Located a, [t1])-mkNilPat _      = (dummyLoc "[]", []    )--mkConsPat :: IsString a => t1 -> t -> t1 -> (Located a, [t1])-mkConsPat x _ y = (dummyLoc ":" , [x, y])+mkTupPat :: Foldable t => Located (t a) -> (Located LHName, t a)+mkTupPat lzs =+    let tupledDC = GHC.tupleDataCon GHC.Boxed (length (val lzs))+     in (makeGHCLHName (GHC.getName tupledDC) (symbol tupledDC) <$ lzs, val lzs) -tupDataCon :: Int -> Located Symbol-tupDataCon n    = dummyLoc $ symbol $ "(" <> replicate (n - 1) ',' <> ")"+mkNilPat :: Located t -> (Located LHName, [t1])+mkNilPat lx     = (makeGHCLHName (GHC.getName GHC.nilDataCon) (symbol GHC.nilDataCon) <$ lx, []) +mkConsPat :: t1 -> Located t -> t1 -> (Located LHName, [t1])+mkConsPat x lc y = (makeGHCLHName (GHC.getName GHC.consDataCon) (symbol GHC.consDataCon) <$ lc, [x, y])  ------------------------------------------------------------------------------- --------------------------------- Predicates ---------------------------------- ------------------------------------------------------------------------------- -dataConFieldsP :: Parser [(Symbol, BareType)]+dataConFieldsP :: Parser [(LHName, BareTypeParsed)] dataConFieldsP-   =  explicitCommaBlock predTypeDDP -- braces (sepBy predTypeDDP comma)-  <|> many dataConFieldP-  <?> "dataConFieldP"+   = map (first (makeUnresolvedLHName LHLogicNameBinder)) <$>+     (explicitCommaBlock predTypeDDP -- braces (sepBy predTypeDDP comma)+       <|> many dataConFieldP+       <?> "dataConFieldP"+     ) -dataConFieldP :: Parser (Symbol, BareType)+dataConFieldP :: Parser (Symbol, BareTypeParsed) dataConFieldP    =  parens (try predTypeDDP <|> dbTypeP)   <|> dbTyArgP -- unparenthesised constructor fields must be "atomic"@@ -1527,32 +1517,35 @@     dbTypeP = (,) <$> dummyBindP <*> bareTypeP     dbTyArgP = (,) <$> dummyBindP <*> bareTyArgP -predTypeDDP :: Parser (Symbol, BareType)+predTypeDDP :: Parser (Symbol, BareTypeParsed) predTypeDDP = (,) <$> bbindP <*> bareTypeP  bbindP   :: Parser Symbol bbindP   = lowerIdP <* reservedOp "::" -dataConP :: [Symbol] -> Parser DataCtor+tyConBindLHNameP :: Parser (Located LHName)+tyConBindLHNameP = locUpperIdLHNameP LHTcName++dataConP :: [Symbol] -> Parser DataCtorParsed dataConP as = do-  x   <- dataConNameP+  x   <- dataConLHNameP   xts <- dataConFieldsP   return $ DataCtor x as [] xts Nothing -adtDataConP :: [Symbol] -> Parser DataCtor+adtDataConP :: [Symbol] -> Parser DataCtorParsed adtDataConP as = do-  x     <- dataConNameP+  x     <- dataConLHNameP   reservedOp "::"   tr    <- toRTypeRep <$> bareTypeP   return $ DataCtor x (tRepVars as tr) [] (tRepFields tr) (Just $ ty_res tr) -tRepVars :: Symbolic a => [Symbol] -> RTypeRep c a r -> [Symbol]+tRepVars :: Symbolic a => [Symbol] -> RTypeRepV v c a r -> [Symbol] tRepVars as tr = case fst <$> ty_vars tr of   [] -> as   vs -> symbol . ty_var_value <$> vs -tRepFields :: RTypeRep c tv r -> [(Symbol, RType c tv r)]-tRepFields tr = zip (ty_binds tr) (ty_args tr)+tRepFields :: RTypeRepV v c tv r -> [(LHName, RTypeV v c tv r)]+tRepFields tr = zip (map (makeUnresolvedLHName LHLogicNameBinder) $ ty_binds tr) (ty_args tr)  -- TODO: fix Located dataConNameP :: Parser (Located Symbol)@@ -1565,18 +1558,21 @@   where      idP p  = takeWhile1P Nothing (not . p)      bad c  = isSpace c || c `elem` ("(,)" :: String)-     pwr s  = symbol $ "(" <> s <> ")"+     pwr s  = symbol s -dataSizeP :: Parser (Maybe SizeFun)+dataConLHNameP :: Parser (Located LHName)+dataConLHNameP = fmap (makeUnresolvedLHName (LHDataConName LHAnyModuleNameF)) <$> dataConNameP++dataSizeP :: Parser (Maybe (SizeFunV LocSymbol)) dataSizeP-  = brackets (Just . SymSizeFun <$> locLowerIdP)+  = brackets (Just . SymSizeFun <$> located locLowerIdP)   <|> return Nothing -relationalP :: Parser (LocSymbol, LocSymbol, LocBareType, LocBareType, RelExpr, RelExpr)+relationalP :: Parser (Located LHName, Located LHName, LocBareTypeParsed, LocBareTypeParsed, RelExprV LocSymbol, RelExprV LocSymbol) relationalP = do-   x <- locBinderP+   x <- locBinderLHNameP    reserved "~"-   y <- locBinderP+   y <- locBinderLHNameP    reserved "::"    braces $ do     tx <- located genBareTypeP@@ -1587,22 +1583,22 @@     ex <- relrefaP     return (x,y,tx,ty,assm,ex) -dataDeclP :: Parser DataDecl+dataDeclP :: Parser DataDeclParsed dataDeclP = do   pos <- getSourcePos   x   <- locUpperOrInfixIdP   fsize <- dataSizeP   dataDeclBodyP pos x fsize <|> return (emptyDecl x pos fsize) -emptyDecl :: LocSymbol -> SourcePos -> Maybe SizeFun -> DataDecl+emptyDecl :: LocSymbol -> SourcePos -> Maybe (SizeFunV LocSymbol) -> DataDeclParsed emptyDecl x pos fsize@(Just _)-  = DataDecl (DnName x) [] [] Nothing pos fsize Nothing DataUser+  = DataDecl (DnName $ makeUnresolvedLHName LHTcName <$> x) [] [] Nothing pos fsize Nothing DataUser emptyDecl x pos _   = uError (ErrBadData (sourcePosSrcSpan pos) (pprint (val x)) msg)   where     msg = "You should specify either a default [size] or one or more fields in the data declaration" -dataDeclBodyP :: SourcePos -> LocSymbol -> Maybe SizeFun -> Parser DataDecl+dataDeclBodyP :: SourcePos -> LocSymbol -> Maybe (SizeFunV LocSymbol) -> Parser DataDeclParsed dataDeclBodyP pos x fsize = do   vanilla    <- null <$> many locUpperIdP   as         <- many noWhere -- TODO: check this again@@ -1611,9 +1607,9 @@   let dn      = dataDeclName pos x vanilla dcs   return      $ DataDecl dn as ps (Just dcs) pos fsize pTy DataUser -dataDeclName :: SourcePos -> LocSymbol -> Bool -> [DataCtor] -> DataName-dataDeclName _ x True  _     = DnName x               -- vanilla data    declaration-dataDeclName _ _ False (d:_) = DnCon  (dcName d)      -- family instance declaration+dataDeclName :: SourcePos -> LocSymbol -> Bool -> [DataCtorParsed] -> DataName+dataDeclName _ x True  _     = DnName $ makeUnresolvedLHName LHTcName <$> x  -- vanilla data    declaration+dataDeclName _ _ False (d:_) = DnCon  $ dcName d                             -- family instance declaration dataDeclName p x _  _        = uError (ErrBadData (sourcePosSrcSpan p) (pprint (val x)) msg)   where     msg                  = "You should specify at least one data constructor for a family instance"@@ -1624,7 +1620,7 @@ -- to match Haskell more closely and parse all constructors in a layout-sensitive block, -- whereas before we required them to be separated by @|@. ---dataCtorsP :: [Symbol] -> Parser (Maybe BareType, [DataCtor])+dataCtorsP :: [Symbol] -> Parser (Maybe BareTypeParsed, [DataCtorParsed]) dataCtorsP as = do   (pTy, dcs) <-     (reservedOp "="     >> ((Nothing, ) <$>                 sepBy (dataConP    as) (reservedOp "|")))                 <|> (reserved   "where" >> ((Nothing, ) <$>                 block (adtDataConP as)                 ))@@ -1638,7 +1634,7 @@   guard (s /= "where")   return s -dataPropTyP :: Parser (Maybe BareType)+dataPropTyP :: Parser (Maybe BareTypeParsed) dataPropTyP = Just <$> between (reservedOp "::") (reserved "where") bareTypeP  ---------------------------------------------------------------------
src/Language/Haskell/Liquid/Termination/Structural.hs view
@@ -4,8 +4,10 @@  module Language.Haskell.Liquid.Termination.Structural (terminationVars) where -import Language.Haskell.Liquid.Types hiding (isDecreasing)+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.Specs import Language.Haskell.Liquid.GHC.Misc (showPpr)+import Language.Haskell.Liquid.UX.Config import Liquid.GHC.API  as GHC hiding ( showPpr                                                       , Env                                                       , text
src/Language/Haskell/Liquid/Transforms/ANF.hs view
@@ -11,26 +11,21 @@  module Language.Haskell.Liquid.Transforms.ANF (anormalize) where -import           Data.Word (Word64) import           Debug.Trace (trace) import           Prelude                          hiding (error) import           Language.Haskell.Liquid.GHC.TypeRep-import           Liquid.GHC.API  as Ghc hiding ( mkTyArg+import           Liquid.GHC.API  as Ghc hiding ( get, mkTyArg                                                                 , showPpr                                                                 , DsM                                                                 , panic) import qualified Liquid.GHC.API  as Ghc import           Control.Monad (forM) import           Control.Monad.State.Lazy-import           System.Console.CmdArgs.Verbosity (whenLoud) import qualified Language.Fixpoint.Types    as F  import           Language.Haskell.Liquid.UX.Config  as UX import qualified Language.Haskell.Liquid.Misc       as Misc import           Language.Haskell.Liquid.GHC.Misc   as GM-import           Language.Haskell.Liquid.Transforms.Rec-import           Language.Haskell.Liquid.Transforms.InlineAux-import           Language.Haskell.Liquid.Transforms.Rewrite import           Language.Haskell.Liquid.Types.Errors  import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp@@ -48,22 +43,11 @@ anormalize :: UX.Config -> HscEnv -> ModGuts -> IO [CoreBind] -------------------------------------------------------------------------------- anormalize cfg hscEnv modGuts = do-  whenLoud $ do-    putStrLn "***************************** GHC CoreBinds ***************************"-    putStrLn $ GM.showCBs untidy (mg_binds modGuts)-    putStrLn "***************************** REC CoreBinds ***************************"-    putStrLn $ GM.showCBs untidy orig_cbs-    putStrLn "***************************** RWR CoreBinds ***************************"-    putStrLn $ GM.showCBs untidy rwr_cbs   fromMaybe err . snd <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act     where       err      = panic Nothing "Oops, cannot A-Normalize GHC Core!"-      act      = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs+      act      = Misc.concatMapM (normalizeTopBind γ0) (mg_binds modGuts)       γ0       = emptyAnfEnv cfg-      rwr_cbs  = rewriteBinds cfg orig_cbs-      orig_cbs = transformRecExpr inl_cbs-      inl_cbs  = inlineAux cfg (mg_module modGuts) $ mg_binds modGuts-      untidy   = UX.untidyCore cfg  -------------------------------------------------------------------------------- -- | A-Normalize a @CoreBind@ --------------------------------------------------@@ -368,9 +352,9 @@   u     <- getUniqueM   let i  = getKey u   let sp = Sp.srcSpan (aeSrcSpan γ)-  return (mkUserLocal (anfOcc i) u Ghc.ManyTy t sp)+  return (mkUserLocalOrCoVar (anfOcc i) u Ghc.ManyTy t sp) -anfOcc :: Word64 -> OccName+anfOcc :: UniqueId -> OccName anfOcc = mkVarOccFS . GM.symbolFastString . F.intSymbol F.anfPrefix  data AnfEnv = AnfEnv
src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs view
@@ -21,10 +21,11 @@   , normalize   ) where +import           Data.Bifunctor (first) import           Data.ByteString                       (ByteString) import           Prelude                               hiding (error) import           Language.Haskell.Liquid.GHC.TypeRep   () -- needed for Eq 'Type'-import           Liquid.GHC.API       hiding (Expr, Located, panic)+import           Liquid.GHC.API       hiding (Expr, Located, get, panic) import qualified Liquid.GHC.API       as Ghc import qualified Liquid.GHC.API       as C import qualified Data.List                             as L@@ -34,10 +35,8 @@ import qualified Text.Printf as Printf import           Data.Text.Encoding import           Data.Text.Encoding.Error-import           Control.Monad.State import           Control.Monad.Except import           Control.Monad.Identity-import qualified Language.Fixpoint.Misc                as Misc import qualified Language.Haskell.Liquid.Misc          as Misc import           Language.Fixpoint.Types               hiding (panic, Error, R, simplify, isBool) import qualified Language.Fixpoint.Types               as F@@ -48,10 +47,16 @@ import           Language.Haskell.Liquid.Bare.DataType import           Language.Haskell.Liquid.Bare.Misc     (simpleSymbolVar) import           Language.Haskell.Liquid.GHC.Play-import           Language.Haskell.Liquid.Types.Types   --     hiding (GhcInfo(..), GhcSpec (..), LM)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types  import qualified Data.HashMap.Strict                   as M+import Control.Monad.Reader+import Language.Haskell.Liquid.UX.Config  logicType :: (Reftable r) => Bool -> Type -> RRType r logicType allowTC τ      = fromRTypeRep $ t { ty_binds = bs, ty_info = is, ty_args = as, ty_refts = rs}@@ -127,7 +132,7 @@     xts          = zip (ty_binds rep) (ty_args rep)     vF           = dummyLoc (symbol v) -type LogicM = ExceptT Error (StateT LState Identity)+type LogicM = ExceptT Error (ReaderT LState Identity)  data LState = LState   { lsSymMap  :: LogicMap@@ -135,36 +140,38 @@   , lsEmb     :: TCEmb TyCon   , lsBools   :: [Var]   , lsDCMap   :: DataConMap+  , lsConfig  :: Config   }  throw :: String -> LogicM a throw str = do-  fmkError  <- gets lsError+  fmkError  <- reader lsError   throwError $ fmkError str  getState :: LogicM LState-getState = get+getState = ask  runToLogic-  :: TCEmb TyCon -> LogicMap -> DataConMap -> (String -> Error)+  :: TCEmb TyCon -> LogicMap -> DataConMap -> Config -> (String -> Error)   -> LogicM t -> Either Error t runToLogic = runToLogicWithBoolBinds []  runToLogicWithBoolBinds-  :: [Var] -> TCEmb TyCon -> LogicMap -> DataConMap -> (String -> Error)+  :: [Var] -> TCEmb TyCon -> LogicMap -> DataConMap -> Config -> (String -> Error)   -> LogicM t -> Either Error t-runToLogicWithBoolBinds xs tce lmap dm ferror m-  = evalState (runExceptT m) $ LState+runToLogicWithBoolBinds xs tce lmap dm cfg ferror m+  = runReader (runExceptT m) $ LState       { lsSymMap = lmap       , lsError  = ferror       , lsEmb    = tce       , lsBools  = xs       , lsDCMap  = dm+      , lsConfig = cfg       } -coreAltToDef :: (Reftable r) => Bool -> LocSymbol -> Var -> [Var] -> Var -> Type -> [C.CoreAlt]+coreAltToDef :: (Reftable r) => Located LHName -> Var -> [Var] -> Var -> Type -> [C.CoreAlt]              -> LogicM [Def (Located (RRType r)) DataCon]-coreAltToDef allowTC locSym z zs y t alts+coreAltToDef locSym z zs y t alts   | not (null litAlts) = measureFail locSym "Cannot lift definition with literal alternatives"   | otherwise          = do       d1s <- F.notracepp "coreAltDefs-1" <$> mapM (mkAlt locSym cc myArgs z) dataAlts@@ -180,16 +187,18 @@      -- mkAlt :: LocSymbol -> (Expr -> Body) -> [Var] -> Var -> (C.AltCon, [Var], C.CoreExpr)     mkAlt x ctor _args dx (Alt (C.DataAlt d) xs e)-      = Def x {- (toArgs id args) -} d (Just $ varRType dx) (toArgs Just xs')-      . ctor-      . (`subst1` (F.symbol dx, F.mkEApp (GM.namedLocSymbol d) (F.eVar <$> xs')))-     <$> coreToLg allowTC e-      where xs' = filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs+      = do+          allowTC <- reader (typeclass . lsConfig)+          let xs' = filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs+          Def x {- (toArgs id args) -} d (Just $ varRType dx) (toArgs Just xs')+               . ctor+               . (`subst1` (F.symbol dx, F.mkEApp (GM.namedLocSymbol d) (F.eVar <$> xs')))+              <$> coreToLg e     mkAlt _ _ _ _ alt       = throw $ "Bad alternative" ++ GM.showPpr alt      mkDef x ctor _args dx (Just dtss) (Just e) = do-      eDef   <- ctor <$> coreToLg allowTC e+      eDef   <- ctor <$> coreToLg e       -- let ys  = toArgs id args       let dxt = Just (varRType dx)       return  [ Def x {- ys -} d dxt (defArgs x ts) eDef | (d, _, ts) <- dtss ]@@ -200,26 +209,28 @@ toArgs :: Reftable r => (Located (RRType r) -> b) -> [Var] -> [(Symbol, b)] toArgs f args = [(symbol x, f $ varRType x) | x <- args] -defArgs :: Monoid r => LocSymbol -> [Type] -> [(Symbol, Maybe (Located (RRType r)))]+defArgs :: Monoid r => Located LHName -> [Type] -> [(Symbol, Maybe (Located (RRType r)))] defArgs x     = zipWith (\i t -> (defArg i, defRTyp t)) [0..]   where-    defArg    = tempSymbol (val x)+    defArg    = tempSymbol (lhNameToResolvedSymbol $ val x)     defRTyp   = Just . F.atLoc x . ofType -coreToDef :: Reftable r => Bool -> LocSymbol -> Var -> C.CoreExpr+coreToDef :: Reftable r => Located LHName -> Var -> C.CoreExpr           -> LogicM [Def (Located (RRType r)) DataCon]-coreToDef allowTC locSym _                   = go [] . inlinePreds . simplify allowTC+coreToDef locSym _ s              = do +    allowTC <- reader $ typeclass . lsConfig+    go [] $ inlinePreds $ simplify allowTC s   where     go args   (C.Lam  x e)        = go (x:args) e     go args   (C.Tick _ e)        = go args e-    go (z:zs) (C.Case _ y t alts) = coreAltToDef allowTC locSym z zs y t alts+    go (z:zs) (C.Case _ y t alts) = coreAltToDef locSym z zs y t alts     go (z:zs) e-      | Just t <- isMeasureArg z  = coreAltToDef allowTC locSym z zs z t [Alt C.DEFAULT [] e]+      | Just t <- isMeasureArg z  = coreAltToDef locSym z zs z t [Alt C.DEFAULT [] e]     go _ _                        = measureFail locSym "Does not have a case-of at the top-level"      inlinePreds   = inline (eqType boolTy . GM.expandVarType) -measureFail       :: LocSymbol -> String -> a+measureFail       :: Located LHName -> String -> a measureFail x msg = panic sp e   where     sp            = Just (GM.fSrcSpan x)@@ -240,58 +251,61 @@ varRType :: (Reftable r) => Var -> Located (RRType r) varRType = GM.varLocInfo ofType -coreToFun :: Bool -> LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Var], Either Expr Expr)-coreToFun allowTC _ _v = go [] . normalize allowTC+coreToFun :: LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Var], Either Expr Expr)+coreToFun _ _v s = do +  allowTC <- reader $ typeclass . lsConfig+  go [] $ normalize allowTC s   where-    isE = if allowTC then GM.isEmbeddedDictVar else isErasable-    go acc (C.Lam x e)  | isTyVar    x = go acc e-    go acc (C.Lam x e)  | isE x = go acc e-    go acc (C.Lam x e)  = go (x:acc) e+    go acc (C.Lam x e)  | isTyVar x = go acc e+    go acc (C.Lam x e)  = do +      allowTC <- reader $ typeclass . lsConfig+      let isE = if allowTC then GM.isEmbeddedDictVar else isErasable+      if isE x then go acc e else go (x:acc) e     go acc (C.Tick _ e) = go acc e-    go acc e            = (reverse acc,) . Right <$> coreToLg allowTC e+    go acc e            = (reverse acc,) . Right <$> coreToLg e   instance Show C.CoreExpr where   show = GM.showPpr -coreToLogic :: Bool -> C.CoreExpr -> LogicM Expr-coreToLogic allowTC cb = coreToLg allowTC (normalize allowTC cb)+coreToLogic :: C.CoreExpr -> LogicM Expr+coreToLogic cb = do+  allowTC <- reader $ typeclass . lsConfig+  coreToLg $ normalize allowTC cb  -coreToLg :: Bool -> C.CoreExpr -> LogicM Expr-coreToLg allowTC  (C.Let (C.NonRec x (C.Coercion c)) e)-  = coreToLg allowTC (C.substExpr (C.extendCvSubst C.emptySubst x c) e)-coreToLg allowTC  (C.Let b e)-  = subst1 <$> coreToLg allowTC e <*>  makesub allowTC b-coreToLg allowTC (C.Tick _ e)          = coreToLg allowTC e-coreToLg allowTC (C.App (C.Var v) e)-  | ignoreVar v                = coreToLg allowTC e-coreToLg _allowTC (C.Var x)+coreToLg :: C.CoreExpr -> LogicM Expr+coreToLg (C.Let (C.NonRec x (C.Coercion c)) e)+  = coreToLg (C.substExpr (C.extendCvSubst C.emptySubst x c) e)+coreToLg (C.Let b e)+  = subst1 <$> coreToLg e <*> makesub b+coreToLg (C.Tick _ e)          = coreToLg e+coreToLg (C.App (C.Var v) e)+  | ignoreVar v                = coreToLg e+coreToLg (C.Var x)   | x == falseDataConId        = return PFalse   | x == trueDataConId         = return PTrue-  | otherwise                  = getState >>= eVarWithMap x . lsSymMap-coreToLg allowTC e@(C.App _ _)         = toPredApp allowTC e-coreToLg allowTC (C.Case e b _ alts)-  | eqType (GM.expandVarType b) boolTy  = checkBoolAlts alts >>= coreToIte allowTC e+  | otherwise                  = eVarWithMap x . lsSymMap <$> getState+coreToLg e@(C.App _ _)         = toPredApp e+coreToLg (C.Case e b _ alts)+  | eqType (GM.expandVarType b) boolTy  = checkBoolAlts alts >>= coreToIte e -- coreToLg (C.Lam x e)           = do p     <- coreToLg e --                                     tce   <- lsEmb <$> getState --                                     return $ ELam (symbol x, typeSort tce (GM.expandVarType x)) p-coreToLg allowTC (C.Case e b _ alts)   = do p <- coreToLg allowTC e-                                            casesToLg allowTC b p alts-coreToLg _ (C.Lit l)             = case mkLit l of+coreToLg (C.Case e b _ alts)   = do p <- coreToLg e+                                    casesToLg b p alts+coreToLg (C.Lit l)             = case mkLit l of                                           Nothing -> throw $ "Bad Literal in measure definition" ++ GM.showPpr l                                           Just i  -> return i-coreToLg allowTC (C.Cast e c)          = do (s, t) <- coerceToLg c-                                            e'     <- coreToLg allowTC e-                                            return (ECoerc s t e')+coreToLg (C.Cast e c)          = do (s, t) <- coerceToLg c+                                    e'     <- coreToLg e+                                    return (ECoerc s t e') -- elaboration reuses coretologic -- TODO: fix this-coreToLg True (C.Lam x e) = do p     <- coreToLg True e-                               tce   <- lsEmb <$> getState-                               return $ ELam (symbol x, typeSort tce (GM.expandVarType x)) p-coreToLg _ e@(C.Lam _ _)        = throw ("Cannot transform lambda abstraction to Logic:\t" ++ GM.showPpr e ++-                                            "\n\n Try using a helper function to remove the lambda.")-coreToLg _ e                     = throw ("Cannot transform to Logic:\t" ++ GM.showPpr e)+coreToLg (C.Lam x e) = do p     <- coreToLg e+                          tce   <- lsEmb <$> getState+                          return $ ELam (symbol x, typeSort tce (GM.expandVarType x)) p+coreToLg e                     = throw ("Cannot transform to Logic:\t" ++ GM.showPpr e)   @@ -307,7 +321,7 @@  typeEqToLg :: (Type, Type) -> LogicM (Sort, Sort) typeEqToLg (s, t) = do-  tce   <- gets lsEmb+  tce   <- reader lsEmb   let tx = typeSort tce . expandTypeSynonyms   return $ F.notracepp "TYPE-EQ-TO-LOGIC" (tx s, tx t) @@ -322,8 +336,8 @@ checkBoolAlts alts   = throw ("checkBoolAlts failed on " ++ GM.showPpr alts) -casesToLg :: Bool -> Var -> Expr -> [C.CoreAlt] -> LogicM Expr-casesToLg allowTC v e alts = mapM (altToLg allowTC e) normAlts >>= go+casesToLg :: Var -> Expr -> [C.CoreAlt] -> LogicM Expr+casesToLg v e alts = mapM (altToLg e) normAlts >>= go   where     normAlts       = normalizeAlts alts     go :: [(C.AltCon, Expr)] -> LogicM Expr@@ -348,15 +362,21 @@     (defAlts, ctorAlts) = L.partition isDefault alts     isDefault (Alt c _ _)   = c == C.DEFAULT -altToLg :: Bool -> Expr -> C.CoreAlt -> LogicM (C.AltCon, Expr)-altToLg allowTC de (Alt a@(C.DataAlt d) xs e) = do-  p  <- coreToLg allowTC e-  dm <- gets lsDCMap-  let su = mkSubst $ concat [ dataConProj dm de d x i | (x, i) <- zip (filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs) [1..]]-  return (a, subst su p)+altToLg :: Expr -> C.CoreAlt -> LogicM (C.AltCon, Expr)+altToLg de (Alt a@(C.DataAlt d) xs e) = do+  ctorReflected <- reader (exactDCFlag . lsConfig)+  if not ctorReflected && not (primDataCon d) then do+    throw $  "Cannot lift to logic the constructor `" ++ show d+          ++ "` consider enabling either --exactdc or --reflection"+  else do+    p  <- coreToLg e+    dm <- reader lsDCMap+    allowTC <- reader (typeclass . lsConfig)+    let su = mkSubst $ concat [ dataConProj dm de d x i | (x, i) <- zip (filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs) [1..]]+    return (a, subst su p) -altToLg allowTC _ (Alt a _ e)-  = (a, ) <$> coreToLg allowTC e+altToLg _ (Alt a _ e)+  = (a, ) <$> coreToLg e  dataConProj :: DataConMap -> Expr -> DataCon -> Var -> Int -> [(Symbol, Expr)] dataConProj dm de d x i = [(symbol x, t), (GM.simplesymbol x, t)]@@ -367,41 +387,43 @@ primDataCon :: DataCon -> Bool primDataCon d = d == intDataCon -coreToIte :: Bool -> C.CoreExpr -> (C.CoreExpr, C.CoreExpr) -> LogicM Expr-coreToIte allowTC e (efalse, etrue)-  = do p  <- coreToLg allowTC e-       e1 <- coreToLg allowTC efalse-       e2 <- coreToLg allowTC etrue+coreToIte :: C.CoreExpr -> (C.CoreExpr, C.CoreExpr) -> LogicM Expr+coreToIte e (efalse, etrue)+  = do p  <- coreToLg e+       e1 <- coreToLg efalse+       e2 <- coreToLg etrue        return $ EIte p e2 e1 -toPredApp :: Bool -> C.CoreExpr -> LogicM Expr-toPredApp allowTC p = go . Misc.mapFst opSym . splitArgs allowTC $ p+toPredApp :: C.CoreExpr -> LogicM Expr+toPredApp p = do+  allowTC <- reader (typeclass . lsConfig)+  go . first opSym . splitArgs allowTC $ p   where-    opSym = fmap GM.dropModuleNamesAndUnique . tomaybesymbol+    opSym = tomaybesymbol     go (Just f, [e1, e2])       | Just rel <- M.lookup f brels-      = PAtom rel <$> coreToLg allowTC e1 <*> coreToLg allowTC e2+      = PAtom rel <$> coreToLg e1 <*> coreToLg e2     go (Just f, [e])-      | f == symbol ("not" :: String)-      = PNot <$>  coreToLg allowTC e-      | f == symbol ("len" :: String)-      = EApp (EVar "len") <$> coreToLg allowTC e+      | f == symbol ("GHC.Classes.not" :: String)+      = PNot <$>  coreToLg e     go (Just f, [e1, e2])-      | f == symbol ("||" :: String)-      = POr <$> mapM (coreToLg allowTC) [e1, e2]-      | f == symbol ("&&" :: String)-      = PAnd <$> mapM (coreToLg allowTC) [e1, e2]-      | f == symbol ("==>" :: String)-      = PImp <$> coreToLg allowTC e1 <*> coreToLg allowTC e2-      | f == symbol ("<=>" :: String)-      = PIff <$> coreToLg allowTC e1 <*> coreToLg allowTC e2+      | f == symbol ("GHC.Classes.||" :: String)+      = POr <$> mapM coreToLg [e1, e2]+      | f == symbol ("GHC.Classes.&&" :: String)+      = PAnd <$> mapM coreToLg [e1, e2]+      | f == symbol ("Language.Haskell.Liquid.Prelude.==>" :: String)+      = PImp <$> coreToLg e1 <*> coreToLg e2+      | f == symbol ("Language.Haskell.Liquid.Prelude.<=>" :: String)+      = PIff <$> coreToLg e1 <*> coreToLg e2+      | f == symbol ("GHC.Base.const" :: String)+      = coreToLg e1     go (Just f, [es])-      | f == symbol ("or" :: String)-      = POr  . deList <$> coreToLg allowTC es-      | f == symbol ("and" :: String)-      = PAnd . deList <$> coreToLg allowTC es+      | f == symbol ("GHC.Internal.Data.Foldable.or" :: String)+      = POr  . deList <$> coreToLg es+      | f == symbol ("GHC.Internal.Data.Foldable.and" :: String)+      = PAnd . deList <$> coreToLg es     go (_, _)-      = toLogicApp allowTC p+      = toLogicApp p      deList :: Expr -> [Expr]     deList (EApp (EApp (EVar cons) e) es)@@ -413,16 +435,17 @@     deList e       = [e] -toLogicApp :: Bool -> C.CoreExpr -> LogicM Expr-toLogicApp allowTC e = do+toLogicApp :: C.CoreExpr -> LogicM Expr+toLogicApp e = do+  allowTC <- reader (typeclass . lsConfig)   let (f, es) = splitArgs allowTC e   case f of-    C.Var _ -> do args <- mapM (coreToLg allowTC) es+    C.Var _ -> do args <- mapM coreToLg es                   lmap <- lsSymMap <$> getState                   def  <- (`mkEApp` args) <$> tosymbol f                   (\x -> makeApp def lmap x args) <$> tosymbol' f-    _       -> do fe   <- coreToLg allowTC f-                  args <- mapM (coreToLg allowTC) es+    _       -> do fe   <- coreToLg f+                  args <- mapM coreToLg es                   return $ foldl EApp fe args  makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr@@ -446,54 +469,49 @@   , Just op <- M.lookup (mappendSym (symbol ("GHC.Internal.Num." :: String)) sym) bops   = EBin op e1 e2 -makeApp def lmap f es-  = eAppWithMap lmap f es def+makeApp def lmap f es =+    eAppWithMap lmap (val f) es def   -- where msg = "makeApp f = " ++ show f ++ " es = " ++ show es ++ " def = " ++ show def -eVarWithMap :: Id -> LogicMap -> LogicM Expr+eVarWithMap :: Id -> LogicMap -> Expr eVarWithMap x lmap = do-  f'     <- tosymbol' (C.Var x :: C.CoreExpr)-  -- let msg = "eVarWithMap x = " ++ show x ++ " f' = " ++ show f'-  return $ eAppWithMap lmap f' [] (varExpr x)--varExpr :: Var -> Expr-varExpr x-  | isPolyCst t = mkEApp (dummyLoc s) []-  | otherwise   = EVar s-  where-    t           = GM.expandVarType x-    s           = symbol x--isPolyCst :: Type -> Bool-isPolyCst (ForAllTy _ t) = isCst t-isPolyCst _              = False--isCst :: Type -> Bool-isCst (ForAllTy _ t) = isCst t-isCst FunTy{}        = False-isCst _              = True-+    eAppWithMap lmap (symbol x) [] (EVar $ symbol x)  brels :: M.HashMap Symbol Brel-brels = M.fromList [ (symbol ("==" :: String), Eq)-                   , (symbol ("/=" :: String), Ne)-                   , (symbol (">=" :: String), Ge)-                   , (symbol (">" :: String) , Gt)-                   , (symbol ("<=" :: String), Le)-                   , (symbol ("<" :: String) , Lt)+brels = M.fromList [ (symbol ("GHC.Classes.==" :: String), Eq)+                   , (symbol ("GHC.Classes./=" :: String), Ne)+                   , (symbol ("GHC.Classes.>=" :: String), Ge)+                   , (symbol ("GHC.Classes.>" :: String) , Gt)+                   , (symbol ("GHC.Classes.<=" :: String), Le)+                   , (symbol ("GHC.Classes.<" :: String) , Lt)                    ] +-- bops is a map between GHC function names/symbols and binary operators+-- from the logic. We want GHC functions like +, -, etc. to map to the+-- corresponding operators. There are actually multiple sources for +, -,+-- they can come from GHC.Prim, GHC.Internal.Num, GHC.Internal.Real or+-- be an instance of Num for Int. bops :: M.HashMap Symbol Bop bops = M.fromList [ (numSymbol "+", Plus)+                  , (numIntSymbol "+", Plus)+                  , (primSymbol "+#", Plus)                   , (numSymbol "-", Minus)+                  , (numIntSymbol "-", Minus)+                  , (primSymbol "-#", Minus)                   , (numSymbol "*", Times)+                  , (numIntSymbol "*", Times)+                  , (primSymbol "*#", Times)                   , (numSymbol "/", Div)                   , (realSymbol "/", Div)                   , (numSymbol "%", Mod)                   ]   where+    primSymbol :: String -> Symbol+    primSymbol =  symbol . (++) "GHC.Prim."     numSymbol :: String -> Symbol     numSymbol =  symbol . (++) "GHC.Internal.Num."+    numIntSymbol :: String -> Symbol+    numIntSymbol = numSymbol . (++) "$fNumInt_$c"     realSymbol :: String -> Symbol     realSymbol =  symbol . (++) "GHC.Internal.Real." @@ -521,9 +539,9 @@ tosymbol' (C.Var x) = return $ dummyLoc $ symbol x tosymbol' e        = throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied") -makesub :: Bool -> C.CoreBind -> LogicM (Symbol, Expr)-makesub allowTC (C.NonRec x e) =  (symbol x,) <$> coreToLg allowTC e-makesub _       _              = throw "Cannot make Logical Substitution of Recursive Definitions"+makesub :: C.CoreBind -> LogicM (Symbol, Expr)+makesub (C.NonRec x e) = (symbol x,) <$> coreToLg e+makesub _              = throw "Cannot make Logical Substitution of Recursive Definitions"  mkLit :: Literal -> Maybe Expr mkLit (LitNumber _ n) = mkI n@@ -650,10 +668,10 @@  instance Simplify C.CoreBind where   simplify allowTC (C.NonRec x e) = C.NonRec x (simplify allowTC e)-  simplify allowTC (C.Rec xes)    = C.Rec (Misc.mapSnd (simplify allowTC) <$> xes )+  simplify allowTC (C.Rec xes)    = C.Rec (fmap (simplify allowTC) <$> xes )    inline p (C.NonRec x e) = C.NonRec x (inline p e)-  inline p (C.Rec xes)    = C.Rec (Misc.mapSnd (inline p) <$> xes)+  inline p (C.Rec xes)    = C.Rec (fmap (inline p) <$> xes)  instance Simplify C.CoreAlt where   simplify allowTC (Alt c xs e) = Alt c xs (simplify allowTC e)
− src/Language/Haskell/Liquid/Transforms/Rec.hs 
@@ -1,292 +0,0 @@-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}--module Language.Haskell.Liquid.Transforms.Rec (-     transformRecExpr, transformScope-     , outerScTr , innerScTr-     , isIdTRecBound, setIdTRecBound-     ) where--import           Control.Arrow                        (second)-import           Control.Monad.State-import qualified Data.HashMap.Strict                  as M-import           Data.Hashable-import           Data.Word (Word64)-import           Liquid.GHC.API      as Ghc hiding (panic)-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.GHC.Play-import           Language.Haskell.Liquid.Misc         (mapSndM)-import           Language.Fixpoint.Misc               (mapSnd) -- , traceShow)-import           Language.Haskell.Liquid.Types.Errors-import           Prelude                              hiding (error)--import qualified Data.List                            as L---transformRecExpr :: CoreProgram -> CoreProgram-transformRecExpr cbs = pg-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs | isEmptyBag $ filterBag isTypeError e-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = pg-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs | otherwise-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = panic Nothing ("Type-check" ++ showSDoc (pprMessageBag e))-  where-    pg     = inlineFailCases pg0-    pg0    = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv-    -- (_, e) = lintCoreBindings [] pg-----inlineLoopBreaker :: Bind Id -> Bind Id-inlineLoopBreaker (NonRec x e) | Just (lbx, lbe) <- hasLoopBreaker be-  = Rec [(x, foldr Lam (sub (M.singleton lbx e') lbe) (αs ++ as))]-  where-    (αs, as, be) = collectTyAndValBinders e--    e' = L.foldl' App (L.foldl' App (Var x) (Type . TyVarTy <$> αs)) (Var <$> as)--    hasLoopBreaker (Let (Rec [(x1, e1)]) (Var x2)) | isLoopBreaker x1 && x1 == x2 = Just (x1, e1)-    hasLoopBreaker _                               = Nothing--    isLoopBreaker =  isStrongLoopBreaker . occInfo . idInfo--inlineLoopBreaker bs-  = bs--inlineFailCases :: CoreProgram -> CoreProgram-inlineFailCases = (go [] <$>)-  where-    go su (Rec xes)    = Rec (mapSnd (go' su) <$> xes)-    go su (NonRec x e) = NonRec x (go' su e)--    go' su (App (Var x) _)       | isFailId x, Just e <- getFailExpr x su = e-    go' su (Let (NonRec x ex) e) | isFailId x   = go' (addFailExpr x (go' su ex) su) e--    go' su (App e1 e2)      = App (go' su e1) (go' su e2)-    go' su (Lam x e)        = Lam x (go' su e)-    go' su (Let xs e)       = Let (go su xs) (go' su e)-    go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt)-    go' su (Cast e c)       = Cast (go' su e) c-    go' su (Tick t e)       = Tick t (go' su e)-    go' _  e                = e--    goalt su (Alt c xs e)   = Alt c xs (go' su e)--    isFailId x  = isLocalId x && isSystemName (varName x) && L.isPrefixOf "fail" (show x)-    getFailExpr = L.lookup--    addFailExpr x (Lam _ e) su = (x, e):su-    addFailExpr _ _         _  = impossible Nothing "internal error" -- this cannot happen---- isTypeError :: SDoc -> Bool--- isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False--- isTypeError _ = True---- No need for this transformation after ghc-8!!!-transformScope :: [Bind Id] -> [Bind Id]-transformScope = outerScTr . innerScTr--outerScTr :: [Bind Id] -> [Bind Id]-outerScTr = mapNonRec (go [])-  where-   go ack x (xe : xes) | isCaseArg x xe = go (xe:ack) x xes-   go ack _ xes        = ack ++ xes--isCaseArg :: Id -> Bind t -> Bool-isCaseArg x (NonRec _ (Case (Var z) _ _ _)) = z == x-isCaseArg _ _                               = False--innerScTr :: Functor f => f (Bind Id) -> f (Bind Id)-innerScTr = (mapBnd scTrans <$>)--scTrans :: Id -> Expr Id -> Expr Id-scTrans id' expr = mapExpr scTrans $ foldr Let e0 bindIds-  where (bindIds, e0)           = go [] id' expr-        go bs x (Let b e)  | isCaseArg x b = go (b:bs) x e-        go bs x (Tick t e) = second (Tick t) $ go bs x e-        go bs _ e          = (bs, e)--type TE = State TrEnv--data TrEnv = Tr { freshIndex  :: !Word64-                , _loc        :: SrcSpan-                }--initEnv :: TrEnv-initEnv = Tr 0 noSrcSpan--transPg :: Traversable t-        => t (Bind CoreBndr)-        -> State TrEnv (t (Bind CoreBndr))-transPg = mapM transBd--transBd :: Bind CoreBndr-        -> State TrEnv (Bind CoreBndr)-transBd (NonRec x e) = fmap (NonRec x) (transExpr =<< mapBdM transBd e)-transBd (Rec xes)    = Rec <$> mapM (mapSndM (mapBdM transBd)) xes--transExpr :: CoreExpr -> TE CoreExpr-transExpr e-  | isNonPolyRec e' && not (null tvs)-  = trans tvs ids bs e'-  | otherwise-  = return e-  where (tvs, ids, e'')       = collectTyAndValBinders e-        (bs, e')              = collectNonRecLets e''--isNonPolyRec :: Expr CoreBndr -> Bool-isNonPolyRec (Let (Rec xes) _) = any nonPoly (snd <$> xes)-isNonPolyRec _                 = False--nonPoly :: CoreExpr -> Bool-nonPoly = null . fst . splitForAllTyCoVars . exprType--collectNonRecLets :: Expr t -> ([Bind t], Expr t)-collectNonRecLets = go []-  where go bs (Let b@(NonRec _ _) e') = go (b:bs) e'-        go bs e'                      = (reverse bs, e')--appTysAndIds :: [Var] -> [Id] -> Id -> Expr b-appTysAndIds tvs ids x = mkApps (mkTyApps (Var x) (map TyVarTy tvs)) (map Var ids)--trans :: Foldable t-      => [TyVar]-      -> [Var]-      -> t (Bind Id)-      -> Expr Var-      -> State TrEnv (Expr Id)-trans vs ids bs (Let (Rec xes) expr)-  = fmap (mkLam . mkLet') (makeTrans vs liveIds e')-  where liveIds = mkAlive <$> ids-        mkLet' e = foldr Let e bs-        mkLam e = foldr Lam e $ vs ++ liveIds-        e'      = Let (Rec xes') expr-        xes'    = second mkLet' <$> xes--trans _ _ _ _ = panic Nothing "TransformRec.trans called with invalid input"--makeTrans :: [TyVar]-          -> [Var]-          -> Expr Var-          -> State TrEnv (Expr Var)-makeTrans vs ids (Let (Rec xes) e)- = do fids    <- mapM (mkFreshIds vs ids) xs-      let (ids', ys) = unzip fids-      let yes  = appTysAndIds vs ids <$> ys-      ys'     <- mapM fresh xs-      let su   = M.fromList $ zip xs (Var <$> ys')-      let rs   = zip ys' yes-      let es'  = zipWith (mkE ys) ids' es-      let xes' = zip ys es'-      return   $ mkRecBinds rs (Rec xes') (sub su e)- where-   (xs, es)       = unzip xes-   mkSu ys ids'   = mkSubs ids vs ids' (zip xs ys)-   mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e')--makeTrans _ _ _ = panic Nothing "TransformRec.makeTrans called with invalid input"--mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b-mkRecBinds xes rs expr = Let rs (L.foldl' f expr xes)-  where f e (x, xe) = Let (NonRec x xe) e--mkSubs :: (Eq k, Hashable k)-       => [k] -> [Var] -> [Id] -> [(k, Id)] -> M.HashMap k (Expr b)-mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2-  where s1 = second (appTysAndIds tvs xs) <$> ys-        s2 = zip ids (Var <$> xs)--mkFreshIds :: [TyVar]-           -> [Var]-           -> Var-           -> State TrEnv ([Var], Id)-mkFreshIds tvs origIds var-  = do ids'  <- mapM fresh origIds-       let ids'' = map setIdTRecBound ids'-       let t  = mkForAllTys ((`Bndr` Required) <$> tvs) $ mkType (reverse ids'') $ varType var-       let x' = setVarType var t-       return (ids'', x')-  where-    mkType ids ty = foldl (\t x -> FunTy FTF_T_T ManyTy (varType x) t) ty ids -- FIXME(adinapoli): Is 'VisArg' OK here?---- NOTE [Don't choose transform-rec binders as decreasing params]--- -------------------------------------------------------------------- We don't want to select a binder created by TransformRec as the--- decreasing parameter, since the user didn't write it. Furthermore,--- consider T1065. There we have an inner loop that decreases on the--- sole list parameter. But TransformRec prepends the parameters to the--- outer `groupByFB` to the inner `groupByFBCore`, and now the first--- decreasing parameter is the constant `xs0`. Disaster!------ So we need a way to signal to L.H.L.Constraint.Generate that we--- should ignore these copied Vars. The easiest way to do that is to set--- a flag on the Var that we know won't be set, and it just so happens--- GHC has a bunch of optional flags that can be set by various Core--- analyses that we don't run...-setIdTRecBound :: Id -> Id--- This is an ugly hack..-setIdTRecBound = modifyIdInfo (`setCafInfo` NoCafRefs)--isIdTRecBound :: Id -> Bool-isIdTRecBound = not . mayHaveCafRefs . cafInfo . idInfo--class Freshable a where-  fresh :: a -> TE a--instance Freshable Word64 where-  fresh _ = freshWord64--instance Freshable Unique where-  fresh _ = freshUnique--instance Freshable Var where-  fresh v = fmap (setVarUnique v) freshUnique--freshWord64 :: MonadState TrEnv m => m Word64-freshWord64-  = do s <- get-       let n = freshIndex s-       put s{freshIndex = n+1}-       return n--freshUnique :: MonadState TrEnv m => m Unique-freshUnique = fmap (mkUnique 'X') freshWord64---mapNonRec :: (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]-mapNonRec f (NonRec x xe:xes) = NonRec x xe : f x (mapNonRec f xes)-mapNonRec f (xe:xes)          = xe : mapNonRec f xes-mapNonRec _ []                = []--mapBnd :: (b -> Expr b -> Expr b) -> Bind b -> Bind b-mapBnd f (NonRec b e)             = NonRec b (mapExpr f  e)-mapBnd f (Rec bs)                 = Rec (map (second (mapExpr f)) bs)--mapExpr :: (b -> Expr b -> Expr b) -> Expr b -> Expr b-mapExpr f (Let (NonRec x ex) e)   = Let (NonRec x (f x ex) ) (f x e)-mapExpr f (App e1 e2)             = App  (mapExpr f e1) (mapExpr f e2)-mapExpr f (Lam b e)               = Lam b (mapExpr f e)-mapExpr f (Let bs e)              = Let (mapBnd f bs) (mapExpr f e)-mapExpr f (Case e b t alt)        = Case e b t (map (mapAlt f) alt)-mapExpr f (Tick t e)              = Tick t (mapExpr f e)-mapExpr _  e                      = e--mapAlt :: (b -> Expr b -> Expr b) -> Alt b -> Alt b-mapAlt f (Alt d bs e) = Alt d bs (mapExpr f e)---- Do not apply transformations to inner code--mapBdM :: Monad m => t -> a -> m a-mapBdM _ = return---- mapBdM f (Let b e)        = liftM2 Let (f b) (mapBdM f e)--- mapBdM f (App e1 e2)      = liftM2 App (mapBdM f e1) (mapBdM f e2)--- mapBdM f (Lam b e)        = liftM (Lam b) (mapBdM f e)--- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt)--- mapBdM f (Tick t e)       = liftM (Tick t) (mapBdM f e)--- mapBdM _  e               = return  e------ mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e)
src/Language/Haskell/Liquid/Transforms/RefSplit.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE UndecidableInstances #-} @@ -12,9 +13,8 @@ import Prelude hiding (error)  import Data.List (partition)-import Text.PrettyPrint.HughesPJ -import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.RType import Language.Haskell.Liquid.Types.PrettyPrint ()  import Language.Fixpoint.Types hiding (Predicate)@@ -109,6 +109,3 @@  instance (Subable x) => (IsFree x) where         isFree x p = x `elem` syms p--instance Show (UReft Reft) where-         show = render . pprint
src/Language/Haskell/Liquid/Transforms/Rewrite.hs view
@@ -24,17 +24,14 @@    ) where -import           Liquid.GHC.API as Ghc hiding (showPpr, substExpr)+import           Liquid.GHC.API as Ghc hiding (get, showPpr, substExpr) import           Language.Haskell.Liquid.GHC.TypeRep ()-import           Data.Maybe     (fromMaybe)-import           Control.Monad (msum)+import           Data.Maybe     (fromMaybe, isJust, mapMaybe) import           Control.Monad.State hiding (lift)-import           Language.Fixpoint.Misc       ({- mapFst, -}  mapSnd)-import qualified          Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Misc (safeZipWithError, Nat)-import           Language.Haskell.Liquid.GHC.Play (substExpr)-import           Language.Haskell.Liquid.GHC.Resugar-import           Language.Haskell.Liquid.GHC.Misc (unTickExpr, isTupleId, showPpr, mkAlive) -- , showPpr, tracePpr)+import           Language.Haskell.Liquid.Misc (Nat)+import           Language.Haskell.Liquid.GHC.Play (sub, substExpr)+import           Language.Haskell.Liquid.GHC.Misc (unTickExpr, isTupleId, mkAlive)+import           Language.Haskell.Liquid.Types.Errors (impossible) import           Language.Haskell.Liquid.UX.Config  (Config, noSimplifyCore) import qualified Data.List as L import qualified Data.HashMap.Strict as M@@ -46,9 +43,12 @@ rewriteBinds cfg   | simplifyCore cfg   = fmap (normalizeTuples -       . rewriteBindWith undollar -       . rewriteBindWith tidyTuples -       . rewriteBindWith simplifyPatTuple)+       . rewriteBindWith undollar+       . tidyTuples+       . rewriteBindWith inlineLoopBreakerTx+       . inlineLoopBreaker+       . rewriteBindWith strictifyLazyLets+       . inlineFailCases)   | otherwise   = id @@ -56,38 +56,15 @@ simplifyCore = not . noSimplifyCore  undollar :: RewriteRule-undollar = go-  where-    go e-     | Just (f, a) <- splitDollarApp e-     = Just $ App f a-    go (Tick t e)-      = Tick t <$> go e-    go (Let (NonRec x ex) e)-      = do ex' <- go ex-           e'  <- go e-           return $ Let (NonRec x ex') e'-    go (Let (Rec bes) e)-      = Let <$> (Rec <$> mapM goRec bes) <*> go e-    go (Case e x t alts)-      = Case e x t <$> mapM goAlt alts-    go (App e1 e2)-      = App <$> go e1 <*> go e2-    go (Lam x e)-      = Lam x <$> go e-    go (Cast e c)-      = (`Cast` c) <$> go e-    go e-      = return e--    goRec (x, e)-      = (x,) <$> go e--    goAlt (Alt c bs e)-      = Alt c bs <$> go e+undollar e+    | Just (f, a) <- splitDollarApp e =+      Just $ App f a+    | otherwise = Nothing -tidyTuples :: RewriteRule-tidyTuples ce = Just $ evalState (go ce) []+tidyTuples :: CoreBind -> CoreBind+tidyTuples ce = case ce of+   NonRec x e -> NonRec x (evalState (go e) [])+   Rec xs -> Rec $ map (fmap (\e -> evalState (go e) [])) xs   where     go (Tick t e)       = Tick t <$> go e@@ -142,7 +119,7 @@     go (Let (NonRec x ex) e)       = Let (NonRec x (go ex)) (go e)     go (Let (Rec xes) e)-      = Let (Rec (mapSnd go <$> xes)) (go e)+      = Let (Rec (fmap go <$> xes)) (go e)     go (App e1 e2)       = App (go e1) (go e2)     go (Lam x e)@@ -173,16 +150,16 @@ rewriteBindWith :: RewriteRule -> CoreBind -> CoreBind -------------------------------------------------------------------------------- rewriteBindWith r (NonRec x e) = NonRec x (rewriteWith r e)-rewriteBindWith r (Rec xes)    = Rec    (mapSnd (rewriteWith r) <$> xes)+rewriteBindWith r (Rec xes)    = Rec    (fmap (rewriteWith r) <$> xes)  -------------------------------------------------------------------------------- rewriteWith :: RewriteRule -> CoreExpr -> CoreExpr -------------------------------------------------------------------------------- rewriteWith tx           = go   where-    go                   = txTop . step+    go                   = step . txTop     txTop e              = fromMaybe e (tx e)-    goB (Rec xes)        = Rec         (mapSnd go <$> xes)+    goB (Rec xes)        = Rec         (fmap go <$> xes)     goB (NonRec x e)     = NonRec x    (go e)     step (Let b e)       = Let (goB b) (go e)     step (App e e')      = App (go e)  (go e')@@ -200,252 +177,107 @@ -- | Rewriting Pattern-Match-Tuples -------------------------------------------- -------------------------------------------------------------------------------- -{--    let CrazyPat x1 ... xn = e in e'--    let t : (t1,...,tn) = "CrazyPat e ... (y1, ..., yn)"-        xn = Proj t n-        ...-        x1 = Proj t 1-    in-        e'--    "crazy-pat"- -}--{- [NOTE] The following is the structure of a @PatMatchTup@--      let x :: (t1,...,tn) = E[(x1,...,xn)]-          yn = case x of (..., yn) -> yn-          …-          y1 = case x of (y1, ...) -> y1-      in-          E'--  GOAL: simplify the above to:--      E [ (x1,...,xn) := E' [y1 := x1,...,yn := xn] ]--  TODO: several tests (e.g. tests/pos/zipper000.hs) fail because-  the above changes the "type" the expression `E` and in "other branches"-  the new type may be different than the old, e.g.--     let (x::y::_) = e in-     x + y--     let t = case e of-               h1::t1 -> case t1 of-                            (h2::t2) ->  (h1, h2)-                            DEFAULT  ->  error @ (Int, Int)-               DEFAULT   -> error @ (Int, Int)-         x = case t of (h1, _) -> h1-         y = case t of (_, h2) -> h2-     in-         x + y--  is rewritten to:--              h1::t1    -> case t1 of-                            (h2::t2) ->  h1 + h2-                            DEFAULT  ->  error @ (Int, Int)-              DEFAULT   -> error @ (Int, Int)--     case e of-       h1 :: h2 :: _ -> h1 + h2-       DEFAULT       -> error @ (Int, Int)--  which, alas, is ill formed.---}-------------------------------------------------------------------------------------- simplifyPatTuple :: RewriteRule--- simplifyPatTuple e =---  case simplifyPatTuple' e of---    Just e' -> if Ghc.exprType e == Ghc.exprType e'---                 then Just e'---                 else Just (tracePpr ("YIKES: RWR " ++ showPpr e) e')---    Nothing -> Nothing+-- | Transforms+--+-- > let ds = case e0 of+-- >            pat -> (x1,...,xn)+-- >     y1 = proj1 ds+-- >     ...+-- >     yn = projn ds+-- >  in e1+--+--  to+--+-- > case e0 of+-- >   pat -> e1[y1 := x1,..., yn := xn]+--+-- Note that the transformation changes the meaning of the expression if+-- evaluation order matters. But it changes it in a way that LH cannot+-- distinguish.+--+-- Also transforms a variant of the above+--+-- > let y1 = case v of+-- >            C x1 ... xn -> xi+-- >     y2 = proj2 v+-- >     ...+-- >     yn = projn v+-- >  in e1+--+--  to+--+-- > case v of+-- >   C x1 ... xn -> e1[y1 := x1,..., yn := xn]+--+-- The purpose of the transformations is to unpack all of the variables in+-- @pat@ at once in a single scope when verifying @e1@, which allows LH to+-- see the dependencies between the fields of @pat@.+--+strictifyLazyLets :: RewriteRule+strictifyLazyLets (Let (NonRec x e@(Case _ _ _ [Alt (DataAlt _) _ _])) rest)+  | Just (bs, bs') <- onlyHasATupleInNestedCases e+  , null (bs' L.\\ bs) -- All variables are from the pattern and occur only once+  , let n = length bs'+  , n > 1+  =+    let (nrbinds, e') = takeBinds n rest+        fields = [ (isProjectionOf x ce, b) | b@(_, ce) <- nrbinds ]+        (projs, otherBinds) = L.partition (isJust . fst) fields+        ss = [ (bs' !! i, v) | (Just i, (v, _)) <- projs ]+        e'' = foldr (\(_, (v, ce)) -> Let (NonRec v ce)) e' otherBinds+     in Just $ Let (NonRec x e) $+        replaceAltInNestedCases (Ghc.exprType e') ss e'' e +strictifyLazyLets (Let (NonRec x e@(Case e0 _ _ [Alt (DataAlt _) bs _])) rest)+  | Just v0 <- isVar e0+  , Just i0 <- isProjectionOf v0 e+  , let n = length bs+  , n > 1+  =+    let (nrbinds, e') = takeBinds (n - 1) rest+        fields = [ (isProjectionOf v0 ce, b) | b@(_, ce) <- nrbinds ]+        (projs, otherBinds) = L.partition (isJust . fst) fields+        ss = [ (bs !! i, v) | (Just i, (v, _)) <- (Just i0, (x, e)) : projs ]+        e'' = foldr (\(_, (v, ce)) -> Let (NonRec v ce)) e' otherBinds+     in Just $ replaceAltInNestedCases (Ghc.exprType e') ss e'' e -_safeSimplifyPatTuple :: RewriteRule-_safeSimplifyPatTuple e-  | Just e' <- simplifyPatTuple e-  , Ghc.exprType e' == Ghc.exprType e-  = Just e'-  | otherwise+strictifyLazyLets _   = Nothing ----------------------------------------------------------------------------------simplifyPatTuple :: RewriteRule-----------------------------------------------------------------------------------_tidyAlt :: Int -> Maybe CoreExpr -> Maybe CoreExpr--_tidyAlt n (Just (Let (NonRec cb expr) rest))-  | Just (yes, e') <- takeBinds n rest-  = Just $ Let (NonRec cb expr) $ foldl (\e (x, ex) -> Let (NonRec x ex) e) e' (reverse $ go $ reverse yes)-+-- | Replaces an expression at the end of a sequence of nested cases with a+-- single alternative.+replaceAltInNestedCases+  :: Type+  -> [(Var, Var)]+  -> CoreExpr -- ^ The expression to place at the end of the nested cases+  -> CoreExpr -- ^ The expression with the nested cases+  -> CoreExpr+replaceAltInNestedCases t ss ef = go   where-    go xes@((_, e):_) = let bs = grapBinds e in mapSnd (replaceBinds bs) <$> xes-    go [] = []-    replaceBinds bs (Case c x t alt) = Case c x t (replaceBindsAlt bs <$> alt)-    replaceBinds bs (Tick t e)       = Tick t (replaceBinds bs e)-    replaceBinds _ e                 = e-    replaceBindsAlt bs (Alt c _ e)     = Alt c bs e+    go (Case e0 v _ [Alt c bs e1]) =+      let bs' = [ fromMaybe b (lookup b ss) | b <- bs ]+       in Case e0 v t [Alt c bs' (go e1)]+    go _ = ef -    grapBinds (Case _ _ _ alt) = grapBinds' alt-    grapBinds (Tick _ e) = grapBinds e-    grapBinds _ = []-    grapBinds' [] = []-    grapBinds' (Alt _ bs _ : _) = bs -_tidyAlt _ e-  = e--simplifyPatTuple (Let (NonRec x e) rest)-  | Just (n, ts  ) <- varTuple x-  , 2 <= n-  , Just (yes, e') <- takeBinds n rest-  , let ys          = fst <$> yes-  , Just _         <- hasTuple ys e-  , matchTypes yes ts-  = replaceTuple ys e e'--simplifyPatTuple _-  = Nothing--varTuple :: Var -> Maybe (Int, [Type])-varTuple x-  | TyConApp c ts <- Ghc.varType x-  , isTupleTyCon c-  = Just (length ts, ts)-  | otherwise-  = Nothing--takeBinds  :: Nat -> CoreExpr -> Maybe ([(Var, CoreExpr)], CoreExpr)-takeBinds nat ce-  | nat < 2     = Nothing-  | otherwise = {- mapFst reverse <$> -} go nat ce+-- | Takes at most n binds from an expression that starts with n non-recursive+-- lets.+takeBinds  :: Nat -> CoreExpr -> ([(Var, CoreExpr)], CoreExpr)+takeBinds nat ce = go nat ce     where-      go 0 e                      = Just ([], e)-      go n (Let (NonRec x e) e')  = do (xes, e'') <- go (n-1) e'-                                       Just ((x,e) : xes, e'')-      go _ _                      = Nothing--matchTypes :: [(Var, CoreExpr)] -> [Type] -> Bool-matchTypes xes ts =  xN == tN-                  && all (uncurry eqType) (safeZipWithError msg xts ts)-                  && all isProjection es-  where-    xN            = length xes-    tN            = length ts-    xts           = Ghc.varType <$> xs-    (xs, es)      = unzip xes-    msg           = "RW:matchTypes"--isProjection :: CoreExpr -> Bool-isProjection e = case lift e of-                   Just PatProject{} -> True-                   _                 -> False------------------------------------------------------------------------------------- | `hasTuple ys e` CHECKS if `e` contains a tuple that "looks like" (y1...yn)----------------------------------------------------------------------------------hasTuple :: [Var] -> CoreExpr -> Maybe [Var]----------------------------------------------------------------------------------hasTuple ys = stepE-  where-    stepE e-     | Just xs <- isVarTup ys e = Just xs-     | otherwise                = go e-    stepA (Alt DEFAULT _ _)     = Nothing-    stepA (Alt _ _ e)           = stepE e-    go (Let _ e)                = stepE e-    go (Case _ _ _ cs)          = msum (stepA <$> cs)-    go _                        = Nothing------------------------------------------------------------------------------------- | `replaceTuple ys e e'` REPLACES tuples that "looks like" (y1...yn) with e'-----------------------------------------------------------------------------------replaceTuple :: [Var] -> CoreExpr -> CoreExpr -> Maybe CoreExpr-replaceTuple ys ce ce'           = stepE ce-  where-    t'                          = Ghc.exprType ce'-    stepE e-     | Just xs <- isVarTup ys e = Just $ substTuple xs ys ce'-     | otherwise                = go e-    stepA (Alt DEFAULT xs err)  = Just (Alt DEFAULT xs (replaceIrrefutPat t' err))-    stepA (Alt c xs e)          = Alt c xs   <$> stepE e-    go (Let b e)                = Let b      <$> stepE e-    go (Case e x t cs)          = fixCase e x t <$> mapM stepA cs-    go _                        = Nothing--_showExpr :: CoreExpr -> String-_showExpr = show'-  where-    show' (App e1 e2) = show' e1 ++ " " ++ show' e2-    show' (Var x)     = _showVar x-    show' (Let (NonRec x ex) e) = "Let " ++ _showVar x ++ " = " ++ show' ex ++ "\nIN " ++ show' e-    show' (Tick _ e) = show' e-    show' (Case e x _ alt) = "Case " ++ _showVar x ++ " = " ++ show' e ++ " OF " ++ unlines (showAlt' <$> alt)-    show' e           = showPpr e--    showAlt' (Alt c bs e) = showPpr c ++ unwords (_showVar <$> bs) ++ " -> " ++ show' e--_showVar :: Var -> String-_showVar = show . F.symbol--_errorSkip :: String -> a -> b-_errorSkip x _ = error x---- replaceTuple :: [Var] -> CoreExpr -> CoreExpr -> Maybe CoreExpr--- replaceTuple ys e e' = tracePpr msg (_replaceTuple ys e e')---  where---    msg = "replaceTuple: ys = " ++ showPpr ys ++---                        " e = " ++ showPpr e  ++---                        " e' =" ++ showPpr e'---- | The substitution (`substTuple`) can change the type of the overall---   case-expression, so we must update the type of each `Case` with its---   new, possibly updated type. See:---   https://github.com/ucsd-progsys/liquidhaskell/pull/752#issuecomment-228946210--fixCase :: CoreExpr -> Var -> Type -> ListNE (Alt Var) -> CoreExpr-fixCase e x _t cs' = Case e x t' cs'-  where-    t'            = Ghc.exprType body-    Alt _ _ body  = c-    c:_           = cs'--{-@  type ListNE a = {v:[a] | len v > 0} @-}-type ListNE a = [a]--replaceIrrefutPat :: Type -> CoreExpr -> CoreExpr-replaceIrrefutPat t (App (Lam z e) eVoid)-  | Just e' <- replaceIrrefutPat' t e-  = App (Lam z e') eVoid--replaceIrrefutPat t e-  | Just e' <- replaceIrrefutPat' t e-  = e'--replaceIrrefutPat _ e-  = e--replaceIrrefutPat' :: Type -> CoreExpr -> Maybe CoreExpr-replaceIrrefutPat' t e-  | (Var x, rep:_:args) <- collectArgs e-  , isIrrefutErrorVar x-  = Just (Ghc.mkCoreApps (Var x) (rep : Type t : args))-  | otherwise-  = Nothing+      go 0 e = ([], e)+      go n (Let (NonRec x e) e') =+        let (xes, e'') = go (n-1) e'+         in ((x,e) : xes, e'')+      go _ e = ([], e) -isIrrefutErrorVar :: Var -> Bool--- isIrrefutErrorVar _x = False -- Ghc.iRREFUT_PAT_ERROR_ID == x -- TODO:GHC-863-isIrrefutErrorVar x = x == Ghc.pAT_ERROR_ID+-- | Checks that the binding is a projections of some data constructor.+-- | Yields the index of the field being projected+isProjectionOf :: Var -> CoreExpr -> Maybe Int+isProjectionOf v (Case xe _ _ [Alt (DataAlt _) ys (Var y)])+  | Just xv <- isVar xe+  , v == xv = y `L.elemIndex` ys+isProjectionOf _ _ = Nothing  -------------------------------------------------------------------------------- -- | `substTuple xs ys e'` returns e' [y1 := x1,...,yn := xn]@@ -453,21 +285,20 @@ substTuple :: [Var] -> [Var] -> CoreExpr -> CoreExpr substTuple xs ys = substExpr (M.fromList $ zip ys xs) ------------------------------------------------------------------------------------ | `isVarTup xs e` returns `Just ys` if e == (y1, ... , yn) and xi ~ yi-----------------------------------------------------------------------------------isVarTup :: [Var] -> CoreExpr -> Maybe [Var]-isVarTup xs e-  | Just ys <- isTuple e-  , eqVars xs ys        = Just ys-isVarTup _ _             = Nothing--eqVars :: [Var] -> [Var] -> Bool-eqVars xs ys = {- F.tracepp ("eqVars: " ++ show xs' ++ show ys') -} xs' == ys'+-- | Yields the tuple of variables at the end of nested cases with+-- a single alternative each.+--+-- > case e0 of+-- >   pat0 -> case e1 of+-- >     pat1 -> (x1,...,xn)+--+-- Yields both the bound variables of the patterns, and the+-- variables @x1,...,xn@+onlyHasATupleInNestedCases :: CoreExpr -> Maybe ([Var], [Var])+onlyHasATupleInNestedCases = go []   where-    xs' = {- F.symbol -} show <$> xs-    ys' = {- F.symbol -} show <$> ys+    go bss (Case _ _ _ [Alt (DataAlt _) bs e]) = go (bs:bss) e+    go bss e = (concat bss,) <$> isTuple e  isTuple :: CoreExpr -> Maybe [Var] isTuple e@@ -480,9 +311,102 @@  isVar :: CoreExpr -> Maybe Var isVar (Var x) = Just x+isVar (Tick _ e) = isVar e isVar _       = Nothing  secondHalf :: [a] -> [a] secondHalf xs = drop (n `div` 2) xs   where     n         = length xs+++inlineLoopBreakerTx :: RewriteRule+inlineLoopBreakerTx (Let b e) = Just $ Let (inlineLoopBreaker b) e+inlineLoopBreakerTx _ = Nothing++-- | Changes top level bindings of the form+--+-- > v = \x1...xn ->+-- >   letrec v0 = \y0...ym -> e0+-- >       in v0 xj..xn+--+-- to+--+-- > v = \x1...xj y0...ym ->+-- >   e0 [ v0 := v x1...xj y0...ym ]+--+inlineLoopBreaker :: Bind Id -> Bind Id+inlineLoopBreaker (NonRec x e)+    | Just (lbx, lbe, lbargs) <- hasLoopBreaker be =+       let asPrefix = take (length as - length lbargs) as+           lbe' = sub (M.singleton lbx (ecall asPrefix)) lbe+        in Rec [(x, mkLams (αs ++ asPrefix) (mkLets nrbinds lbe'))]+  where+    (αs, as, e') = collectTyAndValBinders e+    (nrbinds, be) = collectNonRecLets e'++    ecall xs = L.foldl' App (L.foldl' App (Var x) (Type . TyVarTy <$> αs)) (Var <$> xs)++    hasLoopBreaker :: CoreExpr -> Maybe (Var, CoreExpr, [CoreExpr])+    hasLoopBreaker (Let (Rec [(x1, e1)]) e2)+      | not (isNoInlinePragma (idInlinePragma x1))+      , (Var x2, args) <- collectArgs e2+      , isLoopBreaker x1+      , x1 == x2+      , all (isJust . isVar) args+      , L.isSuffixOf (mapMaybe getVar args) as+      = Just (x1, e1, args)+    hasLoopBreaker _ = Nothing++    isLoopBreaker =  isStrongLoopBreaker . occInfo . idInfo++    getVar (Var v) = Just v+    getVar _ = Nothing++inlineLoopBreaker bs+  = bs++collectNonRecLets :: Expr t -> ([Bind t], Expr t)+collectNonRecLets = go []+  where go bs (Let b@(NonRec _ _) e') = go (b:bs) e'+        go bs e'                      = (reverse bs, e')++-- | Inlines bindings of the form+--+-- > let v = \x -> e0+-- >  in e1+--+-- whenever all of the following hold:+--  * "fail" is a prefix of variable @v@,+--  * @x@ is not free in @e0@, and+--  * v is applied to some value in @e1@.+--+-- In addition to inlining, this function also beta reduces+-- the resulting expressions @(\x -> e0) a@ by replacing them+-- with @e0@.+--+inlineFailCases :: CoreBind -> CoreBind+inlineFailCases = go []+  where+    go su (Rec xes)    = Rec (fmap (go' su) <$> xes)+    go su (NonRec x e) = NonRec x (go' su e)++    go' su (App (Var x) _)       | isFailId x, Just e <- getFailExpr x su = e+    go' su (Let (NonRec x ex) e) | isFailId x   = go' (addFailExpr x (go' su ex) su) e++    go' su (App e1 e2)      = App (go' su e1) (go' su e2)+    go' su (Lam x e)        = Lam x (go' su e)+    go' su (Let xs e)       = Let (go su xs) (go' su e)+    go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt)+    go' su (Cast e c)       = Cast (go' su e) c+    go' su (Tick t e)       = Tick t (go' su e)+    go' _  e                = e++    goalt su (Alt c xs e)   = Alt c xs (go' su e)++    isFailId x  = isLocalId x && isSystemName (varName x) && L.isPrefixOf "fail" (getOccString x)+    getFailExpr = L.lookup++    addFailExpr x (Lam v e) su+      | not (elemVarSet v $ exprFreeVars e)  = (x, e):su+    addFailExpr _ _         _  = impossible Nothing "internal error" -- this cannot happen
src/Language/Haskell/Liquid/Transforms/Simplify.hs view
@@ -1,7 +1,7 @@ module Language.Haskell.Liquid.Transforms.Simplify (simplifyBounds) where  import Prelude hiding (error)-import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.RType import Language.Fixpoint.Types import Language.Fixpoint.Types.Visitor -- import Control.Applicative                 ((<$>))@@ -17,7 +17,7 @@ dropBoundLike :: Expr -> Expr dropBoundLike p   | isKvar p          = p-  | isBoundLikePred p = mempty+  | isBoundLikePred p = PTrue   | otherwise         = p   where     isKvar            = not . null . kvarsExpr
− src/Language/Haskell/Liquid/Types.hs 
@@ -1,17 +0,0 @@--- | This module re-exports a bunch of the Types modules --module Language.Haskell.Liquid.Types (module Types) where --import Language.Haskell.Liquid.Types.Types          as Types-import Language.Haskell.Liquid.Types.Dictionaries   as Types-import Language.Haskell.Liquid.Types.Fresh          as Types-import Language.Haskell.Liquid.Types.Meet           as Types-import Language.Haskell.Liquid.Types.PredType       as Types-import Language.Haskell.Liquid.Types.RefType        as Types-import Language.Haskell.Liquid.Types.Variance       as Types-import Language.Haskell.Liquid.Types.Bounds         as Types-import Language.Haskell.Liquid.Types.Literals       as Types-import Language.Haskell.Liquid.Types.Names          as Types-import Language.Haskell.Liquid.Types.PrettyPrint    as Types-import Language.Haskell.Liquid.Types.Specs          as Types-import Language.Haskell.Liquid.Types.Visitors       as Types
src/Language/Haskell/Liquid/Types/Bounds.hs view
@@ -2,7 +2,10 @@ {-# LANGUAGE TupleSections      #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable  #-} {-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DerivingVia        #-}+{-# LANGUAGE NamedFieldPuns     #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -10,11 +13,13 @@      Bound(..), -    RBound, RRBound,+    RBound, RRBound, RRBoundV, -    RBEnv, RRBEnv,+    RBEnv, RRBEnv, RRBEnvV,      makeBound,+    emapBoundM,+    mapBoundTy      ) where @@ -24,15 +29,18 @@ import Data.List (partition) import Data.Maybe import Data.Hashable-import Data.Bifunctor+import Data.Bifunctor as Bifunctor import Data.Data import qualified Data.Binary         as B+import Data.Traversable import qualified Data.HashMap.Strict as M  import qualified Language.Fixpoint.Types as F-import qualified Language.Fixpoint.Misc  as Misc -- (mapFst, mapSnd)-import Language.Haskell.Liquid.Types.Types+import Language.Haskell.Liquid.Types.Errors import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Types.RType+import Language.Haskell.Liquid.Types.RTypeOp+import Language.Haskell.Liquid.Types.Types   data Bound t e = Bound@@ -41,16 +49,38 @@   , bparams :: [(LocSymbol, t)]  -- ^ These are abstract refinements, for now   , bargs   :: [(LocSymbol, t)]  -- ^ These are value variables   , bbody   :: e                 -- ^ The body of the bound-  } deriving (Data, Typeable, Generic)--instance (B.Binary t, B.Binary e) => B.Binary (Bound t e)+  } deriving (Data, Typeable, Generic, Functor, Foldable, Traversable)+  deriving B.Binary via Generically (Bound t e)  type RBound        = RRBound RSort-type RRBound tv    = Bound tv F.Expr+type RRBound tv    = RRBoundV F.Symbol tv+type RRBoundV v tv = Bound tv (F.ExprV v) type RBEnv         = M.HashMap LocSymbol RBound type RRBEnv tv     = M.HashMap LocSymbol (RRBound tv)+type RRBEnvV v tv     = M.HashMap LocSymbol (RRBoundV v tv) +emapBoundM+  :: Monad m+  => ([F.Symbol] -> t0 -> m t1)+  -> ([F.Symbol] -> e0 -> m e1)+  -> Bound t0 e0+  -> m (Bound t1 e1)+emapBoundM f g b = do+    tyvars <- mapM (f []) $ tyvars b+    (e1, bparams) <- mapAccumM (\e -> fmap (e,) . traverse (f e)) [] (bparams b)+    (e2, bargs) <- mapAccumM (\e -> fmap (e,) . traverse (f e)) e1 (bargs b)+    bbody <- g e2 (bbody b)+    return b{tyvars, bparams, bargs, bbody} +mapBoundTy :: (t0 -> t1) -> Bound t0 e -> Bound t1 e+mapBoundTy f Bound{..} = do+    Bound+      { tyvars = map f tyvars+      , bparams = map (fmap f) bparams+      , bargs = map (fmap f) bargs+      , ..+      }+ instance Hashable (Bound t e) where   hashWithSalt i = hashWithSalt i . bname @@ -70,11 +100,8 @@       ppBsyms _ [] = ""       ppBsyms k' xs = "\\" <+> pprintTidy k' xs <+> "->" -instance Functor (Bound a) where-  fmap f (Bound s vs ps xs e) = Bound s vs ps xs (f e)- instance Bifunctor Bound where-  first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (Misc.mapSnd f <$> ps) (Misc.mapSnd f <$> xs) e+  first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (fmap f <$> ps) (fmap f <$> xs) e   second = fmap  makeBound :: (PPrint r, UReftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r)@@ -107,7 +134,7 @@     go [(x, t)]      = [(F.dummySymbol, tp t x), (F.dummySymbol, tq t x)]     go ((x, t):xtss) = (val x, mkt t x) : go xtss -    mkt t x = ofRSort t `strengthen` ofUReft (MkUReft (F.Reft (val x, mempty))+    mkt t x = ofRSort t `strengthen` ofUReft (MkUReft (F.Reft (val x, F.PTrue))                                                 (Pr $ M.lookupDefault [] (val x) ps))     tp t x  = ofRSort t `strengthen` ofUReft (MkUReft (F.Reft (val x, F.pAnd rs))                                                 (Pr $ M.lookupDefault [] (val x) ps))@@ -121,7 +148,7 @@   partitionPs :: [(F.Symbol, F.Symbol)] -> [F.Expr] -> (M.HashMap F.Symbol [UsedPVar], [F.Expr])-partitionPs penv qs = Misc.mapFst makeAR $ partition (isPApp penv) qs+partitionPs penv qs = Bifunctor.first makeAR $ partition (isPApp penv) qs   where     makeAR ps       = M.fromListWith (++) $ map (toUsedPVars penv) ps @@ -139,7 +166,7 @@  toUsedPVar :: [(F.Symbol, F.Symbol)] -> F.Expr -> PVar () toUsedPVar penv ee@(F.EApp _ _)-  = PV q (PVProp ()) e (((), F.dummySymbol,) <$> es')+  = PV q () e (((), F.dummySymbol,) <$> es')    where      F.EVar e = {- unProp $ -} last es      es'    = init es@@ -158,8 +185,8 @@     (pps, rrs)           = partition (isPApp penv) rs  makeRef penv v rr-  | isPApp penv rr       = ofUReft (MkUReft (F.Reft(val v, mempty)) r)+  | isPApp penv rr       = ofUReft (MkUReft (F.Reft(val v, F.PTrue)) r)   where     r                    = Pr [toUsedPVar penv rr] -makeRef _    v p         = F.ofReft (F.Reft (val v, p))+makeRef _    v p         = ofReft (F.Reft (val v, p))
+ src/Language/Haskell/Liquid/Types/DataDecl.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE DeriveTraversable          #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module contains types to represent refined data types.++module Language.Haskell.Liquid.Types.DataDecl (++  -- * Parse-time entities describing refined data types+    DataDecl+  , DataDeclLHName+  , DataDeclParsed+  , DataDeclP (..)+  , DataName (..), dataNameSymbol+  , DataCtor+  , DataCtorParsed+  , DataCtorP (..)+  , DataConP (..)+  , HasDataDecl (..), hasDecl+  , DataDeclKind (..)+  , TyConP   (..)++  )+  where++import qualified Liquid.GHC.API as Ghc+import           GHC.Generics+import           Prelude                          hiding  (error)++import           Control.DeepSeq+import           Data.Typeable                          (Typeable)+import           Data.Generics                          (Data)+import qualified Data.Binary                            as B+import           Data.Hashable+import           Text.PrettyPrint.HughesPJ              hiding (first, (<>))+import           Text.Printf++import qualified Language.Fixpoint.Types as F++import           Language.Haskell.Liquid.GHC.Misc+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+++--------------------------------------------------------------------------------+-- | Data type refinements+--------------------------------------------------------------------------------+type DataDecl = DataDeclP F.Symbol BareType+type DataDeclParsed = DataDeclP F.LocSymbol BareTypeParsed+type DataDeclLHName = DataDeclP LHName BareTypeLHName+data DataDeclP v ty  = DataDecl+  { tycName   :: DataName              -- ^ Type  Constructor Name+  , tycTyVars :: [F.Symbol]            -- ^ Tyvar Parameters+  , tycPVars  :: [PVarV v (BSortV v)]  -- ^ PVar  Parameters+  , tycDCons  :: Maybe [DataCtorP ty]  -- ^ Data Constructors (Nothing is reserved for non-GADT style empty data declarations)+  , tycSrcPos :: !F.SourcePos          -- ^ Source Position+  , tycSFun   :: Maybe (SizeFunV v)    -- ^ Default termination measure+  , tycPropTy :: Maybe ty              -- ^ Type of Ind-Prop+  , tycKind   :: !DataDeclKind         -- ^ User-defined or Auto-lifted+  } deriving (Data, Typeable, Generic, Functor, Foldable, Traversable)+  deriving (B.Binary, Hashable) via Generically (DataDeclP v ty)++-- | The name of the `TyCon` corresponding to a `DataDecl`+data DataName+  = DnName !(F.Located LHName)         -- ^ for 'isVanillyAlgTyCon' we can directly use the `TyCon` name+  | DnCon  !(F.Located LHName)         -- ^ for 'FamInst' TyCon we save some `DataCon` name+  deriving (Eq, Ord, Data, Typeable, Generic)++instance Hashable DataName++-- | Data Constructor+type DataCtor = DataCtorP BareType+type DataCtorParsed = DataCtorP BareTypeParsed+data DataCtorP ty = DataCtor+  { dcName   :: F.Located LHName       -- ^ DataCon name+  , dcTyVars :: [F.Symbol]             -- ^ Type parameters+  , dcTheta  :: [ty]                   -- ^ The GHC ThetaType corresponding to DataCon.dataConSig+  , dcFields :: [(LHName, ty)]       -- ^ field-name and field-Type pairs+  , dcResult :: Maybe ty               -- ^ Possible output (if in GADT form)+  } deriving (Data, Typeable, Generic, Eq, Functor, Foldable, Traversable)++instance Hashable ty => Hashable (DataCtorP ty)++-- | What kind of `DataDecl` is it?+data DataDeclKind+  = DataUser           -- ^ User defined data-definitions         (should have refined fields)+  | DataReflected      -- ^ Automatically lifted data-definitions (do not have refined fields)+  deriving (Eq, Data, Typeable, Generic, Show)+  deriving Hashable via Generically DataDeclKind++data HasDataDecl+  = NoDecl  (Maybe SizeFun)+  | HasDecl+  deriving (Show)++instance F.PPrint HasDataDecl where+  pprintTidy _ HasDecl    = text "HasDecl"+  pprintTidy k (NoDecl z) = text "NoDecl" <+> parens (F.pprintTidy k z)++hasDecl :: DataDecl -> HasDataDecl+hasDecl d+  | null (tycDCons d)+  = NoDecl (tycSFun d)+  -- // | Just s <- tycSFun d, null (tycDCons d)+  -- // = NoDecl (Just s)+  | otherwise+  = HasDecl++instance NFData   DataDeclKind+instance B.Binary DataDeclKind+instance B.Binary DataName+instance B.Binary ty => B.Binary (DataCtorP ty)++instance Eq (DataDeclP v ty) where+  d1 == d2 = tycName d1 == tycName d2++instance Ord DataDecl where+  compare d1 d2 = compare (tycName d1) (tycName d2)++instance F.Loc (DataCtorP ty) where+  srcSpan = F.srcSpan . dcName++instance F.Loc (DataDeclP v ty) where+  srcSpan = srcSpanFSrcSpan . sourcePosSrcSpan . tycSrcPos++instance F.Loc DataName where+  srcSpan (DnName z) = F.srcSpan z+  srcSpan (DnCon  z) = F.srcSpan z+++-- | For debugging.+instance (Show v, Show ty) => Show (DataDeclP v ty) where+  show dd = printf "DataDecl: data = %s, tyvars = %s, sizeFun = %s, kind = %s" -- [at: %s]"+              (show $ tycName   dd)+              (show $ tycTyVars dd)+              (show $ tycSFun   dd)+              (show $ tycKind   dd)+++instance Show DataName where+  show (DnName n) =               show (F.val n)+  show (DnCon  c) = "datacon:" ++ show (F.val c)++instance F.PPrint DataName where+  pprintTidy k (DnName n) = F.pprintTidy k (F.val n)+  pprintTidy k (DnCon  n) = F.pprintTidy k (F.val n)++  -- symbol (DnName z) = F.suffixSymbol "DnName" (F.val z)+  -- symbol (DnCon  z) = F.suffixSymbol "DnCon"  (F.val z)++dataNameSymbol :: DataName -> F.Located LHName+dataNameSymbol (DnName z) = z+dataNameSymbol (DnCon  z) = z++-- TODO: just use Located instead of dc_loc, dc_locE+data DataConP = DataConP+  { dcpLoc        :: !F.SourcePos+  , dcpCon        :: !Ghc.DataCon            -- ^ Corresponding GHC DataCon+  , dcpFreeTyVars :: ![RTyVar]               -- ^ Type parameters+  , dcpFreePred   :: ![PVar RSort]           -- ^ Abstract Refinement parameters+  , dcpTyConstrs  :: ![SpecType]             -- ^ ? Class constraints (via `dataConStupidTheta`)+  , dcpTyArgs     :: ![(LHName, SpecType)] -- ^ Value parameters+  , dcpTyRes      :: !SpecType               -- ^ Result type+  , dcpIsGadt     :: !Bool                   -- ^ Was this specified in GADT style (if so, DONT use function names as fields)+  , dcpModule     :: !F.Symbol               -- ^ Which module was this defined in+  , dcpLocE       :: !F.SourcePos+  } deriving (Generic, Data, Typeable)++-- | [NOTE:DataCon-Data] for each 'DataConP' we also+--   store the type of the constructed data. This is+--   *the same as* 'tyRes' for *vanilla* ADTs+--   (e.g. List, Maybe etc.) but may differ for GADTs.+--   For example,+--+--      data Thing a where+--        X  :: Thing Int+--        Y  :: Thing Bool+--+--   Here the 'DataConP' associated with 'X' (resp. 'Y')+--   has 'tyRes' corresponding to 'Thing Int' (resp. 'Thing Bool'),+--   but in both cases, the 'tyData' should be 'Thing a'.+--++instance F.Loc DataConP where+  srcSpan d = F.SS (dcpLoc d) (dcpLocE d)++instance (F.PPrint lname, F.PPrint ty) => F.PPrint (DataDeclP lname ty) where+  pprintTidy k dd =+    let+      prefix = "data" <+> F.pprint (tycName dd) <+> ppMbSizeFun (tycSFun dd) <+> F.pprint (tycTyVars dd)+    in+      case tycDCons dd of+        Nothing   -> prefix+        Just cons -> prefix <+> "=" $+$ nest 4 (vcat $ [ "|" <+> F.pprintTidy k c | c <- cons ])++instance F.PPrint ty => F.PPrint (DataCtorP ty) where+  pprintTidy k (DataCtor c as ths xts t) = F.pprintTidy k c <+> text "::" <+> ppVars k as <+> ppThetas ths <+> ppFields k " ->" xts <+> "->" <+> res+    where+      res         = maybe "*" (F.pprintTidy k) t+      ppThetas [] = empty+      ppThetas ts = parens (hcat $ punctuate ", " (F.pprintTidy k <$> ts)) <+> "=>"++ppMbSizeFun :: F.PPrint v => Maybe (SizeFunV v) -> Doc+ppMbSizeFun Nothing  = ""+ppMbSizeFun (Just z) = F.pprint z++ppVars :: (F.PPrint a) => F.Tidy -> [a] -> Doc+ppVars k as = "forall" <+> hcat (punctuate " " (F.pprintTidy k <$> as)) <+> "."++ppFields :: (F.PPrint k, F.PPrint v) => F.Tidy -> Doc -> [(k, v)] -> Doc+ppFields k sep' kvs = hcat $ punctuate sep' (F.pprintTidy k <$> kvs)++instance F.PPrint SpecType => F.PPrint DataConP where+  pprintTidy k (DataConP _ dc vs ps cs yts t isGadt mname _)+     =  F.pprintTidy k dc+    <+> parens (hsep (punctuate comma (F.pprintTidy k <$> vs)))+    <+> parens (hsep (punctuate comma (F.pprintTidy k <$> ps)))+    <+> parens (hsep (punctuate comma (F.pprintTidy k <$> cs)))+    <+> parens (hsep (punctuate comma (F.pprintTidy k <$> yts)))+    <+> F.pprintTidy k isGadt+    <+> F.pprintTidy k mname+    <+> F.pprintTidy k t++instance F.PPrint SpecType => Show DataConP where+  show = F.showpp++instance F.PPrint Ghc.DataCon where+  pprintTidy _ = text . showPpr++instance Show Ghc.DataCon where+  show = F.showpp
src/Language/Haskell/Liquid/Types/Dictionaries.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts     #-} module Language.Haskell.Liquid.Types.Dictionaries (-    makeDictionaries-  , makeDictionary-  , dfromList+    dfromList   , dmapty   , dmap   , dinsert@@ -13,50 +11,17 @@   ) where  import           Data.Hashable--- import           Data.Maybe (catMaybes)  import           Prelude                                   hiding (error) import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.Types.PrettyPrint () import qualified Language.Haskell.Liquid.GHC.Misc       as GM import qualified Liquid.GHC.API        as Ghc-import           Language.Haskell.Liquid.Types.Types -- import           Language.Haskell.Liquid.Types.Visitors (freeVars) import           Language.Haskell.Liquid.Types.RefType ()-import           Language.Fixpoint.Misc                (mapFst)+import           Language.Haskell.Liquid.Types.Types import qualified Data.HashMap.Strict                       as M -----makeDictionaries :: [RInstance LocSpecType] -> DEnv F.Symbol LocSpecType-makeDictionaries = DEnv . M.fromList . map makeDictionary---makeDictionary :: RInstance LocSpecType -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))-makeDictionary (RI c ts xts) = (makeDictionaryName (btc_tc c) ts, M.fromList (mapFst val <$> xts))--makeDictionaryName :: LocSymbol -> [LocSpecType] -> F.Symbol-makeDictionaryName t ts-  = F.notracepp _msg $ F.symbol ("$f" ++ F.symbolString (val t) ++ concatMap mkName ts)-  where-    mkName = makeDicTypeName sp . dropUniv . val-    sp     = GM.fSrcSpan t-    _msg   = "MAKE-DICTIONARY " ++ F.showpp (val t, ts)---- | @makeDicTypeName@ DOES NOT use show/symbol in the @RVar@ case ---   as those functions add the unique-suffix which then breaks the ---   class resolution.--makeDicTypeName :: Ghc.SrcSpan -> SpecType -> String-makeDicTypeName _ RFun{}           = "(->)"-makeDicTypeName _ (RApp c _ _ _)   = F.symbolString . GM.dropModuleNamesCorrect . F.symbol . rtc_tc $ c-makeDicTypeName _ (RVar (RTV a) _) = show (Ghc.getName a)-makeDicTypeName sp t               = panic (Just sp) ("makeDicTypeName: called with invalid type " ++ show t)--dropUniv :: SpecType -> SpecType-dropUniv t = t' where (_,_,t') = bkUniv t  -------------------------------------------------------------------------------- -- | Dictionary Environment ----------------------------------------------------
src/Language/Haskell/Liquid/Types/Equality.hs view
@@ -5,12 +5,14 @@ module Language.Haskell.Liquid.Types.Equality where  import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RefType ()+import           Language.Haskell.Liquid.Types.Types import qualified Liquid.GHC.API as Ghc  import Control.Monad (liftM2, zipWithM) import Control.Monad.Writer.Lazy--- import Control.Monad+import           Data.Function (on) import qualified Data.List as L  instance REq SpecType where@@ -19,10 +21,10 @@ compareRType :: SpecType -> SpecType -> Bool compareRType i1 i2 = res && unify ys   where-    unify vs = and (sndEq <$> L.groupBy (\(x1,_) (x2,_) -> x1 == x2) vs)-    sndEq [] = True-    sndEq [_] = True-    sndEq ((_,y):xs) = all (==y) (snd <$> xs)+    unify =+      all (null . drop 1 . L.nub . map snd) .+      L.groupBy ((==) `on` fst) .+      L.sortOn fst      (res, ys) = runWriter (go i1 i2)     go :: SpecType -> SpecType -> Writer [(RTyVar, RTyVar)] Bool
src/Language/Haskell/Liquid/Types/Errors.hs view
@@ -67,6 +67,7 @@ import qualified Data.HashMap.Strict          as M import qualified Data.List                    as L import           Data.Void+import           GHC.Stack import           System.Directory import           System.FilePath import           Text.PrettyPrint.HughesPJ@@ -482,6 +483,11 @@                 , dc   :: !Doc                 } +  | ErrCtorRefinement { pos :: !SrcSpan+                      , ctorName :: !Doc+                      } -- ^ The refinement of a data constructor doesn't admit+                        -- a refinement on the return type that+                        -- isn't deemd safe    | ErrOther    { pos   :: SrcSpan                 , msg   :: !Doc@@ -576,8 +582,8 @@ panicDoc sp d = Ex.throw (ErrOther sp d :: UserError)  -- | Construct and show an Error, then crash-panic :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a-panic sp d = panicDoc (sspan sp) (text d)+panic :: HasCallStack => Maybe SrcSpan -> String -> a+panic sp d = panicDoc (sspan sp) (text (prettyCallStack callStack) $+$ text d)   where     sspan  = Mb.fromMaybe noSrcSpan @@ -1059,6 +1065,12 @@              , " "              , nest 2 "https://ucsd-progsys.github.io/liquidhaskell/options/#positivity-check"             ]++ppError' _ dCtx (ErrCtorRefinement _ ctorName)+  = text "Refinement of the data constructor" <+> ctorName <+> "doesn't admit an arbitrary refinements on the return type"+        $+$ dCtx+        $+$ nest 4 (text "Were you trying to use `Prop` from `Language.Haskell.Liquid.ProofCombinators`?")+        $+$ nest 4 (text "You can disable this error by enabling the flag `--allow-unsafe-constructors`")  ppError' _ dCtx (ErrParseAnn _ msg)   = text "Malformed annotation"
src/Language/Haskell/Liquid/Types/Fresh.hs view
@@ -34,6 +34,9 @@ import qualified Language.Fixpoint.Types as F -- import           Language.Fixpoint.Types.Visitor (kvars) import           Language.Haskell.Liquid.Misc  (single)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.RefType @@ -59,7 +62,7 @@  instance (Freshable m Integer, Monad m, Applicative m) => Freshable m F.Reft where   fresh                  = panic Nothing "fresh Reft"-  true    _ (F.Reft (v,_)) = return $ F.Reft (v, mempty)+  true    _ (F.Reft (v,_)) = return $ F.Reft (v, F.PTrue)   refresh _ (F.Reft (_,_)) = (F.Reft .) . (,) <$> freshVV <*> fresh     where       freshVV            = F.vv . Just <$> fresh@@ -69,13 +72,13 @@   true allowTC (MkUReft r _)    = MkUReft <$> true allowTC r    <*> return mempty   refresh allowTC (MkUReft r _) = MkUReft <$> refresh allowTC r <*> return mempty -instance (Freshable m Integer, Freshable m r, F.Reftable r ) => Freshable m (RRType r) where+instance (Freshable m Integer, Freshable m r, Reftable r ) => Freshable m (RRType r) where   fresh   = panic Nothing "fresh RefType"   refresh = refreshRefType   true    = trueRefType  ------------------------------------------------------------------------------------------------trueRefType :: (Freshable m Integer, Freshable m r, F.Reftable r) => Bool -> RRType r -> m (RRType r)+trueRefType :: (Freshable m Integer, Freshable m r, Reftable r) => Bool -> RRType r -> m (RRType r) ----------------------------------------------------------------------------------------------- trueRefType allowTC (RAllT α t r)   = RAllT α <$> true allowTC t <*> true allowTC r@@ -117,14 +120,14 @@ trueRefType _ t@(RHole _)   = return t -trueRef :: (F.Reftable r, Freshable f r, Freshable f Integer)+trueRef :: (Reftable r, Freshable f r, Freshable f Integer)         => Bool -> Ref τ (RType RTyCon RTyVar r) -> f (Ref τ (RRType r)) trueRef _ (RProp _ (RHole _)) = panic Nothing "trueRef: unexpected RProp _ (RHole _))" trueRef allowTC (RProp s t) = RProp s <$> trueRefType allowTC t   ------------------------------------------------------------------------------------------------refreshRefType :: (Freshable m Integer, Freshable m r, F.Reftable r) => Bool -> RRType r -> m (RRType r)+refreshRefType :: (Freshable m Integer, Freshable m r, Reftable r) => Bool -> RRType r -> m (RRType r) ----------------------------------------------------------------------------------------------- refreshRefType allowTC (RAllT α t r)   = RAllT α <$> refresh allowTC t <*> true allowTC r@@ -160,7 +163,7 @@ refreshRefType _ t   = return t -refreshRef :: (F.Reftable r, Freshable f r, Freshable f Integer)+refreshRef :: (Reftable r, Freshable f r, Freshable f Integer)            => Bool -> Ref τ (RType RTyCon RTyVar r) -> f (Ref τ (RRType r)) refreshRef _ (RProp _ (RHole _)) = panic Nothing "refreshRef: unexpected (RProp _ (RHole _))" refreshRef allowTC (RProp s t) = RProp <$> mapM freshSym s <*> refreshRefType allowTC t@@ -257,14 +260,14 @@       return $ RProp [(x, t) | (x, (_, t)) <- zip xs s] $ F.subst su t'  ---------------------------------------------------------------------------------refreshHoles :: (F.Symbolic t, F.Reftable r, TyConable c, Freshable f r)+refreshHoles :: (F.Symbolic t, Reftable r, TyConable c, Freshable f r)              => Bool -> [(t, RType c tv r)] -> f ([F.Symbol], [(t, RType c tv r)]) refreshHoles allowTC vts = first catMaybes . unzip . map extract <$> mapM (refreshHoles' allowTC) vts   where   --   extract :: (t, t1, t2) -> (t, (t1, t2))     extract (a,b,c) = (a,(b,c)) -refreshHoles' :: (F.Symbolic a, F.Reftable r, TyConable c, Freshable m r)+refreshHoles' :: (F.Symbolic a, Reftable r, TyConable c, Freshable m r)               => Bool -> (a, RType c tv r) -> m (Maybe F.Symbol, a, RType c tv r) refreshHoles' allowTC (x,t)   | noHoles t = return (Nothing, x, t)@@ -273,5 +276,5 @@     tx r | hasHole r = refresh allowTC r          | otherwise = return r -noHoles :: (F.Reftable r, TyConable c) => RType c tv r -> Bool+noHoles :: (Reftable r, TyConable c) => RType c tv r -> Bool noHoles = and . foldReft False (\_ r bs -> not (hasHole r) : bs) []
src/Language/Haskell/Liquid/Types/Literals.hs view
@@ -11,7 +11,8 @@ import Language.Haskell.Liquid.GHC.TypeRep () import Liquid.GHC.API hiding (panic) -import Language.Haskell.Liquid.Types.Types+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.RType import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Transforms.CoreToLogic (mkLit, mkI, mkS)
src/Language/Haskell/Liquid/Types/Meet.hs view
@@ -6,12 +6,12 @@  import           Text.PrettyPrint.HughesPJ (Doc) import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.RType import           Language.Haskell.Liquid.Types.RefType () import           Liquid.GHC.API as Ghc  meetVarTypes :: F.TCEmb TyCon -> Doc -> (SrcSpan, SpecType) -> (SrcSpan, SpecType) -> SpecType-meetVarTypes _emb _v hs lq = {- meetError emb err -} F.meet hsT lqT+meetVarTypes _emb _v hs lq = {- meetError emb err -} meet hsT lqT   where     (_hsSp, hsT)      = hs     (_lqSp, lqT)      = lq@@ -23,7 +23,7 @@ _meetError :: F.TCEmb TyCon -> Error -> SpecType -> SpecType -> SpecType _meetError _emb _e t t'   -- // | meetable emb t t'-  | True              = t `F.meet` t'+  | True              = t `meet` t'   -- // | otherwise         = panicError e  _meetable :: F.TCEmb TyCon -> SpecType -> SpecType -> Bool
src/Language/Haskell/Liquid/Types/Names.hs view
@@ -1,7 +1,51 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Liquid.Types.Names-  (lenLocSymbol, anyTypeSymbol, functionComposisionSymbol, selfSymbol) where+  ( lenLocSymbol+  , anyTypeSymbol+  , selfSymbol+  , LogicName (..)+  , LHResolvedName (..)+  , LHName (..)+  , LHNameSpace (..)+  , LHThisModuleNameFlag (..)+  , makeResolvedLHName+  , getLHGHCName+  , getLHNameResolved+  , getLHNameSymbol+  , lhNameToResolvedSymbol+  , lhNameToUnqualifiedSymbol+  , makeGHCLHName+  , makeGHCLHNameFromId+  , makeGHCLHNameLocated+  , makeGHCLHNameLocatedFromId+  , makeLocalLHName+  , makeLogicLHName+  , makeGeneratedLogicLHName+  , makeUnresolvedLHName+  , mapLHNames+  , mapMLocLHNames+  , maybeReflectedLHName+  , reflectGHCName+  , reflectLHName+  , updateLHNameSymbol+  ) where +import Control.DeepSeq+import qualified Data.Binary as B+import Data.Data (Data, gmapM, gmapT)+import Data.Generics (extM, extT)+import Data.Hashable+import Data.String (fromString)+import qualified Data.Text                               as Text+import GHC.Generics+import GHC.Show+import GHC.Stack import Language.Fixpoint.Types+import Language.Haskell.Liquid.GHC.Misc ( locNamedThing ) -- Symbolic GHC.Name+import qualified Liquid.GHC.API as GHC  -- RJ: Please add docs lenLocSymbol :: Located Symbol@@ -10,11 +54,323 @@ anyTypeSymbol :: Symbol anyTypeSymbol = symbol ("GHC.Prim.Any" :: String) +selfSymbol :: Symbol+selfSymbol = symbol ("liquid_internal_this" :: String) ---  defined in include/GHC/Base.hs-functionComposisionSymbol :: Symbol-functionComposisionSymbol = symbol ("GHC.Internal.Base.." :: String)+-- | A name for an entity that does not exist in Haskell+--+-- For instance, this can be used to represent predicate aliases+-- or uninterpreted functions.+data LogicName =+    LogicName+       -- | Unqualified symbol+      !Symbol+        -- | Module where the entity was defined+      !GHC.Module+        -- | If the named entity is the reflection of some Haskell name+      !(Maybe GHC.Name)+    | GeneratedLogicName Symbol+  deriving (Data, Eq, Generic) +-- | A name whose procedence is known.+data LHResolvedName+    = LHRLogic !LogicName+    | LHRGHC !GHC.Name    -- ^ A name for an entity that exists in Haskell+    | LHRLocal !Symbol    -- ^ A name for a local variable, e.g. one that is+                          --   bound by a type alias.+    | -- | The index of a name in some environment+      --+      -- Before serializing names, they are converted to indices. The names+      -- themselves are kept in an environment or table that is serialized+      -- separately. This is to acommodate how GHC serializes its Names.+      LHRIndex Word+  deriving (Data, Eq, Generic, Ord) -selfSymbol :: Symbol-selfSymbol = symbol ("liquid_internal_this" :: String)+-- | A name that is potentially unresolved.+data LHName+    = -- | In order to integrate the resolved names gradually, we keep the+      -- unresolved names.+      LHNResolved !LHResolvedName !Symbol+    | LHNUnresolved !LHNameSpace !Symbol+  deriving (Data, Generic)++-- | An Eq instance that ignores the Symbol in resolved names+instance Eq LHName where+  LHNResolved n0 _ == LHNResolved n1 _ = n0 == n1+  LHNUnresolved ns0 s0 == LHNUnresolved ns1 s1 = ns0 == ns1 && s0 == s1+  _ == _ = False++-- | An Ord instance that ignores the Symbol in resolved names+instance Ord LHName where+  compare (LHNResolved n0 _) (LHNResolved n1 _) = compare n0 n1+  compare (LHNUnresolved ns0 s0) (LHNUnresolved ns1 s1) =+    compare (ns0, s0) (ns1, s1)+  compare LHNResolved{} _ = LT+  compare LHNUnresolved{} _ = GT++-- | A Hashable instance that ignores the Symbol in resolved names+instance Hashable LHName where+  hashWithSalt s (LHNResolved n _) = hashWithSalt s n+  hashWithSalt s (LHNUnresolved ns sym) = s `hashWithSalt` ns `hashWithSalt` sym++data LHNameSpace+    = LHTcName+    | LHDataConName LHThisModuleNameFlag+    | LHVarName LHThisModuleNameFlag+    | LHLogicNameBinder+    | LHLogicName+  deriving (Data, Eq, Generic, Ord, Show)++instance B.Binary LHNameSpace+instance NFData LHNameSpace+instance Hashable LHNameSpace++-- | Whether the name should be looked up in the current module only or in any+-- module+data LHThisModuleNameFlag = LHThisModuleNameF | LHAnyModuleNameF+  deriving (Data, Eq, Generic, Ord, Show)++instance B.Binary LHThisModuleNameFlag+instance NFData LHThisModuleNameFlag+instance Hashable LHThisModuleNameFlag++instance Ord LogicName where+  compare (LogicName s1 m1 _) (LogicName s2 m2 _) =+    case compare s1 s2 of+      EQ -> GHC.stableModuleCmp m1 m2+      x -> x+  compare LogicName{} GeneratedLogicName{} = LT+  compare GeneratedLogicName{} LogicName{} = GT+  compare (GeneratedLogicName s1) (GeneratedLogicName s2) = compare s1 s2++instance Show LHName where+  showsPrec d n0 = showParen (d > app_prec) $ case n0 of+      LHNResolved n s ->+        showString "LHNResolved " .+        showsPrec (app_prec + 1) n .+        showSpace .+        showsPrec (app_prec + 1) s+      LHNUnresolved ns s ->+        showString "LHNUnresolved " .+        showsPrec (app_prec + 1) ns .+        showSpace .+        showsPrec (app_prec + 1) s+    where+      app_prec = 10++instance Show LHResolvedName where+  showsPrec d n0 = showParen (d > app_prec) $ case n0 of+      LHRGHC n1 -> showString "LHRGHC " . showString (GHC.showPprDebug n1)+      LHRLogic n1 -> showString "LHRLogic " . showsPrec (app_prec + 1) n1+      LHRLocal n1 -> showString "LHRLocal " . showsPrec (app_prec + 1) n1+      LHRIndex i -> showString "LHRIndex " . showsPrec (app_prec + 1) i+    where+      app_prec = 10++instance Show LogicName where+  showsPrec d n0 = showParen (d > app_prec) $ case n0 of+      LogicName s1 m mr ->+        showString "LogicName " .+        showsPrec (app_prec + 1) s1 .+        showSpace .+        showString (GHC.showPprDebug m) .+        showSpace .+        showsPrecMaybeName mr+      GeneratedLogicName s1 ->+        showString "GeneratedLogicName " .+        showsPrec (app_prec + 1) s1+    where+      app_prec = 10++      showsPrecMaybeName mr = case mr of+        Nothing -> showString "Nothing"+        Just n -> showParen True $ showString "Just " . showString (GHC.showPprDebug n)++instance NFData LHName+instance NFData LHResolvedName+instance NFData LogicName++instance Hashable LHResolvedName where+  hashWithSalt s (LHRLogic n) = s `hashWithSalt` (0::Int) `hashWithSalt` n+  hashWithSalt s (LHRGHC n) =+    s `hashWithSalt` (1::Int) `hashWithSalt` GHC.getKey (GHC.nameUnique n)+  hashWithSalt s (LHRLocal n) = s `hashWithSalt` (2::Int) `hashWithSalt` n+  hashWithSalt s (LHRIndex w) = s `hashWithSalt` (3::Int) `hashWithSalt` w++instance Hashable LogicName where+  hashWithSalt s (LogicName sym m _) =+        s `hashWithSalt` sym+          `hashWithSalt` GHC.moduleStableString m+  hashWithSalt s (GeneratedLogicName sym) =+        s `hashWithSalt` sym++instance B.Binary LHName+instance B.Binary LHResolvedName where+  get = do+    tag <- B.getWord8+    case tag of+      0 -> LHRLocal . fromString <$> B.get+      1 -> LHRIndex <$> B.get+      _ -> error "B.Binary: invalid tag for LHResolvedName"+  put (LHRLogic _n) = error "cannot serialize LHRLogic"+  put (LHRGHC _n) = error "cannot serialize LHRGHC"+  put (LHRLocal s) = B.putWord8 0 >> B.put (symbolString s)+  put (LHRIndex n) = B.putWord8 1 >> B.put n++instance GHC.Binary LHResolvedName where+  get bh = do+    tag <- GHC.getByte bh+    case tag of+      0 -> LHRLogic <$> GHC.get bh+      1 -> LHRGHC <$> GHC.get bh+      2 -> LHRLocal . fromString <$> GHC.get bh+      _ -> error "GHC.Binary: invalid tag for LHResolvedName"+  put_ bh (LHRLogic n) = GHC.putByte bh 0 >> GHC.put_ bh n+  put_ bh (LHRGHC n) = GHC.putByte bh 1 >> GHC.put_ bh n+  put_ bh (LHRLocal n) = GHC.putByte bh 2 >> GHC.put_ bh (symbolString n)+  put_ _bh (LHRIndex _n) = error "GHC.Binary: cannot serialize LHRIndex"++instance GHC.Binary LogicName where+  get bh = do+    tag <- GHC.getByte bh+    case tag of+      0 -> LogicName . fromString <$> GHC.get bh <*> GHC.get bh <*> GHC.get bh+      1 -> GeneratedLogicName . fromString <$> GHC.get bh+      _ -> error "GHC.Binary: invalid tag for LogicName"+  put_ bh (LogicName s m r) = do+    GHC.putByte bh 0+    GHC.put_ bh (symbolString s) >> GHC.put_ bh m >> GHC.put_ bh r+  put_ bh (GeneratedLogicName s) = do+    GHC.putByte bh 1+    GHC.put_ bh (symbolString s)++instance PPrint LHName where+  pprintTidy _ = pprint . getLHNameSymbol++makeResolvedLHName :: LHResolvedName -> Symbol -> LHName+makeResolvedLHName = LHNResolved++makeGHCLHName :: GHC.Name -> Symbol -> LHName+makeGHCLHName n s = makeResolvedLHName (LHRGHC n) s++makeGHCLHNameFromId :: GHC.Id -> LHName+makeGHCLHNameFromId x =+    let n = case GHC.idDetails x of+              GHC.DataConWrapId dc -> GHC.getName dc+              GHC.DataConWorkId dc -> GHC.getName dc+              _ -> GHC.getName x+     in makeGHCLHName n (symbol n)++makeLocalLHName :: Symbol -> LHName+makeLocalLHName s = LHNResolved (LHRLocal s) s++makeLogicLHName :: Symbol -> GHC.Module -> Maybe GHC.Name -> LHName+makeLogicLHName s m r = LHNResolved (LHRLogic (LogicName s m r)) s++makeGeneratedLogicLHName :: Symbol -> LHName+makeGeneratedLogicLHName s = LHNResolved (LHRLogic (GeneratedLogicName s)) s++makeGHCLHNameLocated :: (GHC.NamedThing a, Symbolic a) => a -> Located LHName+makeGHCLHNameLocated x =+    makeGHCLHName (GHC.getName x) (symbol x) <$ locNamedThing x++makeGHCLHNameLocatedFromId :: GHC.Id -> Located LHName+makeGHCLHNameLocatedFromId x =+    case GHC.idDetails x of+      GHC.DataConWrapId dc -> makeGHCLHNameLocated (GHC.getName dc)+      GHC.DataConWorkId dc -> makeGHCLHNameLocated (GHC.getName dc)+      _ -> makeGHCLHNameLocated x++makeUnresolvedLHName :: LHNameSpace -> Symbol -> LHName+makeUnresolvedLHName = LHNUnresolved++-- | Get the unresolved Symbol from an LHName.+getLHNameSymbol :: LHName -> Symbol+getLHNameSymbol (LHNResolved _ s) = s+getLHNameSymbol (LHNUnresolved _ s) = s++-- | Get the resolved Symbol from an LHName.+getLHNameResolved :: HasCallStack => LHName -> LHResolvedName+getLHNameResolved (LHNResolved n _) = n+getLHNameResolved n@LHNUnresolved{} = error $ "getLHNameResolved: unresolved name: " ++ show n++getLHGHCName :: LHName -> Maybe GHC.Name+getLHGHCName (LHNResolved (LHRGHC n) _) = Just n+getLHGHCName _ = Nothing++mapLHNames :: Data a => (LHName -> LHName) -> a -> a+mapLHNames f = go+  where+    go :: Data a => a -> a+    go = gmapT (go `extT` f)++mapMLocLHNames :: forall m a. (Data a, Monad m) => (Located LHName -> m (Located LHName)) -> a -> m a+mapMLocLHNames f = go+  where+    go :: forall b. Data b => b -> m b+    go = gmapM (go `extM` f)++updateLHNameSymbol :: (Symbol -> Symbol) -> LHName -> LHName+updateLHNameSymbol f (LHNResolved n s) = LHNResolved n (f s)+updateLHNameSymbol f (LHNUnresolved n s) = LHNUnresolved n (f s)++-- | Converts resolved names to symbols.+--+-- One important postcondition of this function is that the symbol for reflected+-- names must match exactly the symbol for the corresponding Haskell function.+-- Otherwise, LH would fail to link the two at various places where it is needed.+lhNameToResolvedSymbol :: LHName -> Symbol+lhNameToResolvedSymbol (LHNResolved (LHRLogic (LogicName s om mReflectionOf)) _) =+    let m = maybe om GHC.nameModule mReflectionOf+        msymbol = Text.pack $ GHC.moduleNameString $ GHC.moduleName m+     in symbol $ mconcat [msymbol, ".", symbolText s]+        {-+        TODO: Adding a prefix for the unit would allow LH to deal with+              -XPackageImports. This prefix should be added here and in+              the Symbolic instance of Name.+        munique =+          Text.dropEnd 2 $ -- Remove padding of two characters "=="+          Base64.extractBase64 $+          Base64.encodeBase64 $+          ByteString.toStrict $+          Builder.toLazyByteString $+          Builder.int32BE $+          fromIntegral $+          hash $+          GHC.unitIdString $+          GHC.moduleUnitId m+     in symbol $ mconcat ["u", munique, "##", msymbol, ".", symbolText s]+          -}+lhNameToResolvedSymbol (LHNResolved (LHRLogic (GeneratedLogicName s)) _) = s+lhNameToResolvedSymbol (LHNResolved (LHRLocal s) _) = s+lhNameToResolvedSymbol (LHNResolved (LHRGHC n) _) = symbol n+lhNameToResolvedSymbol n = error $ "lhNameToResolvedSymbol: unexpected name: " ++ show n++lhNameToUnqualifiedSymbol :: HasCallStack => LHName -> Symbol+lhNameToUnqualifiedSymbol (LHNResolved (LHRLogic (LogicName s _ _)) _) = s+lhNameToUnqualifiedSymbol (LHNResolved (LHRLogic (GeneratedLogicName s)) _) = s+lhNameToUnqualifiedSymbol (LHNResolved (LHRLocal s) _) = s+lhNameToUnqualifiedSymbol (LHNResolved (LHRGHC n) _) = symbol $ GHC.getOccString n+lhNameToUnqualifiedSymbol n = error $ "lhNameToUnqualifiedSymbol: unexpected name: " ++ show n++-- | Creates a name in the logic namespace for the given Haskell name.+reflectLHName :: HasCallStack => GHC.Module -> LHName -> LHName+reflectLHName thisModule (LHNResolved (LHRGHC n) _) = reflectGHCName thisModule n+reflectLHName _ n = error $ "not a GHC Name: " ++ show n++-- | Creates a name in the logic namespace for the given Haskell name.+reflectGHCName :: GHC.Module -> GHC.Name -> LHName+reflectGHCName thisModule n =+    LHNResolved+      (LHRLogic+        (LogicName+          (symbol (GHC.occNameString $ GHC.nameOccName n))+          thisModule+          (Just n)+        )+      )+      (symbol n)++maybeReflectedLHName :: LHName -> Maybe GHC.Name+maybeReflectedLHName (LHNResolved (LHRLogic (LogicName _ _ m)) _) = m+maybeReflectedLHName _ = Nothing
src/Language/Haskell/Liquid/Types/PredType.hs view
@@ -8,8 +8,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Language.Haskell.Liquid.Types.PredType (-    PrType-  , TyConP (..), DataConP (..)+    TyConP (..), DataConP (..)   , dataConTy   , dataConPSpecType   , makeTyConInfo@@ -33,7 +32,6 @@   ) where  import           Prelude                         hiding (error)-import           Text.PrettyPrint.HughesPJ import           Liquid.GHC.API hiding ( panic                                                         , (<+>)                                                         , hsep@@ -56,9 +54,13 @@ import qualified Liquid.GHC.API            as Ghc import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names import           Language.Haskell.Liquid.Types.RefType hiding (generalize)+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.Types-import           Data.Default  makeTyConInfo :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> [TyConP] -> TyConMap makeTyConInfo tce fiTcs tcps = TyConMap@@ -156,7 +158,7 @@ meetWorkWrapRep c workR wrapR   | 0 <= pad'   = workR { ty_binds = xs ++ ty_binds wrapR-          , ty_args  = ts ++ zipWith F.meet ts' (ty_args wrapR)+          , ty_args  = ts ++ zipWith meet ts' (ty_args wrapR)           , ty_res   = strengthenRType (ty_res workR)    (ty_res  wrapR)           , ty_preds = ty_preds wrapR           }@@ -182,50 +184,22 @@     mkArrow makeVars' ps ts' rt'   where     isCls    = Ghc.isClassTyCon $ Ghc.dataConTyCon dc-    (as, sts) = unzip (reverse yts)+    (as0, sts) = unzip (reverse yts)+    as = map lhNameToResolvedSymbol as0+    as1 = map lhNameToUnqualifiedSymbol as0     mkDSym z = F.symbol z `F.suffixSymbol` F.symbol dc     bs       = mkDSym <$> as     tx _  []     []     []     = []     tx su (x:xs) (y:ys) (t:ts) = (y, classRFInfo allowTC , if allowTC && isCls then t else F.subst (F.mkSubst su) t, mempty)                                : tx ((x, F.EVar y):su) xs ys ts     tx _ _ _ _ = panic Nothing "PredType.dataConPSpecType.tx called on invalid inputs"-    yts'     = tx [] as bs sts+    yts'     = tx [] as1 bs sts     ts'      = map ("" , classRFInfo allowTC , , mempty) cs ++ yts'-    subst    = F.mkSubst [(x, F.EVar y) | (x, y) <- zip as bs]+    subst    = F.mkSubst [(x, F.EVar y) | (x, y) <- zip as1 bs]     rt'      = F.subst subst rt-    makeVars = zipWith (\v a -> RTVar v (rTVarInfo a :: RTVInfo RSort)) vs (fst $ splitForAllTyCoVars $ dataConRepType dc)-    makeVars' = map (, mempty) makeVars--instance PPrint TyConP where-  pprintTidy k tc = "data" <+> pprintTidy k (tcpCon tc)-                           <+> ppComm     k (tcpFreeTyVarsTy tc)-                           <+> ppComm     k (tcpFreePredTy   tc)-      --  (parens $ hsep (punctuate comma (pprintTidy k <$> vs))) <+>-      -- (parens $ hsep (punctuate comma (pprintTidy k <$> ps))) <+>-      -- (parens $ hsep (punctuate comma (pprintTidy k <$> ls)))--ppComm :: PPrint a => F.Tidy -> [a] -> Doc-ppComm k = parens . hsep . punctuate comma . fmap (pprintTidy k)-----instance Show TyConP where- show = showpp -- showSDoc . ppr--instance PPrint DataConP where-  pprintTidy k (DataConP _ dc vs ps cs yts t isGadt mname _)-     =  pprintTidy k dc-    <+> parens (hsep (punctuate comma (pprintTidy k <$> vs)))-    <+> parens (hsep (punctuate comma (pprintTidy k <$> ps)))-    <+> parens (hsep (punctuate comma (pprintTidy k <$> cs)))-    <+> parens (hsep (punctuate comma (pprintTidy k <$> yts)))-    <+> pprintTidy k isGadt-    <+> pprintTidy k mname-    <+>  pprintTidy k t--instance Show DataConP where-  show = showpp+    makeVars = filter (`elem` fvs) $ zipWith (\v a -> RTVar v (rTVarInfo a :: RTVInfo RSort)) vs (fst $ splitForAllTyCoVars $ dataConRepType dc)+    makeVars' = map (, mempty) makeVars +    fvs = freeTyVars $ mkArrow [] ps ts' rt'  dataConTy :: Monoid r           => M.HashMap RTyVar (RType RTyCon RTyVar r)@@ -249,7 +223,7 @@ replacePredsWithRefs (p, r) (MkUReft (F.Reft(v, rs)) (Pr ps))   = MkUReft (F.Reft (v, rs'')) (Pr ps2)   where-    rs''             = mconcat $ rs : rs'+    rs''             = foldr (F.&.&) F.PTrue $ rs : rs'     rs'              = r . (v,) . pargs <$> ps1     (ps1, ps2)       = L.partition (== p) ps @@ -269,29 +243,23 @@ --   then @pvarRType π@ returns an @RType@ with an @RTycon@ called --   @predRTyCon@ `RApp predRTyCon [T1, T2, T3]` ------------------------------------------------------------------------pvarRType :: (PPrint r, F.Reftable r) => PVar RSort -> RRType r+pvarRType :: (PPrint r, Reftable r) => PVar RSort -> RRType r ----------------------------------------------------------------------- pvarRType (PV _ k {- (PVProp τ) -} _ args) = rpredType k (fst3 <$> args) -- (ty:tys)   -- where   --   ty  = uRTypeGen τ   --   tys = uRTypeGen . fst3 <$> args ---- rpredType    :: (PPrint r, Reftable r) => PVKind (RRType r) -> [RRType r] -> RRType r-rpredType :: F.Reftable r-          => PVKind (RType RTyCon tv a)+rpredType :: Reftable r+          => RType RTyCon tv a           -> [RType RTyCon tv a] -> RType RTyCon tv r-rpredType (PVProp t) ts = RApp predRTyCon  (uRTypeGen <$> t : ts) [] mempty-rpredType PVHProp    ts = RApp wpredRTyCon (uRTypeGen <$>     ts) [] mempty+rpredType t ts = RApp predRTyCon  (uRTypeGen <$> t : ts) [] mempty  predRTyCon   :: RTyCon predRTyCon   = symbolRTyCon predName -wpredRTyCon   :: RTyCon-wpredRTyCon   = symbolRTyCon wpredName- symbolRTyCon   :: F.Symbol -> RTyCon-symbolRTyCon n = RTyCon (stringTyCon 'x' 42 $ F.symbolString n) [] def+symbolRTyCon n = RTyCon (stringTyCon 'x' 42 $ F.symbolString n) [] defaultTyConInfo  ------------------------------------------------------------------------------------- -- | Instantiate `PVar` with `RTProp` -----------------------------------------------@@ -321,11 +289,11 @@ --         go z (π, RPropP r) = replacePVarReft (π, r) <$> z  --------------------------------------------------------------------------------------substPVar :: PVar BSort -> PVar BSort -> BareType -> BareType+substPVar :: PVarV v (BSortV v) -> PVarV v (BSortV v) -> BareTypeParsed -> BareTypeParsed ------------------------------------------------------------------------------------- substPVar src dst = go   where-    go :: BareType -> BareType+    go :: BareTypeParsed -> BareTypeParsed     go (RVar a r)         = RVar a (goRR r)     go (RApp c ts rs r)   = RApp c (go <$> ts) (goR <$> rs) (goRR r)     go (RAllP q t)@@ -339,13 +307,13 @@     go (RAppTy t1 t2 r)   = RAppTy    (go t1) (go t2) (goRR r)     go (RHole r)          = RHole     (goRR r)     go t@(RExprArg  _)    = t-    goR :: BRProp RReft -> BRProp RReft+    goR :: BRPropV LocSymbol (RReftV LocSymbol) -> BRPropV LocSymbol (RReftV LocSymbol)     goR rp = rp {rf_body = go (rf_body rp) }-    goRR :: RReft -> RReft+    goRR :: RReftV LocSymbol -> RReftV LocSymbol     goRR rr = rr { ur_pred = goP (ur_pred rr) }-    goP :: Predicate -> Predicate+    goP :: PredicateV LocSymbol -> PredicateV LocSymbol     goP (Pr ps) = Pr (goPV <$> ps)-    goPV :: UsedPVar -> UsedPVar+    goPV :: UsedPVarV LocSymbol -> UsedPVarV LocSymbol     goPV pv       | pname pv == pname src = pv { pname = pname dst }       | otherwise             = pv@@ -380,11 +348,11 @@   | null πs                     = RFun x i (substPred msg su rt) (substPred msg su rt') r   | otherwise                   =       let sus = (\π -> F.mkSubst (zip (fst <$> rf_args prop) (thd3 <$> pargs π))) <$> πs in-      foldl (\t subst -> t `F.meet` F.subst subst (rf_body prop)) (RFun x i (substPred msg su rt) (substPred msg su rt') r') sus+      foldl (\t subst -> t `meet` F.subst subst (rf_body prop)) (RFun x i (substPred msg su rt) (substPred msg su rt') r') sus   where (r', πs)                = splitRPvar rp r -- ps has   , pargs :: ![(t, Symbol, Expr)] -substPred msg su (RRTy e r o t) = RRTy (mapSnd (substPred msg su) <$> e) r o (substPred msg su t)+substPred msg su (RRTy e r o t) = RRTy (fmap (substPred msg su) <$> e) r o (substPred msg su t) substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t') substPred msg su (REx x t t')   = REx   x (substPred msg su t) (substPred msg su t') substPred _   _  t              = t@@ -393,16 +361,16 @@ -- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType  substRCon-  :: (PPrint t, PPrint t2, Eq tv, F.Reftable r, Hashable tv, PPrint tv, PPrint r,+  :: (PPrint t, PPrint t2, Eq tv, Reftable r, Hashable tv, PPrint tv, PPrint r,       SubsTy tv (RType RTyCon tv ()) r,       SubsTy tv (RType RTyCon tv ()) (RType RTyCon tv ()),       SubsTy tv (RType RTyCon tv ()) RTyCon,       SubsTy tv (RType RTyCon tv ()) tv,-      F.Reftable (RType RTyCon tv r),+      Reftable (RType RTyCon tv r),       SubsTy tv (RType RTyCon tv ()) (RTVar tv (RType RTyCon tv ())),       FreeVar RTyCon tv,-      F.Reftable (RTProp RTyCon tv r),-      F.Reftable (RTProp RTyCon tv ()))+      Reftable (RTProp RTyCon tv r),+      Reftable (RTProp RTyCon tv ()))   => [Char]   -> (t, Ref RSort (RType RTyCon tv r))   -> RType RTyCon tv r@@ -414,14 +382,14 @@   where     ts                     = F.subst su $ safeZipWith (msg ++ ": substRCon")  strSub  ts1  ts2     rs                     = F.subst su $ safeZipWith (msg ++ ": substRCon2") strSubR rs1' rs2'-    (rs1', rs2')           = pad "substRCon" F.top rs1 rs2+    (rs1', rs2')           = pad "substRCon" top rs1 rs2     strSub x r2           = meetListWithPSubs πs ss x r2     strSubR x r2          = meetListWithPSubsRef πs ss x r2      su = F.mkSubst $ zipWith (\s1 s2 -> (s1, F.EVar s2)) (rvs t1) (rvs t2)      rvs      = foldReft False (\_ r acc -> rvReft r : acc) []-    rvReft r = let F.Reft(s,_) = F.toReft r in s+    rvReft r = let F.Reft(s,_) = toReft r in s  substRCon msg su t _ _        = {- panic Nothing -} errorP "substRCon: " $ msg ++ " " ++ showpp (su, t) @@ -486,11 +454,11 @@    ps' = f <$> filter (uPVar p ==) ps    f q = q {pargs = pargs q ++ drop (length (pargs q)) (pargs $ uPVar p)} -meetListWithPSubs :: (Foldable t, PPrint t1, F.Reftable b)+meetListWithPSubs :: (Foldable t, PPrint t1, Reftable b)                   => t (PVar t1) -> [(F.Symbol, RSort)] -> b -> b -> b meetListWithPSubs πs ss r1 r2    = L.foldl' (meetListWithPSub ss r1) r2 πs -meetListWithPSubsRef :: (Foldable t, F.Reftable (RType t1 t2 t3))+meetListWithPSubsRef :: (Foldable t, Reftable (RType t1 t2 t3))                      => t (PVar t4)                      -> [(F.Symbol, b)]                      -> Ref τ (RType t1 t2 t3)@@ -498,18 +466,18 @@                      -> Ref τ (RType t1 t2 t3) meetListWithPSubsRef πs ss r1 r2 = L.foldl' (meetListWithPSubRef ss r1) r2 πs -meetListWithPSub ::  (F.Reftable r, PPrint t) => [(F.Symbol, RSort)]-> r -> r -> PVar t -> r+meetListWithPSub ::  (Reftable r, PPrint t) => [(F.Symbol, RSort)]-> r -> r -> PVar t -> r meetListWithPSub ss r1 r2 π   | all (\(_, x, F.EVar y) -> x == y) (pargs π)-  = r2 `F.meet` r1+  = r2 `meet` r1   | all (\(_, x, F.EVar y) -> x /= y) (pargs π)-  = r2 `F.meet` F.subst su r1+  = r2 `meet` F.subst su r1   | otherwise   = panic Nothing $ "PredType.meetListWithPSub partial application to " ++ showpp π   where     su  = F.mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)] -meetListWithPSubRef :: (F.Reftable (RType t t1 t2))+meetListWithPSubRef :: (Reftable (RType t t1 t2))                     => [(F.Symbol, b)]                     -> Ref τ (RType t t1 t2)                     -> Ref τ (RType t t1 t2)@@ -521,9 +489,9 @@   = panic Nothing "PredType.meetListWithPSubRef called with invalid input" meetListWithPSubRef ss (RProp s1 r1) (RProp s2 r2) π   | all (\(_, x, F.EVar y) -> x == y) (pargs π)-  = RProp s1 $ F.subst su' r2 `F.meet` r1+  = RProp s1 $ F.subst su' r2 `meet` r1   | all (\(_, x, F.EVar y) -> x /= y) (pargs π)-  = RProp s2 $ r2 `F.meet` F.subst su r1+  = RProp s2 $ r2 `meet` F.subst su r1   | otherwise   = panic Nothing $ "PredType.meetListWithPSubRef partial application to " ++ showpp π   where@@ -537,9 +505,8 @@ predType   :: Type predType   = symbolType predName -wpredName, predName :: F.Symbol+predName :: F.Symbol predName   = "Pred"-wpredName  = "WPred"  symbolType :: F.Symbol -> Type symbolType = TyVarTy . symbolTyVar
src/Language/Haskell/Liquid/Types/PrettyPrint.hs view
@@ -55,7 +55,6 @@                                                          , Var                                                          , Name                                                          , SourceError-                                                         , TyCon                                                          , topPrec                                                          , funPrec                                                          , srcSpanStartLine@@ -64,7 +63,11 @@ import           Language.Haskell.Liquid.GHC.Logging import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.UX.Config import           Prelude                          hiding (error) import           Text.PrettyPrint.HughesPJ        hiding ((<>)) @@ -113,10 +116,6 @@ instance PPrint Name where   pprintTidy _ = pprDoc -instance PPrint TyCon where-  pprintTidy F.Lossy = shortModules . pprDoc-  pprintTidy F.Full  =                pprDoc- instance PPrint Type where   pprintTidy _ = pprDoc -- . tidyType emptyTidyEnv -- WHY WOULD YOU DO THIS??? @@ -160,7 +159,7 @@   where     xd          = maybe "unknown" (pprintTidy k) x -instance PPrint LMap where+instance (Ord v, F.Fixpoint v, PPrint v) => PPrint (LMapV v) where   pprintTidy _ (LMap x xs e) = hcat [pprint x, pprint xs, text "|->", pprint e ]  instance PPrint LogicMap where@@ -217,24 +216,24 @@ pprRtype :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc -------------------------------------------------------------------------------- pprRtype bb p t@(RAllT _ _ r)-  = F.ppTy r $ pprForall bb p t+  = ppTy r $ pprForall bb p t pprRtype bb p t@(RAllP _ _)   = pprForall bb p t pprRtype _ _ (RVar a r)-  = F.ppTy r $ pprint a+  = ppTy r $ pprint a pprRtype bb p t@RFun{}   = maybeParen p funPrec (pprRtyFun bb empty t) pprRtype bb p (RApp c [t] rs r)   | isList c-  = F.ppTy r $ brackets (pprRtype bb p t) <-> ppReftPs bb p rs+  = ppTy r $ brackets (pprRtype bb p t) <-> ppReftPs bb p rs pprRtype bb p (RApp c ts rs r)   | isTuple c-  = F.ppTy r $ parens (intersperse comma (pprRtype bb p <$> ts)) <-> ppReftPs bb p rs+  = ppTy r $ parens (intersperse comma (pprRtype bb p <$> ts)) <-> ppReftPs bb p rs pprRtype bb p (RApp c ts rs r)   | isEmpty rsDoc && isEmpty tsDoc-  = F.ppTy r $ ppT c+  = ppTy r $ ppT c   | otherwise-  = F.ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc+  = ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc   where     rsDoc            = ppReftPs bb p rs     tsDoc            = hsep (pprRtype bb p <$> ts)@@ -247,7 +246,7 @@ pprRtype _ _ (RExprArg e)   = braces $ pprint e pprRtype bb p (RAppTy t t' r)-  = F.ppTy r $ pprRtype bb p t <+> pprRtype bb p t'+  = ppTy r $ pprRtype bb p t <+> pprRtype bb p t' pprRtype bb p (RRTy e _ OCons t)   = sep [braces (pprRsubtype bb p e) <+> "=>", pprRtype bb p t] pprRtype bb p (RRTy e r o rt)@@ -257,7 +256,7 @@     ppp  doc    = text "<<" <+> doc <+> text ">>"     ppxt (x, t) = pprint x <+> ":" <+> pprRtype bb p t pprRtype _ _ (RHole r)-  = F.ppTy r $ text "_"+  = ppTy r $ text "_"  ppTyConB :: TyConable c => PPEnv -> c -> Doc ppTyConB bb@@ -288,8 +287,7 @@  ppExists   :: (OkRT c tv r, PPrint c, PPrint tv, PPrint (RType c tv r),-      PPrint (RType c tv ()), F.Reftable (RTProp c tv r),-      F.Reftable (RTProp c tv ()))+      PPrint (RType c tv ()))   => PPEnv -> Prec -> RType c tv r -> Doc ppExists bb p rt   = text "exists" <+> brackets (intersperse comma [pprDbind bb topPrec x t | (x, t) <- ws]) <-> dot <-> pprRtype bb p rt'@@ -309,10 +307,10 @@  ppReftPs   :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()),-      F.Reftable (Ref (RType c tv ()) (RType c tv r)))+      Reftable (Ref (RType c tv ()) (RType c tv r)))   => t -> t1 -> [Ref (RType c tv ()) (RType c tv r)] -> Doc ppReftPs _ _ rs-  | all F.isTauto rs   = empty+  | all isTauto rs   = empty   | not (ppPs ppEnv) = empty   | otherwise        = angleBrackets $ hsep $ punctuate comma $ pprRef <$> rs @@ -407,9 +405,8 @@     dargs = [pprPvarSort bb p xt | (xt,_,_) <- xts]  -pprPvarKind :: (OkRT c tv ()) => PPEnv -> Prec -> PVKind (RType c tv ()) -> Doc-pprPvarKind bb p (PVProp t) = pprPvarSort bb p t <+> arrow <+> pprName F.boolConName -- propConName-pprPvarKind _ _ PVHProp     = panic Nothing "TODO: pprPvarKind:hprop" -- pprName hpropConName+pprPvarKind :: (OkRT c tv ()) => PPEnv -> Prec -> RType c tv () -> Doc+pprPvarKind bb p t = pprPvarSort bb p t <+> arrow <+> pprName F.boolConName  pprName :: F.Symbol -> Doc pprName                      = text . F.symbolString@@ -432,10 +429,10 @@ dot :: Doc dot                = char '.' -instance (PPrint r, F.Reftable r) => PPrint (UReft r) where+instance (PPrint (PredicateV v), Reftable (PredicateV v), PPrint r, Reftable r) => PPrint (UReftV v r) where   pprintTidy k (MkUReft r p)-    | F.isTauto r  = pprintTidy k p-    | F.isTauto p  = pprintTidy k r+    | isTauto r  = pprintTidy k p+    | isTauto p  = pprintTidy k r     | otherwise  = pprintTidy k p <-> text " & " <-> pprintTidy k r  --------------------------------------------------------------------------------
+ src/Language/Haskell/Liquid/Types/RType.hs view
@@ -0,0 +1,1052 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module contains the types to represent refinement types.++module Language.Haskell.Liquid.Types.RType (++  -- * Bare Type Constructors and Variables+    BTyCon(..)+  , mkBTyCon+  -- , mkClassBTyCon, mkPromotedBTyCon+  , isClassBTyCon+  , BTyVar(..)++  -- * Refined Type Constructors+  , RTyCon (RTyCon, rtc_tc, rtc_info)+  , TyConInfo(..), defaultTyConInfo+  , rTyConPVs+  -- , isClassRTyCon+  , isClassType, isEqType, isRVar, isBool, isEmbeddedClass++  -- * Refinement Types+  , RType, RTypeV (..), Ref(..), RTProp, RTPropV, rPropP+  , RTyVar (..)+  , OkRT++  -- * Classes describing operations on `RTypes`+  , TyConable (..)++  -- * Type Variables+  , RTVar (..), RTVInfo (..)+  , makeRTVar, mapTyVarValue+  , dropTyVarInfo, rTVarToBind+  , setRtvPol++  -- * Predicate Variables+  , PVar+  , PVarV (PV, pname, parg, ptype, pargs), pvType+  , Predicate+  , PredicateV (..)++  -- * Manipulating `Predicates`+  , emapExprVM+  , mapPredicateV+  , emapPredicateVM+  , mapPVarV+  , emapPVarVM+  , emapSubstVM+  , pvars, pappSym, pApp++  -- * Refinements+  , UReft+  , UReftV(..)+  , mapUReftV+  , emapUReftVM++  -- * Parse-time entities describing refined data types+  , SizeFun, SizeFunV (..), szFun+  , TyConP   (..)++  -- * Pre-instantiated RType+  , RRType, RRProp+  , BRType, BRProp, BRPropV+  , BSort, BSortV, BPVar+  , RTVU, PVU++  -- * Instantiated RType+  , BareType+  , BareTypeLHName+  , BareTypeParsed+  , BareTypeV+  , SpecType, SpecProp, SpecRTVar+  , LocBareType+  , LocBareTypeLHName+  , LocBareTypeParsed+  , LocSpecType+  , RSort+  , UsedPVar+  , UsedPVarV+  , RPVar, RReft, RReftV++  -- * Printer Configuration+  , PPEnv (..)+  , ppEnv+  , ppEnvShort++  -- * Refined Function Info+  , RFInfo(..), defRFInfo, mkRFInfo, classRFInfo++  -- * Reftable/UReftable Instances+  , Reftable(..)+  , UReftable(..)+  , ToReftV(..)+  )+  where++import           Liquid.GHC.API as Ghc hiding ( Expr+                                                               , isFunTy+                                                               , ($+$)+                                                               , nest+                                                               , text+                                                               , blankLine+                                                               , (<+>)+                                                               , vcat+                                                               , hsep+                                                               , comma+                                                               , colon+                                                               , parens+                                                               , empty+                                                               , char+                                                               , panic+                                                               , int+                                                               , hcat+                                                               , showPpr+                                                               , punctuate+                                                               , ($$)+                                                               , braces+                                                               , angleBrackets+                                                               , brackets+                                                               )+import           Data.String+import           GHC.Generics+import           Prelude                          hiding  (error)++import           Control.DeepSeq+import           Data.Traversable                       (forAccumM)+import           Data.Typeable                          (Typeable)+import           Data.Generics                          (Data)+import qualified Data.Binary                            as B+import           Data.Hashable+import qualified Data.HashMap.Strict                    as M+import qualified Data.List                              as L+import           Data.Maybe                             (mapMaybe)+import           Data.List                              as L (nub)+import           Text.PrettyPrint.HughesPJ              hiding (first, (<>))+import           Language.Fixpoint.Misc++import qualified Language.Fixpoint.Types as F+import           Language.Fixpoint.Types (Expr, ExprV(..), SubstV(..), Symbol)++import           Language.Haskell.Liquid.GHC.Misc+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.Variance+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.UX.Config+++newtype RFInfo = RFInfo {permitTC :: Maybe Bool }+  deriving (Generic, Data, Typeable, Show, Eq)++defRFInfo :: RFInfo+defRFInfo = RFInfo Nothing++classRFInfo :: Bool -> RFInfo+classRFInfo b = RFInfo $ Just b++mkRFInfo :: Config  -> RFInfo+mkRFInfo cfg = RFInfo $ Just (typeclass cfg)++instance Hashable RFInfo+instance NFData RFInfo+instance B.Binary RFInfo++-----------------------------------------------------------------------------+-- | Printer ----------------------------------------------------------------+-----------------------------------------------------------------------------++data PPEnv = PP+  { ppPs    :: Bool -- ^ print abstract-predicates+  , ppTyVar :: Bool -- ^ print the unique suffix for each tyvar+  , ppShort :: Bool -- ^ print the tycons without qualification+  , ppDebug :: Bool -- ^ gross with full info+  }+  deriving (Show)++ppEnv :: PPEnv+ppEnv = ppEnvDef+          { ppPs    = True }+          { ppDebug = True }   -- RJ: needed for resolution, because pp is used for serialization?++{- | [NOTE:ppEnv] For some mysterious reason, `ppDebug` must equal `True`+     or various tests fail e.g. tests/classes/pos/TypeEquality0{0,1}.hs+     Yikes. Find out why!+ -}++ppEnvDef :: PPEnv+ppEnvDef = PP False False False False++ppEnvShort :: PPEnv -> PPEnv+ppEnvShort pp = pp { ppShort = True }+++data TyConP = TyConP+  { tcpLoc          :: !F.SourcePos+  , tcpCon          :: !TyCon+  , tcpFreeTyVarsTy :: ![RTyVar]+  , tcpFreePredTy   :: ![PVar RSort]+  , tcpVarianceTs   :: !VarianceInfo+  , tcpVariancePs   :: !VarianceInfo+  , tcpSizeFun      :: !(Maybe SizeFun)+  } deriving (Generic, Data, Typeable)++instance F.Loc TyConP where+  srcSpan tc = F.SS (tcpLoc tc) (tcpLoc tc)++instance Show TyConP where+ show = F.showpp++instance F.PPrint TyConP where+  pprintTidy k tc = "data" <+> F.pprintTidy k (tcpCon tc)+                           <+> ppComm     k (tcpFreeTyVarsTy tc)+                           <+> ppComm     k (tcpFreePredTy   tc)++ppComm :: F.PPrint a => F.Tidy -> [a] -> Doc+ppComm k = parens . hsep . punctuate comma . fmap (F.pprintTidy k)++instance F.PPrint TyCon where+  pprintTidy F.Lossy = shortModules . pprDoc+    where+      shortModules = text . F.symbolString . dropModuleNames . F.symbol . render+  pprintTidy F.Full  =                pprDoc++-- | Termination expressions+type SizeFun = SizeFunV F.Symbol+data SizeFunV v+  = IdSizeFun              -- ^ \x -> F.EVar x+  | SymSizeFun (F.Located v) -- ^ \x -> f x+  deriving (Data, Typeable, Generic, Eq, Functor, Foldable, Traversable)+  deriving (B.Binary, Hashable) via Generically (SizeFunV v)++instance NFData v => NFData (SizeFunV v)++instance Show v => Show (SizeFunV v) where+  show IdSizeFun      = "IdSizeFun"+  show (SymSizeFun x) = "SymSizeFun " ++ show (F.val x)++szFun :: SizeFun -> Symbol -> Expr+szFun IdSizeFun      = F.EVar+szFun (SymSizeFun f) = \x -> F.mkEApp f [F.EVar x]++instance F.PPrint v => F.PPrint (SizeFunV v) where+  pprintTidy _ IdSizeFun      = "[id]"+  pprintTidy _ (SymSizeFun x) = brackets (F.pprint $ F.val x)+++--------------------------------------------------------------------+-- | Abstract Predicate Variables ----------------------------------+--------------------------------------------------------------------++type PVar t = PVarV Symbol t+data PVarV v t = PV+  { pname :: !Symbol+  , ptype :: !t+  , parg  :: !Symbol+  , pargs :: ![(t, Symbol, F.ExprV v)]+  } deriving (Generic, Data, Typeable, Show, Functor)+  deriving B.Binary via Generically (PVarV v t)++mapPVarV :: (v -> v') -> (t -> t') -> PVarV v t -> PVarV v' t'+mapPVarV f g PV {..} =+    PV+      { ptype = g ptype+      , pargs = [ (g t, s, fmap f e) | (t, s, e) <- pargs ]+      , ..+      }++-- | A map traversal that collects the local variables in scope+emapPVarVM :: Monad m => ([Symbol] -> v -> m v') -> ([Symbol] -> t -> m t') -> PVarV v t -> m (PVarV v' t')+emapPVarVM f g pv = do+    ptype <- g (argSyms (pargs pv)) (ptype pv)+    (_, pargs) <- forAccumM [] (pargs pv) $ \ss (t, s, e) -> do+      (s:ss,) <$> ((,,) <$> g (s:ss) t <*> pure s <*> emapExprVM (f . ((s:ss) ++)) e)+    return pv{ptype, pargs}+  where+    argSyms = map (\(_, s, _) -> s)++instance Eq (PVarV v t) where+  pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}++instance Ord (PVarV v t) where+  compare (PV n _ _ _)  (PV n' _ _ _) = compare n n'++instance (NFData v, NFData t) => NFData   (PVarV v t)++instance Hashable (PVarV v a) where+  hashWithSalt i (PV n _ _ _) = hashWithSalt i n++pvType :: PVarV v t -> t+pvType = ptype++instance F.PPrint (PVar a) where+  pprintTidy _ = pprPvar++pprPvar :: PVar a -> Doc+pprPvar (PV s _ _ xts) = F.pprint s <+> hsep (F.pprint <$> dargs xts)+  where+    dargs              = map thd3 . takeWhile (\(_, x, y) -> F.EVar x /= y)++-- | A map traversal that collects the local variables in scope+emapExprVM :: Monad m => ([Symbol] -> v -> m v') -> ExprV v -> m (ExprV v')+emapExprVM f = go []+  where+    go acc = \case+      ESym c -> return $ ESym c+      ECon c -> return $ ECon c+      EVar v -> EVar <$> f acc v+      EApp e0 e1 -> EApp <$> go acc e0 <*> go acc e1+      ENeg e -> ENeg <$> go acc e+      EBin bop e0 e1 -> EBin bop <$> go acc e0 <*> go acc e1+      EIte e0 e1 e2 -> EIte <$> go acc e0 <*> go acc e1 <*> go acc e2+      ECst e s -> flip ECst s <$> go acc e+      ELam (s,srt) e -> ELam (s, srt) <$> go (s:acc) e+      ETApp e s -> flip ETApp s <$> go acc e+      ETAbs e s -> flip ETAbs s <$> go acc e+      PAnd xs -> PAnd <$> mapM (go acc) xs+      POr xs -> POr <$> mapM (go acc) xs+      PNot e -> PNot <$> go acc e+      PImp e0 e1 -> PImp <$> go acc e0 <*> go acc e1+      PIff e0 e1 -> PIff <$> go acc e0 <*> go acc e1+      PAtom brel e0 e1 -> PAtom brel <$> go acc e0 <*> go acc e1+      PKVar k su -> PKVar k <$> emapSubstVM (f . (domain su ++) . (acc ++)) su+      PAll bnds e -> PAll bnds <$> go (map fst bnds ++ acc) e+      PExist bnds e -> PExist bnds <$> go (map fst bnds ++ acc) e+      PGrad k su gi e ->+        PGrad k <$> emapSubstVM (f . (acc ++)) su <*> pure gi <*> go (domain su ++ acc) e+      ECoerc srt0 srt1 e -> ECoerc srt0 srt1 <$> go acc e++    domain (Su m) = M.keys m++emapSubstVM :: Monad m => ([Symbol] -> v -> m v') -> SubstV v -> m (SubstV v')+emapSubstVM f (Su m) = Su . M.fromList <$> mapM (traverse (emapExprVM f)) (M.toList m)++--------------------------------------------------------------------------------+-- | Predicates ----------------------------------------------------------------+--------------------------------------------------------------------------------++type UsedPVar    = UsedPVarV Symbol+type UsedPVarV v = PVarV v ()++type Predicate = PredicateV Symbol+newtype PredicateV v = Pr [UsedPVarV v]+  deriving (Generic, Data, Typeable)+  deriving (B.Binary, Hashable) via Generically (PredicateV v)++mapPredicateV :: (v -> v') -> PredicateV v -> PredicateV v'+mapPredicateV f (Pr xs) = Pr (map (mapPVarV f (const ())) xs)++-- | A map traversal that collects the local variables in scope+emapPredicateVM :: Monad m => ([Symbol] -> v -> m v') -> PredicateV v -> m (PredicateV v')+emapPredicateVM f (Pr xs) = Pr <$> mapM (emapPVarVM f (\_ _ -> pure ())) xs++instance Ord v => Eq (PredicateV v) where+  (Pr vs) == (Pr ws)+      = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']+        where+          vs' = L.sort vs+          ws' = L.sort ws++instance NFData Predicate where+  rnf _ = ()++instance Monoid Predicate where+  mempty  = pdTrue+  mappend = (<>)++instance Semigroup Predicate where+  p <> p' = pdAnd [p, p']++instance F.PPrint Predicate where+  pprintTidy _ (Pr [])  = text "True"+  pprintTidy k (Pr pvs) = hsep $ punctuate (text "&") (F.pprintTidy k <$> pvs)++instance Semigroup a => Semigroup (UReft a) where+  MkUReft x y <> MkUReft x' y' = MkUReft (x <> x') (y <> y')++instance (Monoid a) => Monoid (UReft a) where+  mempty  = MkUReft mempty mempty+  mappend = (<>)+++pdTrue :: Predicate+pdTrue         = Pr []++pdAnd :: Foldable t => t Predicate -> Predicate+pdAnd ps       = Pr (nub $ concatMap pvars ps)++pvars :: Predicate -> [UsedPVar]+pvars (Pr pvs) = pvs++instance F.Subable UsedPVar where+  syms pv         = [ y | (_, x, F.EVar y) <- pargs pv, x /= y ]+  subst s pv      = pv { pargs = mapThd3 (F.subst s)  <$> pargs pv }+  substf f pv     = pv { pargs = mapThd3 (F.substf f) <$> pargs pv }+  substa f pv     = pv { pargs = mapThd3 (F.substa f) <$> pargs pv }+++instance F.Subable Predicate where+  syms     (Pr pvs) = concatMap F.syms   pvs+  subst  s (Pr pvs) = Pr (F.subst s  <$> pvs)+  substf f (Pr pvs) = Pr (F.substf f <$> pvs)+  substa f (Pr pvs) = Pr (F.substa f <$> pvs)++instance NFData r => NFData (UReft r)++newtype BTyVar = BTV F.LocSymbol+  deriving (Show, Generic, Data, Typeable)+  deriving (B.Binary, Hashable) via Generically BTyVar++newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)++instance Eq BTyVar where+  (BTV x) == (BTV y) = x == y++instance Ord BTyVar where+  compare (BTV x) (BTV y) = compare x y++instance NFData   BTyVar+instance NFData   RTyVar++instance F.Symbolic BTyVar where+  symbol (BTV tv) = F.symbol tv++instance F.Symbolic RTyVar where+  symbol (RTV tv) = F.symbol tv -- tyVarUniqueSymbol tv++-- instance F.Symbolic RTyVar where+  -- symbol (RTV tv) = F.symbol . getName $ tv+-- rtyVarUniqueSymbol  :: RTyVar -> Symbol+-- rtyVarUniqueSymbol (RTV tv) = tyVarUniqueSymbol tv+-- tyVarUniqueSymbol :: TyVar -> Symbol+-- tyVarUniqueSymbol tv = F.symbol $ show (getName tv) ++ "_" ++ show (varUnique tv)++data BTyCon = BTyCon+  { btc_tc    :: !(F.Located LHName)  -- ^ TyCon name with location information+  , btc_class :: !Bool           -- ^ Is this a class type constructor?+  , btc_prom  :: !Bool           -- ^ Is Promoted Data Con?+  }+  deriving (Generic, Data, Typeable)+  deriving (B.Binary, Hashable) via Generically BTyCon++data RTyCon = RTyCon+  { rtc_tc    :: TyCon         -- ^ GHC Type Constructor+  , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters+  , rtc_info  :: !TyConInfo    -- ^ TyConInfo+  }+  deriving (Generic, Data, Typeable)++instance F.Symbolic RTyCon where+  symbol = F.symbol . rtc_tc++instance NFData BTyCon++instance NFData RTyCon+++mkBTyCon :: F.Located LHName -> BTyCon+mkBTyCon x = BTyCon x False False+++-- | Accessors for @RTyCon@++isBool :: RType RTyCon t t1 -> Bool+isBool (RApp RTyCon{rtc_tc = c} _ _ _) = c == boolTyCon+isBool _                                 = False++isRVar :: RType c tv r -> Bool+isRVar (RVar _ _) = True+isRVar _          = False++isClassBTyCon :: BTyCon -> Bool+isClassBTyCon = btc_class++-- isClassRTyCon :: RTyCon -> Bool+-- isClassRTyCon x = (isClassTyCon $ rtc_tc x) || (rtc_tc x == eqPrimTyCon)++rTyConPVs :: RTyCon -> [RPVar]+rTyConPVs     = rtc_pvars++isEqType :: TyConable c => RTypeV v c t t1 -> Bool+isEqType (RApp c _ _ _) = isEqual c+isEqType _              = False+++isClassType :: TyConable c => RTypeV v c t t1 -> Bool+isClassType (RApp c _ _ _) = isClass c+isClassType _              = False++isEmbeddedClass :: TyConable c => RTypeV v c t t1 -> Bool+isEmbeddedClass (RApp c _ _ _) = isEmbeddedDict c+isEmbeddedClass _              = False+++class (Eq c) => TyConable c where+  isFun    :: c -> Bool+  isList   :: c -> Bool+  isTuple  :: c -> Bool+  ppTycon  :: c -> Doc+  isClass  :: c -> Bool+  isEmbeddedDict :: c -> Bool+  isEqual  :: c -> Bool+  isOrdCls  :: c -> Bool+  isEqCls   :: c -> Bool++  isNumCls  :: c -> Bool+  isFracCls :: c -> Bool++  isClass   = const False+  isEmbeddedDict c = isNumCls c || isEqual c || isOrdCls c || isEqCls c+  isOrdCls  = const False+  isEqCls   = const False+  isEqual   = const False+  isNumCls  = const False+  isFracCls = const False+++-------------------------------------------------------------------------------+-- | TyConable Instances -------------------------------------------------------+-------------------------------------------------------------------------------++instance TyConable RTyCon where+  isFun      = isArrowTyCon . rtc_tc+  isList     = (listTyCon ==) . rtc_tc+  isTuple    = Ghc.isTupleTyCon   . rtc_tc+  isClass    = isClass . rtc_tc -- isClassRTyCon+  isEqual    = isEqual . rtc_tc+  ppTycon    = F.toFix++  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)+                (tyConClass_maybe $ rtc_tc c)+  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)+                (tyConClass_maybe $ rtc_tc c)+  isOrdCls  c = maybe False isOrdClass (tyConClass_maybe $ rtc_tc c)+  isEqCls   c = isEqCls (rtc_tc c)+++instance TyConable TyCon where+  isFun      = isArrowTyCon+  isList     = (listTyCon ==)+  isTuple    = Ghc.isTupleTyCon+  isClass c  = isClassTyCon c   || isEqual c -- c == eqPrimTyCon+  isEqual c  = c == eqPrimTyCon || c == eqReprPrimTyCon+  ppTycon    = text . showPpr++  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)+                (tyConClass_maybe c)+  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)+                (tyConClass_maybe c)+  isOrdCls c  = maybe False isOrdClass+                (tyConClass_maybe c)+  isEqCls  c  = isPrelEqTyCon c++isClassOrSubClass :: (Class -> Bool) -> Class -> Bool+isClassOrSubClass p cls+  = p cls || any (isClassOrSubClass p . fst)+                 (mapMaybe getClassPredTys_maybe (classSCTheta cls))++-- MOVE TO TYPES+instance TyConable Symbol where+  isFun   s = F.funConName == s+  isList  s = F.listConName == s+  isTuple = isTupleSymbol+  ppTycon   = text . F.symbolString++instance TyConable F.LocSymbol where+  isFun   = isFun   . F.val+  isList  = isList  . F.val+  isTuple = isTuple . F.val+  ppTycon = ppTycon . F.val++instance TyConable BTyCon where+  isFun b = case F.val (btc_tc b) of+    LHNUnresolved _ s -> isFun s+    LHNResolved (LHRGHC n) _ -> n == unrestrictedFunTyConName+    _ -> False++  isList b = case F.val (btc_tc b) of+    LHNUnresolved _ s -> isList s+    LHNResolved (LHRGHC n) _ -> n == listTyConName+    _ -> False++  isTuple b = case F.val (btc_tc b) of+    LHNUnresolved _ s -> isTuple s+    LHNResolved (LHRGHC n) _ -> Ghc.isTupleTyConName n+    _ -> False++  isClass = isClassBTyCon++  ppTycon b = case F.val (btc_tc b) of+    LHNUnresolved _ s -> ppTycon s+    LHNResolved rn _ -> case rn of+      LHRGHC n -> text $ showPpr n+      LHRLocal s -> ppTycon s+      LHRIndex i -> text $ "(Unknown LHRIndex " ++ show i ++ ")"+      LHRLogic _ -> ppTycon $ lhNameToResolvedSymbol $ F.val $ btc_tc b++instance Eq RTyCon where+  x == y = rtc_tc x == rtc_tc y++instance Eq BTyCon where+  x == y = btc_tc x == btc_tc y++instance Ord BTyCon where+  compare x y = compare (btc_tc x) (btc_tc y)++instance F.Fixpoint RTyCon where+  toFix (RTyCon c _ _) = text $ showPpr c++instance F.Fixpoint BTyCon where+  toFix b = case F.val (btc_tc b) of+    LHNUnresolved _ s -> text $ F.symbolString s+    LHNResolved rn _ -> case rn of+      LHRGHC n -> text $ F.symbolString $ F.symbol n+      LHRLocal s -> text $ F.symbolString s+      LHRIndex i -> panic (Just $ fSrcSpan b) $ "toFix BTyCon: Unknown LHRIndex " ++ show i+      LHRLogic _ -> text $ F.symbolString $ lhNameToResolvedSymbol $ F.val $ btc_tc b++instance F.PPrint RTyCon where+  pprintTidy k c+    | ppDebug ppEnv = F.pprintTidy k tc  <-> angleBrackets (F.pprintTidy k pvs)+    | otherwise     = text . showPpr . rtc_tc $ c+    where+      tc            = F.symbol (rtc_tc c)+      pvs           = rtc_pvars c++instance F.PPrint BTyCon where+  pprintTidy _ b = case F.val (btc_tc b) of+    LHNUnresolved _ s -> text $ F.symbolString s+    LHNResolved rn _ -> case rn of+      LHRGHC n -> text $ F.symbolString $ F.symbol n+      LHRLocal s -> text $ F.symbolString s+      LHRIndex i -> text $ "(Unknown LHRIndex " ++ show i ++ ")"+      LHRLogic _ -> text $ F.symbolString $ lhNameToResolvedSymbol $ F.val $ btc_tc b++instance F.PPrint v => F.PPrint (RTVar v s) where+  pprintTidy k (RTVar x _) = F.pprintTidy k x++instance Show RTyCon where+  show = F.showpp++instance Show BTyCon where+  show = F.showpp++instance F.Loc BTyCon where+  srcSpan = F.srcSpan . btc_tc++defaultTyConInfo :: TyConInfo+defaultTyConInfo = TyConInfo [] [] Nothing+++-----------------------------------------------------------------------+-- | Co- and Contra-variance for TyCon --------------------------------+-----------------------------------------------------------------------++-- | Indexes start from 0 and type or predicate arguments can be both+--   covariant and contravaariant e.g., for the below Foo dataType+--+--     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>+--       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)+--+--  there will be:+--+--    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant]+--    variancePsArgs     = [Covariant, Contravatiant, Bivariant]+--++data TyConInfo = TyConInfo+  { varianceTyArgs  :: !VarianceInfo      -- ^ variance info for type variables+  , variancePsArgs  :: !VarianceInfo      -- ^ variance info for predicate variables+  , sizeFunction    :: !(Maybe SizeFun)   -- ^ logical UNARY function that computes the size of the structure+  } deriving (Generic, Data, Typeable)++instance NFData TyConInfo++instance Show TyConInfo where+  show (TyConInfo x y _) = show x ++ "\n" ++ show y++--------------------------------------------------------------------------------+-- | Unified Representation of Refinement Types --------------------------------+--------------------------------------------------------------------------------++type RTVU c tv = RTVUV Symbol c tv+type RTVUV v c tv = RTVar tv (RTypeV v c tv ())+type PVU c tv = PVUV Symbol c tv+type PVUV v c tv = PVarV v (RTypeV v c tv ())++instance Show tv => Show (RTVU c tv) where+  show (RTVar t _) = show t++type RType c tv r = RTypeV Symbol c tv r+data RTypeV v c tv r+  = RVar {+      rt_var    :: !tv+    , rt_reft   :: !r+    }++  | RFun  {+      rt_bind   :: !Symbol+    , rt_rinfo  :: !RFInfo+    , rt_in     :: !(RTypeV v c tv r)+    , rt_out    :: !(RTypeV v c tv r)+    , rt_reft   :: !r+    }++  | RAllT {+      rt_tvbind :: !(RTVUV v c tv) -- RTVar tv (RType c tv ()))+    , rt_ty     :: !(RTypeV v c tv r)+    , rt_ref    :: !r+    }++  -- | "forall x y <z :: Nat, w :: Int> . TYPE"+  --               ^^^^^^^^^^^^^^^^^^^ (rt_pvbind)+  | RAllP {+      rt_pvbind :: !(PVUV v c tv)+    , rt_ty     :: !(RTypeV v c tv r)+    }++  -- | For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)+  --   * the `RProp`  denoted by `{\h -> v > h}` to+  --   * the `RTyCon` denoted by `[]`.+  | RApp  {+      rt_tycon  :: !c+    , rt_args   :: ![RTypeV v c tv r]+    , rt_pargs  :: ![RTPropV v c tv r]+    , rt_reft   :: !r+    }++  | RAllE {+      rt_bind   :: !Symbol+    , rt_allarg :: !(RTypeV v c tv r)+    , rt_ty     :: !(RTypeV v c tv r)+    }++  | REx {+      rt_bind   :: !Symbol+    , rt_exarg  :: !(RTypeV v c tv r)+    , rt_ty     :: !(RTypeV v c tv r)+    }++  | RExprArg (F.Located (ExprV v))              -- ^ For expression arguments to type aliases+                                                --   see tests/pos/vector2.hs+  | RAppTy{+      rt_arg   :: !(RTypeV v c tv r)+    , rt_res   :: !(RTypeV v c tv r)+    , rt_reft  :: !r+    }++  | RRTy  {+      rt_env   :: ![(Symbol, RTypeV v c tv r)]+    , rt_ref   :: !r+    , rt_obl   :: !Oblig+    , rt_ty    :: !(RTypeV v c tv r)+    }++  | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`+            --   see tests/pos/Holes.hs+  deriving (Eq, Generic, Data, Typeable, Functor, Foldable, Traversable)+  deriving (B.Binary, Hashable) via Generically (RTypeV v c tv r)++instance (NFData c, NFData tv, NFData r)       => NFData (RType c tv r)++makeRTVar :: tv -> RTVar tv s+makeRTVar a = RTVar a (RTVNoInfo True)++instance (Eq tv) => Eq (RTVar tv s) where+  t1 == t2 = ty_var_value t1 == ty_var_value t2++data RTVar tv s = RTVar+  { ty_var_value :: tv+  , ty_var_info  :: RTVInfo s+  } deriving (Generic, Data, Typeable, Functor, Foldable, Traversable)+    deriving (B.Binary, Hashable) via Generically (RTVar tv s)++mapTyVarValue :: (tv1 -> tv2) -> RTVar tv1 s -> RTVar tv2 s+mapTyVarValue f v = v {ty_var_value = f $ ty_var_value v}++dropTyVarInfo :: RTVar tv s1 -> RTVar tv s2+dropTyVarInfo v = v{ty_var_info = RTVNoInfo True }++data RTVInfo s+  = RTVNoInfo { rtv_is_pol :: Bool }+  | RTVInfo { rtv_name   :: Symbol+            , rtv_kind   :: s+            , rtv_is_val :: Bool+            , rtv_is_pol :: Bool -- true iff the type variable gets instantiated with+                                 -- any refinement (ie is polymorphic on refinements),+                                 -- false iff instantiation is with true refinement+            } deriving (Generic, Data, Typeable, Functor, Eq, Foldable, Traversable)+              deriving (B.Binary, Hashable) via Generically (RTVInfo s)+++setRtvPol :: RTVar tv a -> Bool -> RTVar tv a+setRtvPol (RTVar a i) b = RTVar a (i{rtv_is_pol = b})++rTVarToBind :: RTVar RTyVar s  -> Maybe (Symbol, s)+rTVarToBind = go . ty_var_info+  where+    go RTVInfo{..} | rtv_is_val = Just (rtv_name, rtv_kind)+    go _                        = Nothing++instance (NFData tv, NFData s)     => NFData   (RTVar tv s)+instance (NFData s)                => NFData   (RTVInfo s)++-- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors.+--   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)+--   * the `RProp`  denoted by `{\h -> v > h}` to+--   * the `RTyCon` denoted by `[]`.+--   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated+--   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type.+--   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies+--   directly to any type and has semantics _independent of_ the data-type.++data Ref τ t = RProp+  { rf_args :: [(Symbol, τ)] -- ^ arguments. e.g. @h@ in the above example+  , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`. e.g. @v > h@ in the above example+  } deriving (Eq, Generic, Data, Typeable, Functor, Foldable, Traversable)+    deriving (B.Binary, Hashable) via Generically (Ref τ t)++instance (NFData τ,   NFData t)   => NFData   (Ref τ t)++rPropP :: [(Symbol, τ)] -> r -> Ref τ (RTypeV v c tv r)+rPropP τ r = RProp τ (RHole r)++-- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing.+--   In general, perhaps we need not expose @Ref@ directly at all.+type RTProp c tv r = RTPropV Symbol c tv r+type RTPropV v c tv r = Ref (RTypeV v c tv ()) (RTypeV v c tv r)++type UReft r = UReftV F.Symbol r+data UReftV v r = MkUReft+  { ur_reft   :: !r+  , ur_pred   :: !(PredicateV v)+  }+  deriving (Eq, Generic, Data, Typeable, Functor, Foldable, Traversable)+  deriving (B.Binary, Hashable) via Generically (UReftV v r)++mapUReftV :: (v -> v') -> (r -> r') -> UReftV v r -> UReftV v' r'+mapUReftV f g (MkUReft r p) = MkUReft (g r) (mapPredicateV f p)++emapUReftVM+  :: Monad m+  => ([Symbol] -> v -> m v') -> (r -> m r') -> UReftV v r -> m (UReftV v' r')+emapUReftVM f g (MkUReft r p) = MkUReft <$> g r <*> emapPredicateVM f p++type BRType      = RTypeV Symbol BTyCon BTyVar    -- ^ "Bare" parsed version+type BRTypeV v   = RTypeV v BTyCon BTyVar         -- ^ "Bare" parsed version+type RRType      = RTypeV Symbol RTyCon RTyVar    -- ^ "Resolved" version+type BSort       = BRType    ()+type BSortV v    = BRTypeV v ()+type RSort       = RRType    ()+type BPVar       = PVar      BSort+type RPVar       = PVar      RSort+type RReft       = RReftV    F.Symbol+type RReftV v    = UReftV v (F.ReftV v)+type BareType    = BareTypeV F.Symbol+type BareTypeParsed = BareTypeV F.LocSymbol+type BareTypeLHName = BareTypeV LHName+type BareTypeV v = BRTypeV v (RReftV v)+type SpecType    = RRType    RReft+type SpecProp    = RRProp    RReft+type RRProp r    = Ref       RSort (RRType r)+type BRProp r    = BRPropV Symbol r+type BRPropV v r = Ref       (BSortV v) (BRTypeV v r)+type SpecRTVar   = RTVar     RTyVar RSort++++type LocBareType = F.Located BareType+type LocBareTypeLHName = F.Located BareTypeLHName+type LocBareTypeParsed = F.Located BareTypeParsed+type LocSpecType = F.Located SpecType+++--------------------------------------------------------------------------------+-- | Printing Refinement Types -------------------------------------------------+--------------------------------------------------------------------------------++instance Show RTyVar where+  show = F.showpp++instance F.PPrint (UReft r) => Show (UReft r) where+  show = F.showpp++instance F.PPrint (RType c tv r) => Show (RType c tv r) where+  show = F.showpp++instance F.PPrint (RTProp c tv r) => Show (RTProp c tv r) where+  show = F.showpp++instance F.PPrint BTyVar where+  pprintTidy _ (BTV α) = text (F.symbolString $ F.val α)++instance F.PPrint RTyVar where+  pprintTidy k (RTV α)+   | ppTyVar ppEnv  = F.pprintTidy k (F.symbol α) -- shows full tyvar+   | otherwise      = ppr_tyvar_short α           -- drops the unique-suffix+   where+     ppr_tyvar_short :: TyVar -> Doc+     ppr_tyvar_short = text . showPpr++instance (F.PPrint r, F.PPrint t, F.PPrint (RType c tv r)) => F.PPrint (Ref t (RType c tv r)) where+  pprintTidy k (RProp ss s) = ppRefArgs k (fst <$> ss) <+> F.pprintTidy k s++ppRefArgs :: F.Tidy -> [Symbol] -> Doc+ppRefArgs _ [] = empty+ppRefArgs k ss = text "\\" <-> hsep (ppRefSym k <$> ss ++ [F.vv Nothing]) <+> "->"++ppRefSym :: (Eq a, IsString a, F.PPrint a) => F.Tidy -> a -> Doc+ppRefSym _ "" = text "_"+ppRefSym k s  = F.pprintTidy k s++-------------------------------------------++-- Should just make this a @Pretty@ instance but its too damn tedious+-- to figure out all the constraints.++type OkRT c tv r = ( TyConable c+                   , F.PPrint tv, F.PPrint c, F.PPrint r+                   , Reftable r, Reftable (RTProp c tv ()), Reftable (RTProp c tv r)+                   , Eq c, Eq tv+                   , Hashable tv+                   )++class Reftable r => UReftable r where+  ofUReft :: UReft F.Reft -> r+  ofUReft (MkUReft r _) = ofReft r+++instance UReftable (UReft F.Reft) where+   ofUReft r = r++instance UReftable () where+   ofUReft _ = mempty++class ToReftV r where+  type ReftVar r+  toReftV  :: r -> F.ReftV (ReftVar r)++instance ToReftV r => ToReftV (UReftV v r) where+  type ReftVar (UReftV v r) = ReftVar r+  toReftV = toReftV . ur_reft++instance ToReftV (F.ReftV v) where+  type ReftVar (F.ReftV v) = v+  toReftV = id++instance ToReftV () where+  type ReftVar () = Symbol+  toReftV _ = F.trueReft++class (Monoid r, F.Subable r) => Reftable r where+  isTauto :: r -> Bool+  ppTy    :: r -> Doc -> Doc++  top     :: r -> r+  top _   =  mempty++  meet    :: r -> r -> r+  meet    = mappend++  toReft  :: r -> F.Reft+  ofReft  :: F.Reft -> r++instance Semigroup F.Reft where+  (<>) = F.meetReft++instance Monoid F.Reft where+  mempty  = F.trueReft+  mappend = (<>)++instance Reftable () where+  isTauto _ = True+  ppTy _  d = d+  top  _    = ()+  meet _ _  = ()+  toReft _  = F.trueReft+  ofReft _  = ()++instance Reftable F.Reft where+  isTauto  = all F.isTautoPred . F.conjuncts . F.reftPred+  ppTy     = pprReft+  toReft   = id+  ofReft   = id+  top (F.Reft (v,_)) = F.Reft (v, F.PTrue)++instance F.Subable r => F.Subable (UReft r) where+  syms (MkUReft r p)     = F.syms r ++ F.syms p+  subst s (MkUReft r z)  = MkUReft (F.subst s r)  (F.subst s z)+  substf f (MkUReft r z) = MkUReft (F.substf f r) (F.substf f z)+  substa f (MkUReft r z) = MkUReft (F.substa f r) (F.substa f z)++instance (F.PPrint r, Reftable r) => Reftable (UReft r) where+  isTauto               = isTautoUreft+  ppTy                  = ppTyUreft+  toReft (MkUReft r ps) = toReft r `meet` toReft ps+  top (MkUReft r p)     = MkUReft (top r) (top p)+  ofReft r              = MkUReft (ofReft r) mempty++instance F.Expression (UReft ()) where+  expr = F.expr . toReft++ppTyUreft :: Reftable r => UReft r -> Doc -> Doc+ppTyUreft u@(MkUReft r p) d+  | isTautoUreft u = d+  | otherwise      = pprReft r (ppTy p d)++pprReft :: (Reftable r) => r -> Doc -> Doc+pprReft r d = braces (F.pprint v <+> colon <+> d <+> text "|" <+> F.pprint r')+  where+    r'@(F.Reft (v, _)) = toReft r++isTautoUreft :: Reftable r => UReft r -> Bool+isTautoUreft u = isTauto (ur_reft u) && isTauto (ur_pred u)++instance Reftable Predicate where+  isTauto (Pr ps)      = null ps++  ppTy r d | isTauto r      = d+           | not (ppPs ppEnv) = d+           | otherwise        = d <-> angleBrackets (F.pprint r)++  toReft (Pr ps@(p:_))        = F.Reft (parg p, F.pAnd $ pToRef <$> ps)+  toReft _                    = F.trueReft++  ofReft = todo Nothing "TODO: Predicate.ofReft"++pToRef :: PVar a -> F.Expr+pToRef p = pApp (pname p) $ F.EVar (parg p) : (thd3 <$> pargs p)++pApp      :: Symbol -> [Expr] -> Expr+pApp p es = F.mkEApp fn (F.EVar p:es)+  where+    fn    = F.dummyLoc (pappSym n)+    n     = length es++pappSym :: Show a => a -> Symbol+pappSym n  = F.symbol $ "papp" ++ show n
+ src/Language/Haskell/Liquid/Types/RTypeOp.hs view
@@ -0,0 +1,721 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE TupleSections              #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module should contain all the global type definitions and basic instances.++module Language.Haskell.Liquid.Types.RTypeOp (++  -- * Constructing & Destructing RTypes+    SpecRep+  , RTypeRep, RTypeRepV(..), fromRTypeRep, toRTypeRep+  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow+  , mkUnivs, bkUniv, bkClass, bkUnivClass, bkUnivClass'+  , rFun, rFun', rCls, rRCls, rFunDebug+  , classRFInfoType++  -- * Traversing `RType`+  , efoldReft, foldReft, foldReft'+  , emapReft, mapReft, mapReftM, mapPropM+  , emapReftM, emapRefM+  , mapExprReft+  , mapBot, mapBind, mapRFInfo+  , foldRType+  , emapFReftM+  , mapRTypeV+  , mapRTypeVM+  , mapDataDeclV+  , mapDataDeclVM+  , emapDataDeclM+  , emapDataCtorTyM+  , emapBareTypeVM+  , parsedToBareType++  -- * Converting To and From Sort+  , ofRSort, toRSort+  , rTypeValueVar+  , rTypeReft+  , stripRTypeBase+  , topRTypeBase++  -- * Some tests on RTypes+  , isBase+  , isFunTy+  , isTrivial+  , hasHoleTy++  -- * Scoping Info+  , BScope++  -- * Misc+  , addInvCond+  , insertsSEnv+  )+  where++import qualified Liquid.GHC.API as Ghc+import           Prelude                          hiding  (error)+import qualified Prelude++import           Control.Monad                          (liftM2, liftM3, liftM4, void)+import           Data.Bifunctor (first)++import qualified Language.Fixpoint.Types as F+import           Language.Fixpoint.Types (Expr, Symbol)++import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Misc+++-----------------------------------------------------------------------------+-- | Information about scope Binders Scope in+-----------------------------------------------------------------------------+{- In types with base refinement, e.g., {out:T {inner:a | ri} | ro }+If BScope = True , then the outer binder out is     in scope on ri+If BScope = False, then the outer binder out is not in scope on ri+-}++type BScope = Bool++--------------------------------------------------------------------------------+-- | Constructor and Destructors for RTypes ------------------------------------+--------------------------------------------------------------------------------+type RRep        = RTypeRep RTyCon RTyVar+type SpecRep     = RRep      RReft++type RTypeRep = RTypeRepV Symbol+data RTypeRepV v c tv r = RTypeRep+  { ty_vars   :: [(RTVar tv (RTypeV v c tv ()), r)]+  , ty_preds  :: [PVarV v (RTypeV v c tv ())]+  , ty_binds  :: [Symbol]+  , ty_info   :: [RFInfo]+  , ty_refts  :: [r]+  , ty_args   :: [RTypeV v c tv r]+  , ty_res    :: RTypeV v c tv r+  }++fromRTypeRep :: RTypeRepV v c tv r -> RTypeV v c tv r+fromRTypeRep RTypeRep{..}+  = mkArrow ty_vars ty_preds arrs ty_res+  where+    arrs = safeZip4WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_info, length ty_args, length ty_refts)) ty_binds ty_info ty_args ty_refts++classRFInfoType :: Bool -> RType c tv r -> RType c tv r+classRFInfoType b = fromRTypeRep .+                    (\trep@RTypeRep{..} -> trep{ty_info = map (\i -> i{permitTC = pure b}) ty_info}) .+                    toRTypeRep++--------------------------------------------------------------------------------+toRTypeRep           :: RTypeV v c tv r -> RTypeRepV v c tv r+--------------------------------------------------------------------------------+toRTypeRep t         = RTypeRep αs πs xs is rs ts t''+  where+    (αs, πs, t') = bkUniv t+    ((xs, is, ts, rs), t'') = bkArrow t'++mkArrow :: [(RTVar tv (RTypeV v c tv ()), r)]+        -> [PVarV v (RTypeV v c tv ())]+        -> [(Symbol, RFInfo, RTypeV v c tv r, r)]+        -> RTypeV v c tv r+        -> RTypeV v c tv r+mkArrow αs πs zts = mkUnivs αs πs . mkRFuns zts+  where+    mkRFuns xts t = foldr (\(b,i,t1,r) t2 -> RFun b i t1 t2 r) t xts++-- Do I need to keep track of implicits here too?+bkArrowDeep :: RType t t1 a -> ([Symbol], [RFInfo], [RType t t1 a], [a], RType t t1 a)+bkArrowDeep (RAllT _ t _)   = bkArrowDeep t+bkArrowDeep (RAllP _ t)     = bkArrowDeep t+bkArrowDeep (RFun x i t t' r) = let (xs, is, ts, rs, t'') = bkArrowDeep t' in+                                (x:xs, i:is, t:ts, r:rs, t'')+bkArrowDeep t               = ([], [], [], [], t)++bkArrow :: RTypeV v t t1 a -> ( ([Symbol], [RFInfo], [RTypeV v t t1 a], [a])+                           , RTypeV v t t1 a )+bkArrow t                = ((xs,is,ts,rs),t')+  where+    (xs, is, ts, rs, t') = bkFun t++bkFun :: RTypeV v t t1 a -> ([Symbol], [RFInfo], [RTypeV v t t1 a], [a], RTypeV v t t1 a)+bkFun (RFun x i t t' r) = let (xs, is, ts, rs, t'') = bkFun t' in+                          (x:xs, i:is, t:ts, r:rs, t'')+bkFun t                 = ([], [], [], [], t)++safeBkArrow ::(F.PPrint (RType t t1 a))+            => RType t t1 a -> ( ([Symbol], [RFInfo], [RType t t1 a], [a])+                               , RType t t1 a )+safeBkArrow t@RAllT {} = Prelude.error {- panic Nothing -} $ "safeBkArrow on RAllT" ++ F.showpp t+safeBkArrow (RAllP _ _)     = Prelude.error {- panic Nothing -} "safeBkArrow on RAllP"+safeBkArrow t               = bkArrow t++mkUnivs :: (Foldable t, Foldable t1)+        => t  (RTVar tv (RTypeV v c tv ()), r)+        -> t1 (PVarV v (RTypeV v c tv ()))+        -> RTypeV v c tv r+        -> RTypeV v c tv r+mkUnivs αs πs rt = foldr (\(a,r) t -> RAllT a t r) (foldr RAllP rt πs) αs++bkUnivClass :: SpecType -> ([(SpecRTVar, RReft)],[PVar RSort], [(RTyCon, [SpecType])], SpecType )+bkUnivClass t        = (as, ps, cs, t2)+  where+    (as, ps, t1) = bkUniv  t+    (cs, t2)     = bkClass t1+++bkUniv :: RTypeV v tv c r -> ([(RTVar c (RTypeV v tv c ()), r)], [PVarV v (RTypeV v tv c ())], RTypeV v tv c r)+bkUniv (RAllT α t r) = let (αs, πs, t') = bkUniv t in ((α, r):αs, πs, t')+bkUniv (RAllP π t)   = let (αs, πs, t') = bkUniv t in (αs, π:πs, t')+bkUniv t             = ([], [], t)+++-- bkFun :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)+-- bkFun (RFun x t t' r) = let (xs, ts, rs, t'') = bkFun t'  in (x:xs, t:ts, r:rs, t'')+-- bkFun t               = ([], [], [], t)++bkUnivClass' :: SpecType ->+  ([(SpecRTVar, RReft)], [PVar RSort], [(Symbol, SpecType, RReft)], SpecType)+bkUnivClass' t = (as, ps, zip3 bs ts rs, t2)+  where+    (as, ps, t1) = bkUniv  t+    (bs, ts, rs, t2)     = bkClass' t1++bkClass' :: TyConable t => RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)+bkClass' (RFun x _ t@(RApp c _ _ _) t' r)+  | isClass c+  = let (xs, ts, rs, t'') = bkClass' t' in (x:xs, t:ts, r:rs, t'')+bkClass' (RRTy e r o t)+  = let (xs, ts, rs, t'') = bkClass' t in (xs, ts, rs, RRTy e r o t'')+bkClass' t+  = ([], [],[],t)++bkClass :: (F.PPrint c, TyConable c) => RType c tv r -> ([(c, [RType c tv r])], RType c tv r)+bkClass (RFun _ _ (RApp c t _ _) t' _)+  | F.notracepp ("IS-CLASS: " ++ F.showpp c) $ isClass c+  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')+bkClass (RRTy e r o t)+  = let (cs, t') = bkClass t in (cs, RRTy e r o t')+bkClass t+  = ([], t)++rFun :: Monoid r => Symbol -> RTypeV v c tv r -> RTypeV v c tv r -> RTypeV v c tv r+rFun b t t' = RFun b defRFInfo t t' mempty++rFun' :: Monoid r => RFInfo -> Symbol -> RType c tv r -> RType c tv r -> RType c tv r+rFun' i b t t' = RFun b i t t' mempty++rFunDebug :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r+rFunDebug b t t' = RFun b (classRFInfo True) t t' mempty++rCls :: Monoid r => Ghc.TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r+rCls c ts   = RApp (RTyCon c [] defaultTyConInfo) ts [] mempty++rRCls :: Monoid r => c -> [RType c tv r] -> RType c tv r+rRCls rc ts = RApp rc ts [] mempty++addInvCond :: SpecType -> RReft -> SpecType+addInvCond t r'+  | isTauto $ ur_reft r' -- null rv+  = t+  | otherwise+  = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}+  where+    trep = toRTypeRep t+    tbd  = ty_res trep+    r    = r' {ur_reft = F.Reft (v, rx)}+    su   = (v, F.EVar x')+    x'   = "xInv"+    rx   = F.PIff (F.EVar v) $ F.subst1 rv su+    F.Reft(v, rv) = ur_reft r'+++instance (Reftable r, TyConable c) => F.Subable (RTProp c tv r) where+  syms (RProp  ss r)     = (fst <$> ss) ++ F.syms r++  subst su (RProp ss (RHole r)) = RProp ss (RHole (F.subst su r))+  subst su (RProp  ss t) = RProp ss (F.subst su <$> t)++  substf f (RProp ss (RHole r)) = RProp ss (RHole (F.substf f r))+  substf f (RProp  ss t) = RProp ss (F.substf f <$> t)++  substa f (RProp ss (RHole r)) = RProp ss (RHole (F.substa f r))+  substa f (RProp  ss t) = RProp ss (F.substa f <$> t)+++instance (F.Subable r, Reftable r, TyConable c) => F.Subable (RType c tv r) where+  syms        = foldReft False (\_ r acc -> F.syms r ++ acc) []+  -- 'substa' will substitute bound vars+  substa f    = emapExprArg (\_ -> F.substa f) []      . mapReft  (F.substa f)+  -- 'substf' will NOT substitute bound vars+  substf f    = emapExprArg (\_ -> F.substf f) []      . emapReft (F.substf . F.substfExcept f) []+  subst su    = emapExprArg (\_ -> F.subst su) []      . emapReft (F.subst  . F.substExcept su) []+  subst1 t su = emapExprArg (\_ e -> F.subst1 e su) [] $ emapReft (\xs r -> F.subst1Except xs r su) [] t+++--------------------------------------------------------------------------------+-- | Visitors ------------------------------------------------------------------+--------------------------------------------------------------------------------+mapExprReft :: (Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft+mapExprReft f = mapReft g+  where+    g (MkUReft (F.Reft (x, e)) p) = MkUReft (F.Reft (x, f x e)) p++-- const False (not dropping dict) is probably fine since there will not be refinement on+-- dictionaries+isTrivial :: (Reftable r, TyConable c) => RType c tv r -> Bool+isTrivial = foldReft False (\_ r b -> isTauto r && b) True++mapReft ::  (r1 -> r2) -> RTypeV v c tv r1 -> RTypeV v c tv r2+mapReft f = emapReft (const f) []++emapReft ::  ([Symbol] -> r1 -> r2) -> [Symbol] -> RTypeV v c tv r1 -> RTypeV v c tv r2+emapReft f γ (RVar α r)        = RVar  α (f γ r)+emapReft f γ (RAllT α t r)     = RAllT α (emapReft f γ t) (f γ r)+emapReft f γ (RAllP π t)       = RAllP π (emapReft f γ t)+emapReft f γ (RFun x i t t' r) = RFun  x i (emapReft f γ t) (emapReft f (x:γ) t') (f (x:γ) r)+emapReft f γ (RApp c ts rs r)  = RApp  c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r)+emapReft f γ (RAllE z t t')    = RAllE z (emapReft f γ t) (emapReft f γ t')+emapReft f γ (REx z t t')      = REx   z (emapReft f γ t) (emapReft f γ t')+emapReft _ _ (RExprArg e)      = RExprArg e+emapReft f γ (RAppTy t t' r)   = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)+emapReft f γ (RRTy e r o t)    = RRTy  (fmap (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)+emapReft f γ (RHole r)         = RHole (f γ r)++emapRef :: ([Symbol] -> t -> s) ->  [Symbol] -> RTPropV v c tv t -> RTPropV v c tv s+emapRef  f γ (RProp s (RHole r))  = RProp s $ RHole (f γ r)+emapRef  f γ (RProp s t)         = RProp s $ emapReft f γ t++mapRTypeV ::  (v -> v') -> RTypeV v c tv r -> RTypeV v' c tv r+mapRTypeV _ (RVar α r)        = RVar α r+mapRTypeV f (RAllT α t r)     = RAllT (fmap (mapRTypeV f) α) (mapRTypeV f t) r+mapRTypeV f (RAllP π t)       = RAllP (mapPVarV f (mapRTypeV f) π) (mapRTypeV f t)+mapRTypeV f (RFun x i t t' r) = RFun x i (mapRTypeV f t) (mapRTypeV f t') r+mapRTypeV f (RApp c ts rs r)  = RApp c (mapRTypeV f <$> ts) (mapRefV <$> rs) r+  where+    mapRefV (RProp ss t) = RProp (map (fmap (mapRTypeV f)) ss) (mapRTypeV f t)+mapRTypeV f (RAllE z t t')    = RAllE z (mapRTypeV f t) (mapRTypeV f t')+mapRTypeV f (REx z t t')      = REx z (mapRTypeV f t) (mapRTypeV f t')+mapRTypeV f (RExprArg e)      = RExprArg (fmap (fmap f) e)+mapRTypeV f (RAppTy t t' r)   = RAppTy (mapRTypeV f t) (mapRTypeV f t') r+mapRTypeV f (RRTy e r o t)    = RRTy (fmap (mapRTypeV f) <$> e) r o (mapRTypeV f t)+mapRTypeV _ (RHole r)         = RHole r++mapRTypeVM :: Monad m => (v -> m v') -> RTypeV v c tv r -> m (RTypeV v' c tv r)+mapRTypeVM _ (RVar α r)        = return $ RVar α r+mapRTypeVM f (RAllT α t r)     = RAllT <$> traverse (mapRTypeVM f) α <*> mapRTypeVM f t <*> pure r+mapRTypeVM f (RAllP π t)       = RAllP <$> emapPVarVM (const f) (const (mapRTypeVM f)) π <*> mapRTypeVM f t+mapRTypeVM f (RFun x i t t' r) = RFun x i <$> mapRTypeVM f t <*> mapRTypeVM f t' <*> pure r+mapRTypeVM f (RApp c ts rs r)  = RApp c <$> mapM (mapRTypeVM f) ts <*> mapM mapRefVM rs <*> pure r+  where+    mapRefVM (RProp ss t) = RProp <$> mapM (traverse (mapRTypeVM f)) ss <*> mapRTypeVM f t+mapRTypeVM f (RAllE z t t')    = RAllE z <$> mapRTypeVM f t <*> mapRTypeVM f t'+mapRTypeVM f (REx z t t')      = REx z <$> mapRTypeVM f t <*> mapRTypeVM f t'+mapRTypeVM f (RExprArg e)      = RExprArg <$> traverse (traverse f) e+mapRTypeVM f (RAppTy t t' r)   = RAppTy <$> mapRTypeVM f t <*> mapRTypeVM f t' <*> pure r+mapRTypeVM f (RRTy e r o t)    = RRTy <$> mapM (traverse (mapRTypeVM f)) e <*> pure r <*> pure o <*> mapRTypeVM f t+mapRTypeVM _ (RHole r)         = return (RHole r)++emapFReftM :: Monad m => ([Symbol] -> v -> m v') -> F.ReftV v -> m (F.ReftV v')+emapFReftM f (F.Reft (v, e)) = F.reft v <$> emapExprVM (f . (v:)) e++-- The first parameter corresponds to the bscope config setting+emapReftM+  :: (Monad m, ToReftV r1, F.Symbolic tv)+  => Bool+  -> ([Symbol] -> v1 -> m v2)+  -> ([Symbol] -> r1 -> m r2)+  -> [Symbol]+  -> RTypeV v1 c tv r1+  -> m (RTypeV v2 c tv r2)+emapReftM bscp vf f = go+  where+    go γ (RVar α r)        = RVar  α <$> f γ r+    go γ (RAllT α t r)     = RAllT <$> traverse (emapReftM bscp vf (const pure) γ) α <*> go (F.symbol (ty_var_value α) : γ) t <*> f γ r+    go γ (RAllP π t)       = RAllP <$> emapPVarVM vf (emapReftM bscp vf (const pure)) π <*> go γ t+    go γ (RFun x i t t' r) = RFun  x i <$> go (x:γ) t <*> go (x:γ) t' <*> f (x:γ) r+    go γ (RApp c ts rs r)  =+      let γ' = if bscp then F.reftBind (toReftV r) : γ  else γ+       in RApp  c <$> mapM (go γ') ts <*> mapM (emapRefM bscp vf f γ) rs <*> f γ r+    go γ (RAllE z t t')    = RAllE z <$> go γ t <*> go γ t'+    go γ (REx z t t')      = REx   z <$> go γ t <*> go γ t'+    go γ (RExprArg e)      = RExprArg <$> traverse (emapExprVM (vf . (++γ))) e+    go γ (RAppTy t t' r)   = RAppTy <$> go γ t <*> go γ t' <*> f γ r+    go γ (RRTy e r o t)    =+      RRTy <$> mapM (traverse (go (map fst e ++ γ))) e <*> f γ r <*> pure o <*> go γ t+    go γ (RHole r)         = RHole <$> f γ r++emapRefM+  :: (Monad m, ToReftV t, F.Symbolic tv)+  => Bool+  -> ([Symbol] -> v -> m v')+  -> ([Symbol] -> t -> m s)+  -> [Symbol]+  -> RTPropV v c tv t+  -> m (RTPropV v' c tv s)+emapRefM bscp vf f γ0 (RProp ss t0) =+    RProp . snd <$>+      mapAccumM+        (\γ (s, t) -> (s:γ,) . (s,) <$> emapReftM bscp vf (const pure) γ t)+        γ0+        ss+      <*> emapReftM bscp vf f (map fst ss ++ γ0) t0++emapBareTypeVM+  :: Monad m+  => Bool+  -> ([Symbol] -> v1 -> m v2)+  -> [Symbol]+  -> BareTypeV v1+  -> m (BareTypeV v2)+emapBareTypeVM bscp f =+    emapReftM+      bscp+      f+      (\e -> emapUReftVM (f . (++ e)) (emapFReftM (f . (++ e))))++mapDataDeclV :: (v -> v') -> DataDeclP v ty -> DataDeclP v' ty+mapDataDeclV f DataDecl {..} =+    DataDecl+      { tycPVars = map (mapPVarV f (mapRTypeV f)) tycPVars+      , tycSFun = fmap (fmap f) tycSFun+      , ..+      }++mapDataDeclVM :: Monad m => (v -> m v') -> DataDeclP v ty -> m (DataDeclP v' ty)+mapDataDeclVM f = emapDataDeclM False (const f) (const pure)++emapDataDeclM+  :: Monad m+  => Bool+  -> ([Symbol] -> v -> m v')+  -> ([Symbol] -> ty -> m ty')+  -> DataDeclP v ty+  -> m (DataDeclP v' ty')+emapDataDeclM bscp vf f d = do+    tycPVars <- mapM (emapPVarVM vf (emapReftM bscp vf (const pure))) $ tycPVars d+    tycDCons <- traverse (mapM (emapDataCtorTyM f)) (tycDCons d)+    tycSFun <- traverse (traverse (vf [])) (tycSFun d)+    tycPropTy <- traverse (f []) $ tycPropTy d+    return d{tycDCons, tycPVars, tycSFun, tycPropTy}++emapDataCtorTyM+  :: Monad m+  => ([Symbol] -> ty -> m ty')+  -> DataCtorP ty+  -> m (DataCtorP ty')+emapDataCtorTyM f d = do+    dcTheta <- mapM (f []) (dcTheta d)+    dcResult <- traverse (f (map (lhNameToUnqualifiedSymbol . fst) (dcFields d))) $ dcResult d+    dcFields <- snd <$> mapAccumM (\γ  (s, t) -> (lhNameToUnqualifiedSymbol s:γ,) . (s,) <$> f γ t) [] (dcFields d)+    return d{dcTheta, dcFields, dcResult}++emapExprArg :: ([Symbol] -> Expr -> Expr) -> [Symbol] -> RType c tv r -> RType c tv r+emapExprArg f = go+  where+    go _ t@RVar{}          = t+    go _ t@RHole{}         = t+    go γ (RAllT α t r)     = RAllT α (go γ t) r+    go γ (RAllP π t)       = RAllP π (go γ t)+    go γ (RFun x i t t' r) = RFun  x i (go γ t) (go (x:γ) t') r+    go γ (RApp c ts rs r)  = RApp  c (go γ <$> ts) (mo γ <$> rs) r+    go γ (RAllE z t t')    = RAllE z (go γ t) (go γ t')+    go γ (REx z t t')      = REx   z (go γ t) (go γ t')+    go γ (RExprArg e)      = RExprArg (f γ <$> F.notracepp "RExprArg" e) -- <---- actual substitution+    go γ (RAppTy t t' r)   = RAppTy (go γ t) (go γ t') r+    go γ (RRTy e r o t)    = RRTy  (fmap (go γ) <$> e) r o (go γ t)++    mo _ t@(RProp _ RHole{}) = t+    mo γ (RProp s t)         = RProp s (go γ t)++parsedToBareType :: BareTypeParsed -> BareType+parsedToBareType = mapRTypeV F.val . mapReft (mapUReftV F.val (fmap F.val))++foldRType :: (acc -> RType c tv r -> acc) -> acc -> RType c tv r -> acc+foldRType f = go+  where+    step a t                = go (f a t) t+    prep a (RProp _ RHole{}) = a+    prep a (RProp _ t)      = step a t+    go a RVar{}             = a+    go a RHole{}            = a+    go a RExprArg{}         = a+    go a (RAllT _ t _)      = step a t+    go a (RAllP _ t)        = step a t+    go a (RFun _ _ t t' _)  = foldl' step a [t, t']+    go a (RAllE _ t t')     = foldl' step a [t, t']+    go a (REx _ t t')       = foldl' step a [t, t']+    go a (RAppTy t t' _)    = foldl' step a [t, t']+    go a (RApp _ ts rs _)   = foldl' prep (foldl' step a ts) rs+    go a (RRTy e _ _ t)     = foldl' step a (t : (snd <$> e))++------------------------------------------------------------------------------------------------------+-- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t+-- same as GhcMisc isBaseType++-- isBase :: RType a -> Bool++-- set all types to basic types, haskell `tx -> t` is translated to Arrow tx t+-- isBase _ = True++isBase :: RType t t1 t2 -> Bool+isBase (RAllT _ t _)    = isBase t+isBase (RAllP _ t)      = isBase t+isBase (RVar _ _)       = True+isBase (RApp _ ts _ _)  = all isBase ts+isBase RFun{}           = False+isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2+isBase (RRTy _ _ _ t)   = isBase t+isBase (RAllE _ _ t)    = isBase t+isBase (REx _ _ t)      = isBase t+isBase _                = False++hasHoleTy :: RType t t1 t2 -> Bool+hasHoleTy (RVar _ _)        = False+hasHoleTy (RAllT _ t _)     = hasHoleTy t+hasHoleTy (RAllP _ t)       = hasHoleTy t+hasHoleTy (RFun _ _ t t' _) = hasHoleTy t || hasHoleTy t'+hasHoleTy (RApp _ ts _ _)   = any hasHoleTy ts+hasHoleTy (RAllE _ t t')    = hasHoleTy t || hasHoleTy t'+hasHoleTy (REx _ t t')      = hasHoleTy t || hasHoleTy t'+hasHoleTy (RExprArg _)      = False+hasHoleTy (RAppTy t t' _)   = hasHoleTy t || hasHoleTy t'+hasHoleTy (RHole _)         = True+hasHoleTy (RRTy xts _ _ t)  = hasHoleTy t || any hasHoleTy (snd <$> xts)++isFunTy :: RType t t1 t2 -> Bool+isFunTy (RAllE _ _ t)    = isFunTy t+isFunTy (RAllT _ t _)    = isFunTy t+isFunTy (RAllP _ t)      = isFunTy t+isFunTy RFun{}           = True+isFunTy _                = False++mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType c tv r2)+mapReftM f (RVar α r)        = fmap   (RVar  α)  (f r)+mapReftM f (RAllT α t r)     = liftM2 (RAllT α)  (mapReftM f t)         (f r)+mapReftM f (RAllP π t)       = fmap   (RAllP π)  (mapReftM f t)+mapReftM f (RFun x i t t' r) = liftM3 (RFun x i) (mapReftM f t)         (mapReftM f t')       (f r)+mapReftM f (RApp c ts rs r)  = liftM3 (RApp  c)  (mapM (mapReftM f) ts) (mapM (mapRefM f) rs) (f r)+mapReftM f (RAllE z t t')    = liftM2 (RAllE z)  (mapReftM f t)         (mapReftM f t')+mapReftM f (REx z t t')      = liftM2 (REx z)    (mapReftM f t)         (mapReftM f t')+mapReftM _ (RExprArg e)      = return $ RExprArg e+mapReftM f (RAppTy t t' r)   = liftM3 RAppTy (mapReftM f t) (mapReftM f t') (f r)+mapReftM f (RHole r)         = fmap   RHole      (f r)+mapReftM f (RRTy xts r o t)  = liftM4 RRTy (mapM (traverse (mapReftM f)) xts) (f r) (return o) (mapReftM f t)++mapRefM  :: (Monad m) => (t -> m s) -> RTProp c tv t -> m (RTProp c tv s)+mapRefM  f (RProp s t)        = fmap    (RProp s)      (mapReftM f t)++mapPropM :: (Monad m) => (RTProp c tv r -> m (RTProp c tv r)) -> RType c tv r -> m (RType c tv r)+mapPropM _ (RVar α r)        = return $ RVar  α r+mapPropM f (RAllT α t r)     = liftM2 (RAllT α)   (mapPropM f t)          (return r)+mapPropM f (RAllP π t)       = fmap   (RAllP π)   (mapPropM f t)+mapPropM f (RFun x i t t' r) = liftM3 (RFun x i)  (mapPropM f t)          (mapPropM f t') (return r)+mapPropM f (RApp c ts rs r)  = liftM3 (RApp  c)   (mapM (mapPropM f) ts)  (mapM f rs)     (return r)+mapPropM f (RAllE z t t')    = liftM2 (RAllE z)   (mapPropM f t)          (mapPropM f t')+mapPropM f (REx z t t')      = liftM2 (REx z)     (mapPropM f t)          (mapPropM f t')+mapPropM _ (RExprArg e)      = return $ RExprArg e+mapPropM f (RAppTy t t' r)   = liftM3 RAppTy (mapPropM f t) (mapPropM f t') (return r)+mapPropM _ (RHole r)         = return $ RHole r+mapPropM f (RRTy xts r o t)  = liftM4 RRTy (mapM (traverse (mapPropM f)) xts) (return r) (return o) (mapPropM f t)+++--------------------------------------------------------------------------------+-- foldReft :: (Reftable r, TyConable c) => (r -> a -> a) -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+-- foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptyF.SEnv++--------------------------------------------------------------------------------+foldReft :: (Reftable r, TyConable c) => BScope -> (F.SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+foldReft bsc f = foldReft'  (\_ _ -> False) bsc id (\γ _ -> f γ)++--------------------------------------------------------------------------------+foldReft' :: (Reftable r, TyConable c)+          => (Symbol -> RType c tv r -> Bool)+          -> BScope+          -> (RType c tv r -> b)+          -> (F.SEnv b -> Maybe (RType c tv r) -> r -> a -> a)+          -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+foldReft' logicBind bsc g f+  = efoldReft logicBind bsc+              (\_ _ -> [])+              (const [])+              g+              (\γ t r z -> f γ t r z)+              (\_ γ -> γ)+              F.emptySEnv++tyVarIsVal :: RTVar tv s -> Bool+tyVarIsVal = rtvinfoIsVal . ty_var_info++rtvinfoIsVal :: RTVInfo s -> Bool+rtvinfoIsVal RTVNoInfo{} = False+rtvinfoIsVal RTVInfo{..} = rtv_is_val++-- efoldReft :: Reftable r =>(p -> [RType c tv r] -> [(Symbol, a)])-> (RType c tv r -> a)-> (SEnv a -> Maybe (RType c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType c tv r-> c1+efoldReft :: (Reftable r, TyConable c)+          => (Symbol -> RType c tv r -> Bool)+          -> BScope+          -> (c  -> [RType c tv r] -> [(Symbol, a)])+          -> (RTVar tv (RType c tv ()) -> [(Symbol, a)])+          -> (RType c tv r -> a)+          -> (F.SEnv a -> Maybe (RType c tv r) -> r -> b -> b)+          -> (PVar (RType c tv ()) -> F.SEnv a -> F.SEnv a)+          -> F.SEnv a+          -> b+          -> RType c tv r+          -> b+efoldReft logicBind bsc cb dty g f fp = go+  where+    -- folding over RType+    go γ z me@(RVar _ r)                = f γ (Just me) r z+    go γ z me@(RAllT a t r)+       | tyVarIsVal a                   = f γ (Just me) r (go (insertsSEnv γ (dty a)) z t)+       | otherwise                      = f γ (Just me) r (go γ z t)+    go γ z (RAllP p t)                  = go (fp p γ) z t+    go γ z me@(RFun _ RFInfo{permitTC = permitTC} (RApp c ts _ _) t' r)+       | (if permitTC == Just True then isEmbeddedDict else isClass)+         c  = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')+    go γ z me@(RFun x _ t t' r)+       | logicBind x t                  = f γ (Just me) r (go γ' (go γ z t) t')+       | otherwise                      = f γ (Just me) r (go γ  (go γ z t) t')+       where+         γ'                             = insertSEnv x (g t) γ+    go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' γ' z ts) rs)+       where γ' = if bsc then insertSEnv (rTypeValueVar me) (g me) γ else γ++    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'+    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'+    go γ z me@(RRTy [] r _ t)           = f γ (Just me) r (go γ z t)+    go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)+    go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')+    go _ z (RExprArg _)                 = z+    go γ z me@(RHole r)                 = f γ (Just me) r z++    -- folding over Ref+    ho  γ z (RProp ss (RHole r))       = f (insertsSEnv γ (fmap (g . ofRSort) <$> ss)) Nothing r z+    ho  γ z (RProp ss t)               = go (insertsSEnv γ (fmap (g . ofRSort) <$> ss)) z t++    -- folding over [RType]+    go' γ z ts                 = foldr (flip $ go γ) z ts++    -- folding over [Ref]+    ho' γ z rs                 = foldr (flip $ ho γ) z rs++    envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)++mapRFInfo :: (RFInfo -> RFInfo) -> RType c tv r -> RType c tv r+mapRFInfo f (RAllT α t r)     = RAllT α (mapRFInfo f t) r+mapRFInfo f (RAllP π t)       = RAllP π (mapRFInfo f t)+mapRFInfo f (RFun x i t t' r) = RFun x (f i) (mapRFInfo f t) (mapRFInfo f t') r+mapRFInfo f (RAppTy t t' r)   = RAppTy (mapRFInfo f t) (mapRFInfo f t') r+mapRFInfo f (RApp c ts rs r)  = RApp c (mapRFInfo f <$> ts) (mapRFInfoRef f <$> rs) r+mapRFInfo f (REx b t1 t2)     = REx b  (mapRFInfo f t1) (mapRFInfo f t2)+mapRFInfo f (RAllE b t1 t2)   = RAllE b (mapRFInfo f t1) (mapRFInfo f t2)+mapRFInfo f (RRTy e r o t)    = RRTy (fmap (mapRFInfo f) <$> e) r o (mapRFInfo f t)+mapRFInfo _ t'                = t'++mapRFInfoRef :: (RFInfo -> RFInfo)+          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)+mapRFInfoRef _ (RProp s (RHole r)) = RProp s $ RHole r+mapRFInfoRef f (RProp s t)    = RProp  s $ mapRFInfo f t++mapBot :: (RType c tv r -> RType c tv r) -> RType c tv r -> RType c tv r+mapBot f (RAllT α t r)     = RAllT α (mapBot f t) r+mapBot f (RAllP π t)       = RAllP π (mapBot f t)+mapBot f (RFun x i t t' r) = RFun x i (mapBot f t) (mapBot f t') r+mapBot f (RAppTy t t' r)   = RAppTy (mapBot f t) (mapBot f t') r+mapBot f (RApp c ts rs r)  = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r+mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2)+mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2)+mapBot f (RRTy e r o t)    = RRTy (fmap (mapBot f) <$> e) r o (mapBot f t)+mapBot f t'                = f t'++mapBotRef :: (RType c tv r -> RType c tv r)+          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)+mapBotRef _ (RProp s (RHole r)) = RProp s $ RHole r+mapBotRef f (RProp s t)         = RProp s $ mapBot f t++mapBind :: (Symbol -> Symbol) -> RTypeV v c tv r -> RTypeV v c tv r+mapBind f (RAllT α t r)      = RAllT α (mapBind f t) r+mapBind f (RAllP π t)        = RAllP π (mapBind f t)+mapBind f (RFun b i t1 t2 r) = RFun (f b) i (mapBind f t1) (mapBind f t2) r+mapBind f (RApp c ts rs r)   = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r+mapBind f (RAllE b t1 t2)    = RAllE  (f b) (mapBind f t1) (mapBind f t2)+mapBind f (REx b t1 t2)      = REx    (f b) (mapBind f t1) (mapBind f t2)+mapBind _ (RVar α r)         = RVar α r+mapBind _ (RHole r)          = RHole r+mapBind f (RRTy e r o t)     = RRTy e r o (mapBind f t)+mapBind _ (RExprArg e)       = RExprArg e+mapBind f (RAppTy t t' r)    = RAppTy (mapBind f t) (mapBind f t') r++mapBindRef :: (Symbol -> Symbol)+           -> Ref τ (RTypeV v c tv r) -> Ref τ (RTypeV v c tv r)+mapBindRef f (RProp s (RHole r)) = RProp (first f <$> s) (RHole r)+mapBindRef f (RProp s t)         = RProp (first f <$> s) $ mapBind f t+++--------------------------------------------------+ofRSort ::  Reftable r => RType c tv () -> RType c tv r+ofRSort = fmap mempty++toRSort :: RTypeV v c tv r -> RTypeV v c tv ()+toRSort = stripAnnotations . mapBind (const F.dummySymbol) . void++stripAnnotations :: RTypeV v c tv r -> RTypeV v c tv r+stripAnnotations (RAllT α t r)     = RAllT α (stripAnnotations t) r+stripAnnotations (RAllP _ t)       = stripAnnotations t+stripAnnotations (RAllE _ _ t)     = stripAnnotations t+stripAnnotations (REx _ _ t)       = stripAnnotations t+stripAnnotations (RFun x i t t' r) = RFun x i (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RAppTy t t' r)   = RAppTy (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RApp c ts rs r)  = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r+stripAnnotations (RRTy _ _ _ t)    = stripAnnotations t+stripAnnotations t                 = t++stripAnnotationsRef :: Ref τ (RTypeV v c tv r) -> Ref τ (RTypeV v c tv r)+stripAnnotationsRef (RProp s (RHole r)) = RProp s (RHole r)+stripAnnotationsRef (RProp s t)         = RProp s $ stripAnnotations t++insertSEnv :: F.Symbol -> a -> F.SEnv a -> F.SEnv a+insertSEnv = F.insertSEnv++insertsSEnv :: F.SEnv a -> [(Symbol, a)] -> F.SEnv a+insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)++rTypeValueVar :: (Reftable r) => RType c tv r -> Symbol+rTypeValueVar t = vv where F.Reft (vv,_) =  rTypeReft t++rTypeReft :: (Reftable r) => RType c tv r -> F.Reft+rTypeReft = maybe F.trueReft toReft . stripRTypeBase++-- stripRTypeBase ::  RType a -> Maybe a+stripRTypeBase :: RType c tv r -> Maybe r+stripRTypeBase (RApp _ _ _ x)   = Just x+stripRTypeBase (RVar _ x)       = Just x+stripRTypeBase (RFun _ _ _ _ x) = Just x+stripRTypeBase (RAppTy _ _ x)   = Just x+stripRTypeBase (RAllT _ _ x)    = Just x+stripRTypeBase _                = Nothing++topRTypeBase :: (Reftable r) => RType c tv r -> RType c tv r+topRTypeBase = mapRBase top++mapRBase :: (r -> r) -> RType c tv r -> RType c tv r+mapRBase f (RApp c ts rs r)   = RApp c ts rs $ f r+mapRBase f (RVar a r)         = RVar a $ f r+mapRBase f (RFun x i t1 t2 r) = RFun x i t1 t2 $ f r+mapRBase f (RAppTy t1 t2 r)   = RAppTy t1 t2 $ f r+mapRBase _ t                  = t
src/Language/Haskell/Liquid/Types/RefType.hs view
@@ -67,6 +67,7 @@    -- * Manipulating Refinements in RTypes   , strengthen+  , strengthenWith   , generalize   , normalizePds   , dataConMsReft@@ -111,13 +112,15 @@ import           Language.Haskell.Liquid.Types.Errors import           Language.Haskell.Liquid.Types.PrettyPrint -import           Language.Haskell.Liquid.Types.Types hiding (R, DataConP (..))+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.Variance import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Types.Names import qualified Language.Haskell.Liquid.GHC.Misc as GM import           Language.Haskell.Liquid.GHC.Play (mapType, stringClassArg, isRecursivenewTyCon)-import           Liquid.GHC.API        as Ghc hiding ( Expr+import           Liquid.GHC.API        as Ghc hiding ( Expr, get                                                                       , Located                                                                       , tyConName                                                                       , punctuate@@ -161,8 +164,8 @@     isValTy      = not . Ghc.isEvVarType . toType False  -pdVar :: PVar t -> Predicate-pdVar v        = Pr [uPVar v]+pdVar :: PVarV v t -> PredicateV v+pdVar v  = Pr [uPVar v]  findPVar :: [PVar (RType c tv ())] -> UsedPVar -> PVar (RType c tv ()) findPVar ps upv = PV name ty v (zipWith (\(_, _, e) (t, s, _) -> (t, s, e)) (pargs upv) args)@@ -181,14 +184,14 @@ uRTypeGen       :: Reftable b => RType c tv a -> RType c tv b uRTypeGen       = fmap $ const mempty -uPVar           :: PVar t -> UsedPVar+uPVar           :: PVarV v t -> UsedPVarV v uPVar           = void  uReft           :: (Symbol, Expr) -> UReft Reft uReft           = uTop . Reft -uTop            ::  r -> UReft r-uTop r          = MkUReft r mempty+uTop            ::  r -> UReftV v r+uTop r          = MkUReft r (Pr [])  -------------------------------------------------------------------- -------------- (Class) Predicates for Valid Refinement Types -------@@ -285,8 +288,6 @@   ppTy (RProp _ (RHole r)) d  = ppTy r d   ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"   toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"   ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"  instance Reftable (RTProp RTyCon RTyVar ()) where@@ -297,8 +298,6 @@   ppTy (RProp _ (RHole r)) d  = ppTy r d   ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"   toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"   ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"  instance Reftable (RTProp BTyCon BTyVar (UReft Reft)) where@@ -309,8 +308,6 @@   ppTy (RProp _ (RHole r)) d  = ppTy r d   ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"   toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"   ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"  instance Reftable (RTProp BTyCon BTyVar ())  where@@ -321,8 +318,6 @@   ppTy (RProp _ (RHole r)) d  = ppTy r d   ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"   toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"   ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"  instance Reftable (RTProp RTyCon RTyVar Reft) where@@ -333,8 +328,6 @@   ppTy (RProp _ (RHole r)) d  = ppTy r d   ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"   toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"   ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"  ----------------------------------------------------------------------------@@ -346,15 +339,15 @@   syms (RProp ss t)      = (fst <$> ss) ++ syms t  -  subst su (RProp ss (RHole r)) = RProp (mapSnd (subst su) <$> ss) $ RHole $ subst su r-  subst su (RProp ss r)  = RProp  (mapSnd (subst su) <$> ss) $ subst su r+  subst su (RProp ss (RHole r)) = RProp (fmap (subst su) <$> ss) $ RHole $ subst su r+  subst su (RProp ss r)  = RProp  (fmap (subst su) <$> ss) $ subst su r  -  substf f (RProp ss (RHole r)) = RProp (mapSnd (substf f) <$> ss) $ RHole $ substf f r-  substf f (RProp ss r) = RProp  (mapSnd (substf f) <$> ss) $ substf f r+  substf f (RProp ss (RHole r)) = RProp (fmap (substf f) <$> ss) $ RHole $ substf f r+  substf f (RProp ss r) = RProp  (fmap (substf f) <$> ss) $ substf f r -  substa f (RProp ss (RHole r)) = RProp (mapSnd (substa f) <$> ss) $ RHole $ substa f r-  substa f (RProp ss r) = RProp  (mapSnd (substa f) <$> ss) $ substa f r+  substa f (RProp ss (RHole r)) = RProp (fmap (substa f) <$> ss) $ RHole $ substa f r+  substa f (RProp ss r) = RProp  (fmap (substa f) <$> ss) $ substa f r   -------------------------------------------------------------------------------@@ -366,8 +359,6 @@   isTauto     = isTrivial   ppTy        = panic Nothing "ppTy RProp Reftable"   toReft      = panic Nothing "toReft on RType"-  params      = panic Nothing "params on RType"-  bot         = panic Nothing "bot on RType"   ofReft      = panic Nothing "ofReft on RType"  @@ -376,8 +367,6 @@   top t       = mapReft top t   ppTy        = panic Nothing "ppTy RProp Reftable"   toReft      = panic Nothing "toReft on RType"-  params      = panic Nothing "params on RType"-  bot         = panic Nothing "bot on RType"   ofReft      = panic Nothing "ofReft on RType"  @@ -480,7 +469,7 @@ rTVar a = RTVar (RTV a) (rTVarInfo a)  bTVar :: Monoid r => TyVar -> RTVar BTyVar (BRType r)-bTVar a = RTVar (BTV (symbol a)) (bTVarInfo a)+bTVar a = RTVar (BTV (symbol <$> GM.locNamedThing a)) (bTVarInfo a)  bTVarInfo :: Monoid r => TyVar -> RTVInfo (BRType r) bTVarInfo = mkTVarInfo kindToBRType@@ -515,14 +504,14 @@     let x = expandTypeSynonyms x0      in x == naturalTy || x == typeSymbolKind -bTyVar :: Symbol -> BTyVar+bTyVar :: LocSymbol -> BTyVar bTyVar      = BTV  symbolRTyVar :: Symbol -> RTyVar symbolRTyVar = rTyVar . GM.symbolTyVar  bareRTyVar :: BTyVar -> RTyVar-bareRTyVar (BTV tv) = symbolRTyVar tv+bareRTyVar (BTV tv) = symbolRTyVar $ val tv  normalizePds :: (OkRT c tv r) => RType c tv r -> RType c tv r normalizePds t = addPds ps t'@@ -560,9 +549,11 @@ bApp c = RApp (tyConBTyCon c)  tyConBTyCon :: TyCon -> BTyCon-tyConBTyCon = mkBTyCon . fmap tyConName . GM.locNamedThing--- tyConBTyCon = mkBTyCon . fmap symbol . locNamedThing+tyConBTyCon tc =+    mkBTyCon $+      makeResolvedLHName (LHRGHC (getName tc)) . tyConName <$> GM.locNamedThing tc + --- NV TODO : remove this code!!!  addPds :: Foldable t@@ -709,26 +700,33 @@ strengthenRefType_ f t1 t2   = f t1 t2 -meets :: (F.Reftable r) => [r] -> [r] -> [r]+meets :: (Reftable r) => [r] -> [r] -> [r] meets [] rs                 = rs meets rs []                 = rs meets rs rs'   | length rs == length rs' = zipWith meet rs rs'   | otherwise               = panic Nothing "meets: unbalanced rs" -strengthen :: Reftable r => RType c tv r -> r -> RType c tv r-strengthen (RApp c ts rs r)   r' = RApp c ts rs   (r `F.meet` r')-strengthen (RVar a r)         r' = RVar a         (r `F.meet` r')-strengthen (RFun b i t1 t2 r) r' = RFun b i t1 t2 (r `F.meet` r')-strengthen (RAppTy t1 t2 r)   r' = RAppTy t1 t2   (r `F.meet` r')-strengthen (RAllT a t r)      r' = RAllT a t      (r `F.meet` r')-strengthen t                  _  = t+strengthen :: Reftable r => RTypeV v c tv r -> r -> RTypeV v c tv r+strengthen = strengthenWith meet -quantifyRTy :: (Monoid r, Eq tv) => [RTVar tv (RType c tv ())] -> RType c tv r -> RType c tv r+strengthenWith :: (r -> r -> r) -> RTypeV v c tv r -> r -> RTypeV v c tv r+strengthenWith mt = go+  where+    go (RApp c ts rs r)   r' = RApp c ts rs   (r `mt` r')+    go (RVar a r)         r' = RVar a         (r `mt` r')+    go (RFun b i t1 t2 r) r' = RFun b i t1 t2 (r `mt` r')+    go (RAppTy t1 t2 r)   r' = RAppTy t1 t2   (r `mt` r')+    go (RAllT a t r)      r' = RAllT a t      (r `mt` r')+    go (RHole r)          r' = RHole          (r `mt` r')+    go t                  _  = t+++quantifyRTy :: (Monoid r, Eq tv) => [RTVar tv (RTypeV v c tv ())] -> RTypeV v c tv r -> RTypeV v c tv r quantifyRTy tvs ty = foldr rAllT ty tvs   where rAllT a t = RAllT a t mempty -quantifyFreeRTy :: (Monoid r, Eq tv) => RType c tv r -> RType c tv r+quantifyFreeRTy :: (Monoid r, Eq tv) => RTypeV v c tv r -> RTypeV v c tv r quantifyFreeRTy ty = quantifyRTy (freeTyVars ty) ty  @@ -771,11 +769,7 @@       SubsTy tv (RType c tv ()) tv,       SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))    => PVar (RType c tv ()) -> Ref (RType c tv ()) (RType c tv r)-rtPropTop pv = case ptype pv of-                 PVProp t -> RProp xts $ ofRSort t-                 PVHProp  -> RProp xts mempty-               where-                 xts      =  pvArgs pv+rtPropTop pv = RProp (pvArgs pv) $ ofRSort $ ptype pv  rtPropPV :: (Fixpoint a, Reftable r)          => a@@ -930,7 +924,7 @@     vs'     = freeTyVars t  -freeTyVars :: Eq tv => RType c tv r -> [RTVar tv (RType c tv ())]+freeTyVars :: Eq tv => RTypeV v c tv r -> [RTVar tv (RTypeV v c tv ())] freeTyVars (RAllP _ t)       = freeTyVars t freeTyVars (RAllT α t _)     = freeTyVars t L.\\ [α] freeTyVars (RFun _ _ t t' _) = freeTyVars t `L.union` freeTyVars t'@@ -1071,7 +1065,7 @@ subsFree _ _ _ t@(RExprArg _)   = t subsFree m s z@(α, τ, _) (RRTy e r o t)-  = RRTy (mapSnd (subsFree m s z) <$> e) (subt (α, τ) r) o (subsFree m s z t)+  = RRTy (fmap (subsFree m s z) <$> e) (subt (α, τ) r) o (subsFree m s z t) subsFree _ _ (α, τ, _) (RHole r)   = RHole (subt (α, τ) r) @@ -1128,7 +1122,7 @@   -> r   -> RType c tv r mkRApp m s c ts rs r r'-  | isFun c, [_rep1, _rep2, t1, t2] <- ts+  | isFun c, [_m, _rep1, _rep2, t1, t2] <- ts   = RFun dummySymbol defRFInfo t1 t2 (refAppTyToFun r')   | otherwise   = subsFrees m s zs (RApp c ts rs (r `meet` r'))@@ -1194,9 +1188,9 @@   -> RTProp c tv r   -> RTProp c tv r subsFreeRef _ _ (α', τ', _) (RProp ss (RHole r))-  = RProp (mapSnd (subt (α', τ')) <$> ss) (RHole r)+  = RProp (fmap (subt (α', τ')) <$> ss) (RHole r) subsFreeRef m s (α', τ', t')  (RProp ss t)-  = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t+  = RProp (fmap (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t   --------------------------------------------------------------------------------@@ -1235,12 +1229,12 @@   subt su (Reft (x, e)) = Reft (x, subt su e)  instance SubsTy Symbol Symbol (BRType r) where-  subt (x,y) (RVar v r)-    | BTV x == v = RVar (BTV y) r-    | otherwise  = RVar v r-  subt (x, y) (RAllT (RTVar v i) t r)-    | BTV x == v = RAllT (RTVar v i) t r-    | otherwise  = RAllT (RTVar v i) (subt (x,y) t) r+  subt (x,y) (RVar (BTV v) r)+    | x == val v = RVar (BTV (y <$ v)) r+    | otherwise  = RVar (BTV v) r+  subt (x, y) (RAllT (RTVar (BTV v) i) t r)+    | x == val v = RAllT (RTVar (BTV v) i) t r+    | otherwise  = RAllT (RTVar (BTV v) i) (subt (x,y) t) r   subt su (RFun x i t1 t2 r)  = RFun x i (subt su t1) (subt su t2) r   subt su (RAllP p t)       = RAllP p (subt su t)   subt su (RApp c ts ps r)  = RApp c (subt su <$> ts) (subt su <$> ps) r@@ -1298,10 +1292,6 @@     | otherwise     = FObj s   subt _ s          = s -instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where-  subt su (PVProp t) = PVProp (subt su t)-  subt _   PVHProp   = PVHProp- instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where   subt su (PV n pvk v xts) = PV n (subt su pvk) v [(subt su t, x, y) | (t,x,y) <- xts] @@ -1312,10 +1302,6 @@        ps'  = subt z <$> rTyConPVs c        i    = rtc_info c --- NOTE: This DOES NOT substitute at the binders-instance SubsTy RTyVar RSort PrType where-  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)- instance SubsTy RTyVar RSort SpecType where   subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ) @@ -1343,8 +1329,8 @@   subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)  instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType c tv ())) => SubsTy tv ty (RTProp c tv (UReft r))  where-  subt m (RProp ss (RHole p)) = RProp (mapSnd (subt m) <$> ss) $ RHole $ subt m p-  subt m (RProp ss t) = RProp (mapSnd (subt m) <$> ss) $ fmap (subt m) t+  subt m (RProp ss (RHole p)) = RProp (fmap (subt m) <$> ss) $ RHole $ subt m p+  subt m (RProp ss t) = RProp (fmap (subt m) <$> ss) $ fmap (subt m) t  subvUReft     :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft subvUReft f (MkUReft r p) = MkUReft r (subvPredicate f p)@@ -1366,7 +1352,7 @@ bareOfType :: Monoid r => Type -> BRType r -------------------------------------------------------------------------------- bareOfType  = ofType_ $ TyConv-  { tcFVar  = (`RVar` mempty) . BTV . symbol+  { tcFVar  = (`RVar` mempty) . BTV . fmap symbol . GM.locNamedThing   , tcFTVar = bTVar   , tcFApp  = \c ts -> bApp c ts [] mempty   , tcFLit  = ofLitType bApp@@ -1569,7 +1555,7 @@  -------------------------------------------------------------------------------- -- shiftVV :: Int -- SpecType -> Symbol -> SpecType-shiftVV :: (TyConable c, F.Reftable (f Reft), Functor f)+shiftVV :: (TyConable c, Reftable (f Reft), Functor f)         => RType c tv (f Reft) -> Symbol -> RType c tv (f Reft) -------------------------------------------------------------------------------- shiftVV t@(RApp _ ts rs r) vv'@@ -1615,6 +1601,7 @@     go (TyConApp c τs)       | isNewTyCon c       , not (isRecursivenewTyCon c)+      , τs `lengthAtLeast` newTyConEtadArity c       = go (Ghc.newTyConInstRhs c τs)       | otherwise       = tyConFTyCon tce c (go <$> τs)@@ -1654,7 +1641,7 @@ tyConName :: TyCon -> Symbol tyConName c   | listTyCon == c    = listConName-  | Ghc.isTupleTyCon c = tupConName+  | Ghc.isTupleTyCon c = symbol $ "Tuple" ++ show (tyConArity c)   | otherwise         = symbol c  typeSortFun :: TCEmb TyCon -> Type -> Sort@@ -1839,60 +1826,6 @@   where     tcTv                      = if null userTv then defTv else userTv     defTv                     = makeTyConVariance c-------------------------------------------------------------------------------------- | Printing Refinement Types ------------------------------------------------------------------------------------------------------------------------------------instance Show RTyVar where-  show = showpp--instance PPrint (UReft r) => Show (UReft r) where-  show = showpp--instance PPrint DataDecl where-  pprintTidy k dd =-    let-      prefix = "data" <+> pprint (tycName dd) <+> ppMbSizeFun (tycSFun dd) <+> pprint (tycTyVars dd)-    in-      case tycDCons dd of-        Nothing   -> prefix-        Just cons -> prefix <+> "=" $+$ nest 4 (vcat $ [ "|" <+> pprintTidy k c | c <- cons ])--instance PPrint DataCtor where-  -- pprintTidy k (DataCtor c as _   xts Nothing)  = pprintTidy k c <+> dcolon ppVars as <+> braces (ppFields k ", " xts)-  -- pprintTidy k (DataCtor c as ths xts (Just t)) = pprintTidy k c <+> dcolon <+> ppVars as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> pprintTidy k t-  pprintTidy k (DataCtor c as ths xts t) = pprintTidy k c <+> dcolon <+> ppVars k as <+> ppThetas ths <+> ppFields k " ->" xts <+> "->" <+> res-    where-      res         = maybe "*" (pprintTidy k) t-      ppThetas [] = empty-      ppThetas ts = parens (hcat $ punctuate ", " (pprintTidy k <$> ts)) <+> "=>"---ppVars :: (PPrint a) => Tidy -> [a] -> Doc-ppVars k as = "forall" <+> hcat (punctuate " " (F.pprintTidy k <$> as)) <+> "."--ppFields :: (PPrint k, PPrint v) => Tidy -> Doc -> [(k, v)] -> Doc-ppFields k sep' kvs = hcat $ punctuate sep' (F.pprintTidy k <$> kvs)--ppMbSizeFun :: Maybe SizeFun -> Doc-ppMbSizeFun Nothing  = ""-ppMbSizeFun (Just z) = F.pprint z---- instance PPrint DataCtor where-  -- pprintTidy k (DataCtor c xts t) =-    -- pprintTidy k c <+> text "::" <+> (hsep $ punctuate (text "->")-                                          -- ((pprintTidy k <$> xts) ++ [pprintTidy k t]))---- ppHack :: (?callStack :: CallStack) => a -> b--- ppHack _ = errorstar "OOPS"--instance PPrint (RType c tv r) => Show (RType c tv r) where-  show = showpp--instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where-  show = showpp   -------------------------------------------------------------------------------
src/Language/Haskell/Liquid/Types/Specs.hs view
@@ -1,12 +1,15 @@-{-# LANGUAGE DeriveAnyClass #-} -- | This module contains the top-level structures that hold --   information about specifications.  {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE NamedFieldPuns             #-} {-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE UndecidableInstances       #-}  {-# OPTIONS_GHC -Wno-orphans #-} @@ -23,7 +26,9 @@   , TargetSpec(..)   -- * BareSpec   -- $bareSpec-  , BareSpec(..)+  , BareSpec+  , BareSpecLHName+  , BareSpecParsed   -- * LiftedSpec   -- $liftedSpec   , LiftedSpec(..)@@ -43,14 +48,17 @@   , GhcSpecNames(..)   , GhcSpecTerm(..)   , GhcSpecRefl(..)-  , GhcSpecLaws(..)   , GhcSpecData(..)   , GhcSpecQual(..)   , BareDef   , BareMeasure   , SpecMeasure   , VarOrLocSymbol-  , LawInstance(..)+  , emapSpecM+  , fromBareSpecLHName+  , fromBareSpecParsed+  , mapSpecLName+  , mapSpecTy   -- * Legacy data structures   -- $legacyDataStructures   , GhcSrc(..)@@ -60,26 +68,33 @@   , toTargetSrc   , fromTargetSrc   , toTargetSpec-  , toBareSpec-  , fromBareSpec   , toLiftedSpec   , unsafeFromLiftedSpec   , emptyLiftedSpec   ) where  import           GHC.Generics            hiding (to, moduleName)+import           Data.Bifunctor          (bimap, first, second)+import           Data.Bitraversable      (bimapM) import           Data.Binary import qualified Language.Fixpoint.Types as F-import           Language.Fixpoint.Misc (sortNub)+import           Data.Data (Data) import           Data.Hashable import qualified Data.HashSet            as S import           Data.HashSet            (HashSet)+import qualified Data.HashMap.Lazy       as Lazy.M import qualified Data.HashMap.Strict     as M import           Data.HashMap.Strict     (HashMap)+import           Language.Haskell.Liquid.GHC.Misc (dropModuleNames)+import           Language.Haskell.Liquid.Types.DataDecl+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.Variance import           Language.Haskell.Liquid.Types.Bounds-import           Liquid.GHC.API hiding (text, (<+>))+import           Language.Haskell.Liquid.UX.Config+import           Liquid.GHC.API hiding (Binary, text, (<+>), panic) import           Language.Haskell.Liquid.GHC.Types import           Text.PrettyPrint.HughesPJ              (text, (<+>)) import           Text.PrettyPrint.HughesPJ as HughesPJ (($$))@@ -170,9 +185,6 @@   , gsFiTcs     :: ![TyCon]               -- ^ Family instance TyCons   , gsFiDcs     :: ![(F.Symbol, DataCon)] -- ^ Family instance DataCons   , gsPrimTcs   :: ![TyCon]               -- ^ Primitive GHC TyCons (from TysPrim.primTyCons)-  , gsQualImps  :: !QImports              -- ^ Map of qualified imports-  , gsAllImps   :: !(HashSet F.Symbol)    -- ^ Set of _all_ imported modules-  , gsTyThings  :: ![TyThing]             -- ^ All the @TyThing@s known to GHC   }  -- | 'QImports' is a map of qualified imports.@@ -194,7 +206,6 @@   , gsVars   :: !GhcSpecVars   , gsTerm   :: !GhcSpecTerm   , gsRefl   :: !GhcSpecRefl-  , gsLaws   :: !GhcSpecLaws   , gsImps   :: ![(F.Symbol, F.Sort)]  -- ^ Imported Environment   , gsConfig :: !Config   }@@ -274,21 +285,21 @@   , gsInvariants :: ![(Maybe Var, LocSpecType)]   -- ^ Data type invariants from measure definitions, e.g forall a. {v: [a] | len(v) >= 0}   , gsIaliases   :: ![(LocSpecType, LocSpecType)] -- ^ Data type invariant aliases   , gsMeasures   :: ![Measure SpecType DataCon]   -- ^ Measure definitions+  , gsOpaqueRefls:: ![Var]                        -- ^ List of opaque reflected measures   , gsUnsorted   :: ![UnSortedExpr]   }   deriving Show  data GhcSpecNames = SpNames-  { gsFreeSyms   :: ![(F.Symbol, Var)]            -- ^ List of `Symbol` free in spec and corresponding GHC var, eg. (Cons, Cons#7uz) from tests/pos/ex1.hs-  , gsDconsP     :: ![F.Located DataCon]          -- ^ Predicated Data-Constructors, e.g. see tests/pos/Map.hs+  { gsDconsP     :: ![F.Located DataCon]          -- ^ Predicated Data-Constructors, e.g. see tests/pos/Map.hs   , gsTconsP     :: ![TyConP]                     -- ^ Predicated Type-Constructors, e.g. see tests/pos/Map.hs-  , gsTcEmbeds   :: !(F.TCEmb TyCon)              -- ^ Embedding GHC Tycons into fixpoint sorts e.g. "embed Set as Set_set" from include/Data/Set.spec+  , gsTcEmbeds   :: !(F.TCEmb TyCon)              -- ^ Embedding GHC Tycons into fixpoint sorts e.g. "embed Set as Set_set"   , gsADTs       :: ![F.DataDecl]                 -- ^ ADTs extracted from Haskell 'data' definitions   , gsTyconEnv   :: !TyConMap+  , gsDataConIds :: [Var]   }   deriving Show -deriving instance Show TyConP deriving instance Show TyConMap  data GhcSpecTerm = SpTerm@@ -312,13 +323,12 @@ instance Monoid GhcSpecTerm where   mempty = SpTerm mempty mempty mempty mempty mempty data GhcSpecRefl = SpRefl-  { gsAutoInst     :: !(M.HashMap Var (Maybe Int))      -- ^ Binders to USE PLE+  { gsAutoInst     :: !(S.HashSet Var)                  -- ^ Binders to USE PLE   , gsHAxioms      :: ![(Var, LocSpecType, F.Equation)] -- ^ Lifted definitions   , gsImpAxioms    :: ![F.Equation]                     -- ^ Axioms from imported reflected functions   , gsMyAxioms     :: ![F.Equation]                     -- ^ Axioms from my reflected functions   , gsReflects     :: ![Var]                            -- ^ Binders for reflected functions   , gsLogicMap     :: !LogicMap-  , gsWiredReft    :: ![Var]   , gsRewrites     :: S.HashSet (F.Located Var)   , gsRewritesWith :: M.HashMap Var [Var]   }@@ -332,7 +342,6 @@     , gsMyAxioms = gsMyAxioms x <> gsMyAxioms y     , gsReflects = gsReflects x <> gsReflects y     , gsLogicMap = gsLogicMap x <> gsLogicMap y-    , gsWiredReft = gsWiredReft x <> gsWiredReft y     , gsRewrites = gsRewrites x <> gsRewrites y     , gsRewritesWith = gsRewritesWith x <> gsRewritesWith y     }@@ -340,25 +349,11 @@ instance Monoid GhcSpecRefl where   mempty = SpRefl mempty mempty mempty                   mempty mempty mempty-                  mempty mempty mempty-data GhcSpecLaws = SpLaws-  { gsLawDefs :: ![(Class, [(Var, LocSpecType)])]-  , gsLawInst :: ![LawInstance]-  }-  deriving Show--data LawInstance = LawInstance-  { lilName   :: Class-  , liSupers  :: [LocSpecType]-  , lilTyArgs :: [LocSpecType]-  , lilEqus   :: [(VarOrLocSymbol, (VarOrLocSymbol, Maybe LocSpecType))]-  , lilPos    :: SrcSpan-  }-  deriving Show+                  mempty mempty  type VarOrLocSymbol = Either Var LocSymbol-type BareMeasure   = Measure LocBareType F.LocSymbol-type BareDef       = Def     LocBareType F.LocSymbol+type BareMeasure   = Measure LocBareType (F.Located LHName)+type BareDef       = Def     LocBareType (F.Located LHName) type SpecMeasure   = Measure LocSpecType DataCon  -- $bareSpec@@ -374,109 +369,250 @@ -- -- Also, a 'BareSpec' has not yet been subject to name resolution, so it may refer -- to undefined or out-of-scope entities.-newtype BareSpec =-  MkBareSpec { getBareSpec :: Spec LocBareType F.LocSymbol }-  deriving (Generic, Show, Binary)--instance Semigroup BareSpec where-  x <> y = MkBareSpec { getBareSpec = getBareSpec x <> getBareSpec y }--instance Monoid BareSpec where-  mempty = MkBareSpec { getBareSpec = mempty }----- instance Semigroup (Spec ty bndr) where+type BareSpec = Spec F.Symbol BareType+type BareSpecLHName = Spec LHName BareTypeLHName+type BareSpecParsed = Spec LocSymbol BareTypeParsed --- | A generic 'Spec' type, polymorphic over the inner choice of type and binder.-data Spec ty bndr  = Spec-  { measures   :: ![Measure ty bndr]                                  -- ^ User-defined properties for ADTs-  , impSigs    :: ![(F.Symbol, F.Sort)]                               -- ^ Imported variables types-  , expSigs    :: ![(F.Symbol, F.Sort)]                               -- ^ Exported variables types-  , asmSigs    :: ![(F.LocSymbol, ty)]                                -- ^ Assumed (unchecked) types; including reflected signatures-  , asmReflectSigs :: ![(F.LocSymbol, F.LocSymbol)]                   -- ^ Assume reflects : left is the actual function and right the pretended one-  , sigs       :: ![(F.LocSymbol, ty)]                                -- ^ Imported functions and types-  , localSigs  :: ![(F.LocSymbol, ty)]                                -- ^ Local type signatures-  , reflSigs   :: ![(F.LocSymbol, ty)]                                -- ^ Reflected type signatures-  , invariants :: ![(Maybe F.LocSymbol, ty)]                          -- ^ Data type invariants; the Maybe is the generating measure-  , ialiases   :: ![(ty, ty)]                                         -- ^ Data type invariants to be checked-  , imports    :: ![F.Symbol]                                         -- ^ Loaded spec module names-  , dataDecls  :: ![DataDecl]                                         -- ^ Predicated data definitions-  , newtyDecls :: ![DataDecl]                                         -- ^ Predicated new type definitions-  , includes   :: ![FilePath]                                         -- ^ Included qualifier files-  , aliases    :: ![F.Located (RTAlias F.Symbol BareType)]            -- ^ RefType aliases-  , ealiases   :: ![F.Located (RTAlias F.Symbol F.Expr)]              -- ^ Expression aliases-  , embeds     :: !(F.TCEmb F.LocSymbol)                              -- ^ GHC-Tycon-to-fixpoint Tycon map-  , qualifiers :: ![F.Qualifier]                                      -- ^ Qualifiers in source/spec files-  , lvars      :: !(S.HashSet F.LocSymbol)                            -- ^ Variables that should be checked in the environment they are used-  , lazy       :: !(S.HashSet F.LocSymbol)                            -- ^ Ignore Termination Check in these Functions-  , rewrites    :: !(S.HashSet F.LocSymbol)                           -- ^ Theorems turned into rewrite rules-  , rewriteWith :: !(M.HashMap F.LocSymbol [F.LocSymbol])             -- ^ Definitions using rewrite rules-  , fails      :: !(S.HashSet F.LocSymbol)                            -- ^ These Functions should be unsafe-  , reflects   :: !(S.HashSet F.LocSymbol)                            -- ^ Binders to reflect-  , autois     :: !(M.HashMap F.LocSymbol (Maybe Int))                -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel-  , hmeas      :: !(S.HashSet F.LocSymbol)                            -- ^ Binders to turn into measures using haskell definitions-  , hbounds    :: !(S.HashSet F.LocSymbol)                            -- ^ Binders to turn into bounds using haskell definitions-  , inlines    :: !(S.HashSet F.LocSymbol)                            -- ^ Binders to turn into logic inline using haskell definitions-  , ignores    :: !(S.HashSet F.LocSymbol)                            -- ^ Binders to ignore during checking; that is DON't check the corebind.-  , autosize   :: !(S.HashSet F.LocSymbol)                            -- ^ Type Constructors that get automatically sizing info+-- | A generic 'Spec' type, polymorphic over the inner choice of type and binders.+--+-- @lname@ corresponds to the names used for entities only known to LH like+-- non-interpreted functions and type aliases.+data Spec lname ty = Spec+  { measures   :: ![MeasureV lname (F.Located ty) (F.Located LHName)] -- ^ User-defined properties for ADTs+  , expSigs    :: ![(lname, F.Sort)]                                  -- ^ Exported logic symbols originated by reflecting functions+  , asmSigs    :: ![(F.Located LHName, F.Located ty)]                 -- ^ Assumed (unchecked) types; including reflected signatures+  , asmReflectSigs :: ![(F.Located LHName, F.Located LHName)]         -- ^ Assume reflects : left is the actual function and right the pretended one+  , sigs       :: ![(F.Located LHName, F.Located (BareTypeV lname))]  -- ^ Asserted spec signatures+  , invariants :: ![(Maybe F.LocSymbol, F.Located ty)]                -- ^ Data type invariants; the Maybe is the generating measure+  , ialiases   :: ![(F.Located ty, F.Located ty)]                     -- ^ Data type invariants to be checked+  , dataDecls  :: ![DataDeclP lname ty]                               -- ^ Predicated data definitions+  , newtyDecls :: ![DataDeclP lname ty]                               -- ^ Predicated new type definitions+  , aliases    :: ![F.Located (RTAlias F.Symbol (BareTypeV lname))]   -- ^ RefType aliases+  , ealiases   :: ![F.Located (RTAlias F.Symbol (F.ExprV lname))]     -- ^ Expression aliases+  , embeds     :: !(F.TCEmb (F.Located LHName))                       -- ^ GHC-Tycon-to-fixpoint Tycon map+  , qualifiers :: ![F.QualifierV lname]                               -- ^ Qualifiers in source files+  , lvars      :: !(S.HashSet (F.Located LHName))                     -- ^ Variables that should be checked in the environment they are used+  , lazy       :: !(S.HashSet (F.Located LHName))                     -- ^ Ignore Termination Check in these Functions+  , rewrites    :: !(S.HashSet (F.Located LHName))                    -- ^ Theorems turned into rewrite rules+  , rewriteWith :: !(M.HashMap (F.Located LHName) [F.Located LHName]) -- ^ Definitions using rewrite rules+  , fails      :: !(S.HashSet (F.Located LHName))                     -- ^ These Functions should be unsafe+  , reflects   :: !(S.HashSet (F.Located LHName))                     -- ^ Binders to reflect+  , privateReflects :: !(S.HashSet F.LocSymbol)                       -- ^ Private binders to reflect+  , opaqueReflects :: !(S.HashSet (F.Located LHName))                 -- ^ Binders to opaque-reflect+  , autois     :: !(S.HashSet (F.Located LHName))                     -- ^ Automatically instantiate axioms in these Functions+  , hmeas      :: !(S.HashSet (F.Located LHName))                     -- ^ Binders to turn into measures using haskell definitions+  , inlines    :: !(S.HashSet (F.Located LHName))                     -- ^ Binders to turn into logic inline using haskell definitions+  , ignores    :: !(S.HashSet (F.Located LHName))                     -- ^ Binders to ignore during checking; that is DON't check the corebind.+  , autosize   :: !(S.HashSet (F.Located LHName))                     -- ^ Type Constructors that get automatically sizing info   , pragmas    :: ![F.Located String]                                 -- ^ Command-line configurations passed in through source-  , cmeasures  :: ![Measure ty ()]                                    -- ^ Measures attached to a type-class-  , imeasures  :: ![Measure ty bndr]                                  -- ^ Mappings from (measure,type) -> measure-  , classes    :: ![RClass ty]                                        -- ^ Refined Type-Classes-  , claws      :: ![RClass ty]                                        -- ^ Refined Type-Classe Laws-  , relational :: ![(LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr)] -- ^ Relational types-  , asmRel     :: ![(LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr)] -- ^ Assumed relational types-  , termexprs  :: ![(F.LocSymbol, [F.Located F.Expr])]                -- ^ Terminating Conditions for functions-  , rinstance  :: ![RInstance ty]-  , ilaws      :: ![RILaws ty]-  , dvariance  :: ![(F.LocSymbol, [Variance])]                        -- ^ TODO ? Where do these come from ?!-  , dsize      :: ![([ty], F.LocSymbol)]                              -- ^ Size measure to enforce fancy termination-  , bounds     :: !(RRBEnv ty)-  , defs       :: !(M.HashMap F.LocSymbol F.Symbol)                   -- ^ Temporary (?) hack to deal with dictionaries in specifications-                                                                      --   see tests/pos/NatClass.hs-  , axeqs      :: ![F.Equation]                                       -- ^ Equalities used for Proof-By-Evaluation-  } deriving (Generic, Show)--instance Binary (Spec LocBareType F.LocSymbol)+  , cmeasures  :: ![MeasureV lname (F.Located ty) ()]                 -- ^ Measures attached to a type-class+  , imeasures  :: ![MeasureV lname (F.Located ty) (F.Located LHName)] -- ^ Mappings from (measure,type) -> measure+  , omeasures  :: ![MeasureV lname (F.Located ty) (F.Located LHName)] -- ^ Opaque reflection measures.+  -- Separate field bc measures are checked for duplicates, and we want to allow for opaque-reflected measures to be duplicated.+  -- See Note [Duplicate measures and opaque reflection] in "Language.Haskell.Liquid.Measure".+  , classes    :: ![RClass (F.Located ty)]                            -- ^ Refined Type-Classes+  , relational :: ![(F.Located LHName, F.Located LHName, F.Located (BareTypeV lname), F.Located (BareTypeV lname), RelExprV lname, RelExprV lname)] -- ^ Relational types+  , asmRel :: ![(F.Located LHName, F.Located LHName, F.Located (BareTypeV lname), F.Located (BareTypeV lname), RelExprV lname, RelExprV lname)] -- ^ Assumed relational types+  , termexprs  :: ![(F.Located LHName, [F.Located (F.ExprV lname)])]  -- ^ Terminating Conditions for functions+  , rinstance  :: ![RInstance (F.Located ty)]+  , dvariance  :: ![(F.Located LHName, [Variance])]                   -- ^ TODO ? Where do these come from ?!+  , dsize      :: ![([F.Located ty], lname)]                          -- ^ Size measure to enforce fancy termination+  , bounds     :: !(RRBEnvV lname (F.Located ty))+  , axeqs      :: ![F.EquationV lname]                                -- ^ Equalities used for Proof-By-Evaluation+  , defines    :: ![(F.Located LHName, LMapV lname)]                  -- ^ Logic aliases+  , usedDataCons :: S.HashSet LHName                                  -- ^ Data constructors used in specs+  } deriving (Data, Generic) -instance (Show ty, Show bndr, F.PPrint ty, F.PPrint bndr) => F.PPrint (Spec ty bndr) where+instance (Show lname, F.PPrint lname, Show ty, F.PPrint ty, F.PPrint (RTypeV lname BTyCon BTyVar (RReftV lname))) => F.PPrint (Spec lname ty) where     pprintTidy k sp = text "dataDecls = " <+> pprintTidy k  (dataDecls sp)                          HughesPJ.$$                       text "classes = " <+> pprintTidy k (classes sp)                          HughesPJ.$$                       text "sigs = " <+> pprintTidy k (sigs sp) +deriving instance Show BareSpec++-- | A function to resolve names in the ty parameter of Spec+--+--+emapSpecM+  :: Monad m+  =>+     -- | The bscope setting, which affects which names+     -- are considered to be in scope in refinment types.+     Bool+     -- | For names that have a local environment return the names in scope.+  -> (LHName -> [F.Symbol])+     -- | The first parameter of the function argument are the variables in scope.+  -> ([F.Symbol] -> lname0 -> m lname1)+  -> ([F.Symbol] -> ty0 -> m ty1)+  -> Spec lname0 ty0+  -> m (Spec lname1 ty1)+emapSpecM bscp lenv vf f sp = do+    measures <- mapM (emapMeasureM vf (traverse . f)) (measures sp)+    expSigs <- sequence [ (,s) <$> vf [] n | (n, s) <- expSigs sp ]+    asmSigs <- mapM (\p -> traverse (traverse (f $ lenv $ val $ fst p)) p) (asmSigs sp)+    sigs <-+      mapM+        (\p -> traverse (traverse (emapBareTypeVM bscp vf (lenv $ val $ fst p))) p)+        (sigs sp)+    invariants <- mapM (traverse (traverse fnull)) (invariants sp)+    ialiases <- mapM (bimapM (traverse fnull) (traverse fnull)) (ialiases sp)+    dataDecls <- mapM (emapDataDeclM bscp vf f) (dataDecls sp)+    newtyDecls <- mapM (emapDataDeclM bscp vf f) (newtyDecls sp)+    aliases <- mapM (traverse (emapRTAlias (emapBareTypeVM bscp vf))) (aliases sp)+    ealiases <- mapM (traverse (emapRTAlias (\e -> emapExprVM (vf . (++ e))))) $ ealiases sp+    qualifiers <- mapM (emapQualifierM vf) $ qualifiers sp+    cmeasures <- mapM (emapMeasureM vf (traverse . f)) (cmeasures sp)+    imeasures <- mapM (emapMeasureM vf (traverse . f)) (imeasures sp)+    omeasures <- mapM (emapMeasureM vf (traverse . f)) (omeasures sp)+    classes <- mapM (traverse (traverse fnull)) (classes sp)+    relational <- mapM (emapRelationalM vf) (relational sp)+    asmRel <- mapM (emapRelationalM vf) (asmRel sp)+    let mbinds = Lazy.M.fromList [ (val lx, ty_binds $ toRTypeRep $ val lty) | (lx, lty) <- sigs ]+    termexprs <-+      mapM+        (\p -> do+          let bs0 = lenv $ val $ fst p+              mbs = M.findWithDefault [] (val $ fst p) mbinds+          traverse+            (mapM (traverse (emapExprVM (vf . (++ (mbs ++ bs0))))))+            p+        )+        (termexprs sp)+    rinstance <- mapM (traverse (traverse fnull)) (rinstance sp)+    dsize <- mapM (bimapM (mapM (traverse fnull)) (vf [])) (dsize sp)+    bounds <- M.fromList <$>+      mapM+        (traverse (emapBoundM (traverse . f) (\e -> emapExprVM (vf . (++ e)))))+        (M.toList $ bounds sp)+    axeqs <- mapM (emapEquationM vf) $ axeqs sp+    defines <- mapM (traverse (emapLMapM vf)) $ defines sp+    return sp+      { measures+      , expSigs+      , asmSigs+      , sigs+      , invariants+      , ialiases+      , dataDecls+      , newtyDecls+      , aliases+      , ealiases+      , qualifiers+      , cmeasures+      , imeasures+      , omeasures+      , classes+      , relational+      , asmRel+      , termexprs+      , rinstance+      , dsize+      , bounds+      , axeqs+      , defines+      }+  where+    fnull = f []+    emapRelationalM vf1 (n0, n1, t0, t1, e0, e1) = do+      t0' <- traverse (emapBareTypeVM bscp vf1 []) t0+      t1' <- traverse (emapBareTypeVM bscp vf1 []) t1+      let bs = [F.symbol "r1", F.symbol "r2"] ++ tArgs (val t0') ++ tArgs (val t1')+      e0' <- emapRelExprV (vf1 . (++ bs)) e0+      e1' <- emapRelExprV (vf1 . (++ bs)) e1+      return (n0, n1, t0', t1', e0', e1')++    tArgs t =+      let rt = toRTypeRep t+       in ty_binds rt ++ concatMap tArgs (ty_args rt)++emapRTAlias :: Monad m => ([F.Symbol] -> r0 -> m r1) -> RTAlias F.Symbol r0 -> m (RTAlias F.Symbol r1)+emapRTAlias f rt = do+    rtBody <- f (rtTArgs rt ++ rtVArgs rt) (rtBody rt)+    return rt{rtBody}++emapQualifierM :: Monad m => ([F.Symbol] -> v0 -> m v1) -> F.QualifierV v0 -> m (F.QualifierV v1)+emapQualifierM f q = do+    qBody <- emapExprVM (f . (++ map F.qpSym (F.qParams q))) (F.qBody q)+    return q{F.qBody}++emapEquationM :: Monad m => ([F.Symbol] -> v0 -> m v1) -> F.EquationV v0 -> m (F.EquationV v1)+emapEquationM f e = do+    eqBody <- emapExprVM (f . (++ map fst (F.eqArgs e))) (F.eqBody e)+    return e{F.eqBody}++mapSpecTy :: (ty0 -> ty1) -> Spec lname ty0 -> Spec lname ty1+mapSpecTy f Spec {..} =+    Spec+      { measures = map (mapMeasureTy (fmap f)) measures+      , asmSigs = map (fmap (fmap f)) asmSigs+      , invariants = map (fmap (fmap f)) invariants+      , ialiases = map (bimap (fmap f) (fmap f)) ialiases+      , dataDecls = map (fmap f) dataDecls+      , newtyDecls = map (fmap f) newtyDecls+      , cmeasures = map (mapMeasureTy (fmap f)) cmeasures+      , imeasures = map (mapMeasureTy (fmap f)) imeasures+      , omeasures = map (mapMeasureTy (fmap f)) omeasures+      , classes = map (fmap (fmap f)) classes+      , rinstance = map (fmap (fmap f)) rinstance+      , dsize = map (first (map (fmap f))) dsize+      , bounds = M.map (first (fmap f)) bounds+      , ..+      }++mapSpecLName :: (lname0 -> lname1) -> Spec lname0 ty -> Spec lname1 ty+mapSpecLName f Spec {..} =+    Spec+      { measures = map (mapMeasureV f) measures+      , expSigs = map (first f) expSigs+      , sigs = map (fmap (fmap (mapRTypeV f . mapReft (mapUReftV f (fmap f))))) sigs+      , dataDecls = map (mapDataDeclV f) dataDecls+      , newtyDecls = map (mapDataDeclV f) newtyDecls+      , aliases = map (fmap (fmap (mapRTypeV f . fmap (mapUReftV f (fmap f))))) aliases+      , ealiases = map (fmap (fmap (fmap f))) ealiases+      , qualifiers = map (fmap f) qualifiers+      , cmeasures = map (mapMeasureV f) cmeasures+      , imeasures = map (mapMeasureV f) imeasures+      , omeasures = map (mapMeasureV f) omeasures+      , relational = map (mapRelationalV f) relational+      , asmRel = map (mapRelationalV f) asmRel+      , termexprs = map (fmap (map (fmap (fmap f)))) termexprs+      , bounds = M.map (fmap (fmap f)) bounds+      , axeqs = map (fmap f) axeqs+      , dsize = map (fmap f) dsize+      , defines = map (second $ fmap f) defines+      , ..+      }+  where+    mapRelationalV f1 (n0, n1, a, b, e0, e1) =+      (n0, n1, fmap (mapRTypeV f1 . mapReft (mapUReftV f1 (fmap f1))) a, fmap (mapRTypeV f1 . mapReft (mapUReftV f1 (fmap f1))) b, fmap f1 e0, fmap f1 e1)+ -- /NOTA BENE/: These instances below are considered legacy, because merging two 'Spec's together doesn't -- really make sense, and we provide this only for legacy purposes.-instance Semigroup (Spec ty bndr) where+instance Semigroup (Spec lname ty) where   s1 <> s2     = Spec { measures   =           measures   s1 ++ measures   s2-           , impSigs    =           impSigs    s1 ++ impSigs    s2            , expSigs    =           expSigs    s1 ++ expSigs    s2            , asmSigs    =           asmSigs    s1 ++ asmSigs    s2            , asmReflectSigs    =    asmReflectSigs s1 ++ asmReflectSigs s2            , sigs       =           sigs       s1 ++ sigs       s2-           , localSigs  =           localSigs  s1 ++ localSigs  s2-           , reflSigs   =           reflSigs   s1 ++ reflSigs   s2            , invariants =           invariants s1 ++ invariants s2            , ialiases   =           ialiases   s1 ++ ialiases   s2-           , imports    = sortNub $ imports    s1 ++ imports    s2            , dataDecls  =           dataDecls  s1 ++ dataDecls  s2            , newtyDecls =           newtyDecls s1 ++ newtyDecls s2-           , includes   = sortNub $ includes   s1 ++ includes   s2            , aliases    =           aliases    s1 ++ aliases    s2            , ealiases   =           ealiases   s1 ++ ealiases   s2            , qualifiers =           qualifiers s1 ++ qualifiers s2            , pragmas    =           pragmas    s1 ++ pragmas    s2            , cmeasures  =           cmeasures  s1 ++ cmeasures  s2            , imeasures  =           imeasures  s1 ++ imeasures  s2+           , omeasures  =           omeasures  s1 ++ omeasures  s2            , classes    =           classes    s1 ++ classes    s2-           , claws      =           claws      s1 ++ claws      s2            , relational =           relational s1 ++ relational s2            , asmRel     =           asmRel     s1 ++ asmRel     s2            , termexprs  =           termexprs  s1 ++ termexprs  s2            , rinstance  =           rinstance  s1 ++ rinstance  s2-           , ilaws      =               ilaws  s1 ++ ilaws      s2            , dvariance  =           dvariance  s1 ++ dvariance  s2            , dsize      =               dsize  s1 ++ dsize      s2            , axeqs      =           axeqs s1      ++ axeqs s2@@ -487,33 +623,30 @@            , rewriteWith = M.union  (rewriteWith s1)  (rewriteWith s2)            , fails      = S.union   (fails    s1)  (fails    s2)            , reflects   = S.union   (reflects s1)  (reflects s2)+           , privateReflects = S.union (privateReflects s1) (privateReflects s2)+           , opaqueReflects   = S.union   (opaqueReflects s1)  (opaqueReflects s2)            , hmeas      = S.union   (hmeas    s1)  (hmeas    s2)-           , hbounds    = S.union   (hbounds  s1)  (hbounds  s2)            , inlines    = S.union   (inlines  s1)  (inlines  s2)            , ignores    = S.union   (ignores  s1)  (ignores  s2)            , autosize   = S.union   (autosize s1)  (autosize s2)            , bounds     = M.union   (bounds   s1)  (bounds   s2)-           , defs       = M.union   (defs     s1)  (defs     s2)-           , autois     = M.union   (autois s1)      (autois s2)+           , autois     = S.union   (autois s1)      (autois s2)+           , defines    =            defines  s1 ++ defines  s2+           , usedDataCons = S.union (usedDataCons s1) (usedDataCons s2)            } -instance Monoid (Spec ty bndr) where+instance Monoid (Spec lname ty) where   mappend = (<>)   mempty     = Spec { measures   = []-           , impSigs    = []            , expSigs    = []            , asmSigs    = []            , asmReflectSigs = []            , sigs       = []-           , localSigs  = []-           , reflSigs   = []            , invariants = []            , ialiases   = []-           , imports    = []            , dataDecls  = []            , newtyDecls = []-           , includes   = []            , aliases    = []            , ealiases   = []            , embeds     = mempty@@ -523,28 +656,29 @@            , rewrites   = S.empty            , rewriteWith = M.empty            , fails      = S.empty-           , autois     = M.empty+           , autois     = S.empty            , hmeas      = S.empty            , reflects   = S.empty-           , hbounds    = S.empty+           , privateReflects = S.empty+           , opaqueReflects = S.empty            , inlines    = S.empty            , ignores    = S.empty            , autosize   = S.empty            , pragmas    = []            , cmeasures  = []            , imeasures  = []+           , omeasures  = []            , classes    = []-           , claws      = []            , relational = []            , asmRel     = []            , termexprs  = []            , rinstance  = []-           , ilaws      = []            , dvariance  = []            , dsize      = []            , axeqs      = []            , bounds     = M.empty-           , defs       = M.empty+           , defines    = []+           , usedDataCons = mempty            }  -- $liftedSpec@@ -557,13 +691,10 @@ -- -- What we /do not/ have compared to a 'BareSpec': ----- * The 'localSigs', as it's not necessary/visible to clients;--- * The 'includes', as they are probably not reachable for clients anyway; -- * The 'reflSigs', they are now just \"normal\" signatures; -- * The 'lazy', we don't do termination checking in lifted specs; -- * The 'reflects', the reflection has already happened at this point; -- * The 'hmeas', we have /already/ turned these into measures at this point;--- * The 'hbounds', ditto as 'hmeas'; -- * The 'inlines', ditto as 'hmeas'; -- * The 'ignores', ditto as 'hmeas'; -- * The 'pragmas', we can't make any use of this information for lifted specs;@@ -572,78 +703,100 @@ -- Apart from less fields, a 'LiftedSpec' /replaces all instances of lists with sets/, to enforce -- duplicate detection and removal on what we serialise on disk. data LiftedSpec = LiftedSpec-  { liftedMeasures   :: HashSet (Measure LocBareType F.LocSymbol)-    -- ^ User-defined properties for ADTs-  , liftedImpSigs    :: HashSet (F.Symbol, F.Sort)-    -- ^ Imported variables types-  , liftedExpSigs    :: HashSet (F.Symbol, F.Sort)-    -- ^ Exported variables types-  , liftedAsmSigs    :: HashSet (F.LocSymbol, LocBareType)+  { -- | Measures (a.k.a.  user-defined properties for ADTs)+    --+    -- The key of the HashMap is the unqualified name of the measure.+    -- Constructing such a map discards preceding measures with the same name+    -- as later measures, which makes possible to predict which of a few+    -- conflicting measures will be exported.+    --+    -- Tested in MeasureOverlapC.hs+    liftedMeasures   :: HashMap F.Symbol (MeasureV LHName LocBareTypeLHName (F.Located LHName))+  , liftedExpSigs    :: HashSet (LHName, F.Sort)+    -- ^ Exported logic symbols originated from reflecting functions+  , liftedPrivateReflects :: HashSet F.LocSymbol+    -- ^ Private functions that have been reflected+  , liftedAsmSigs    :: HashSet (F.Located LHName, LocBareTypeLHName)     -- ^ Assumed (unchecked) types; including reflected signatures-  , liftedAsmReflectSigs    :: HashSet (F.LocSymbol, F.LocSymbol)-    -- ^ Reflected assumed signatures-  , liftedSigs       :: HashSet (F.LocSymbol, LocBareType)-    -- ^ Imported functions and types-  , liftedInvariants :: HashSet (Maybe F.LocSymbol, LocBareType)+  , liftedSigs       :: HashSet (F.Located LHName, LocBareTypeLHName)+    -- ^ Asserted spec signatures+  , liftedInvariants :: HashSet (Maybe F.LocSymbol, LocBareTypeLHName)     -- ^ Data type invariants; the Maybe is the generating measure-  , liftedIaliases   :: HashSet (LocBareType, LocBareType)+  , liftedIaliases   :: HashSet (LocBareTypeLHName, LocBareTypeLHName)     -- ^ Data type invariants to be checked-  , liftedImports    :: HashSet F.Symbol-    -- ^ Loaded spec module names-  , liftedDataDecls  :: HashSet DataDecl+  , liftedDataDecls  :: HashSet DataDeclLHName     -- ^ Predicated data definitions-  , liftedNewtyDecls :: HashSet DataDecl+  , liftedNewtyDecls :: HashSet DataDeclLHName     -- ^ Predicated new type definitions-  , liftedAliases    :: HashSet (F.Located (RTAlias F.Symbol BareType))+  , liftedAliases    :: HashSet (F.Located (RTAlias F.Symbol BareTypeLHName))     -- ^ RefType aliases-  , liftedEaliases   :: HashSet (F.Located (RTAlias F.Symbol F.Expr))+  , liftedEaliases   :: HashSet (F.Located (RTAlias F.Symbol (F.ExprV LHName)))     -- ^ Expression aliases-  , liftedEmbeds     :: F.TCEmb F.LocSymbol+  , liftedEmbeds     :: F.TCEmb (F.Located LHName)     -- ^ GHC-Tycon-to-fixpoint Tycon map-  , liftedQualifiers :: HashSet F.Qualifier+  , liftedQualifiers :: HashSet (F.QualifierV LHName)     -- ^ Qualifiers in source/spec files-  , liftedLvars      :: HashSet F.LocSymbol+  , liftedLvars      :: HashSet (F.Located LHName)     -- ^ Variables that should be checked in the environment they are used-  , liftedAutois     :: M.HashMap F.LocSymbol (Maybe Int)-    -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel-  , liftedAutosize   :: HashSet F.LocSymbol+  , liftedAutois     :: S.HashSet (F.Located LHName)+    -- ^ Automatically instantiate axioms in these Functions+  , liftedAutosize   :: HashSet (F.Located LHName)     -- ^ Type Constructors that get automatically sizing info-  , liftedCmeasures  :: HashSet (Measure LocBareType ())-    -- ^ Measures attached to a type-class-  , liftedImeasures  :: HashSet (Measure LocBareType F.LocSymbol)++    -- | Measures attached to a type-class+    --+    -- Imitates the arrangement for 'liftedMeasures'+  , liftedCmeasures  :: HashMap F.Symbol (MeasureV LHName LocBareTypeLHName ())+  , liftedImeasures  :: HashSet (MeasureV LHName LocBareTypeLHName (F.Located LHName))     -- ^ Mappings from (measure,type) -> measure-  , liftedClasses    :: HashSet (RClass LocBareType)+  , liftedOmeasures  :: HashSet (MeasureV LHName LocBareTypeLHName (F.Located LHName))+    -- ^ Lifted opaque reflection measures+  , liftedClasses    :: HashSet (RClass LocBareTypeLHName)     -- ^ Refined Type-Classes-  , liftedClaws      :: HashSet (RClass LocBareType)-    -- ^ Refined Type-Classe Laws-  , liftedRinstance  :: HashSet (RInstance LocBareType)-  , liftedIlaws      :: HashSet (RILaws LocBareType)-  , liftedDsize      :: [([LocBareType], F.LocSymbol)]-  , liftedDvariance  :: HashSet (F.LocSymbol, [Variance])+  , liftedRinstance  :: HashSet (RInstance LocBareTypeLHName)+  , liftedDsize      :: [([LocBareTypeLHName], LHName)]+  , liftedDvariance  :: HashSet (F.Located LHName, [Variance])     -- ^ ? Where do these come from ?!-  , liftedBounds     :: RRBEnv LocBareType-  , liftedDefs       :: M.HashMap F.LocSymbol F.Symbol-    -- ^ Temporary (?) hack to deal with dictionaries in specifications-    --   see tests/pos/NatClass.hs-  , liftedAxeqs      :: HashSet F.Equation+  , liftedBounds     :: RRBEnvV LHName LocBareTypeLHName+  , liftedAxeqs      :: HashSet (F.EquationV LHName)     -- ^ Equalities used for Proof-By-Evaluation-  } deriving (Eq, Generic, Show)+  , liftedDefines    :: HashMap F.Symbol (LMapV LHName)+    -- ^ Logic aliases+  , liftedUsedDataCons :: HashSet LHName+    -- ^ Data constructors used in specs+  } deriving (Eq, Data, Generic)     deriving Hashable via Generically LiftedSpec     deriving Binary   via Generically LiftedSpec -instance Binary F.Equation +instance Show LiftedSpec where+   show = (show :: BareSpec -> String) . fromBareSpecLHName . unsafeFromLiftedSpec++fromBareSpecLHName :: BareSpecLHName -> BareSpec+fromBareSpecLHName sp =+    mapSpecTy+      ( mapRTypeV lhNameToResolvedSymbol .+        mapReft (mapUReftV lhNameToResolvedSymbol (fmap lhNameToResolvedSymbol))+      ) $+    mapSpecLName lhNameToResolvedSymbol sp++fromBareSpecParsed :: BareSpecParsed -> BareSpec+fromBareSpecParsed sp =+    mapSpecTy+      ( mapRTypeV val .+        mapReft (mapUReftV val (fmap val))+      ) $+    mapSpecLName val sp+ emptyLiftedSpec :: LiftedSpec emptyLiftedSpec = LiftedSpec   { liftedMeasures = mempty-  , liftedImpSigs  = mempty   , liftedExpSigs  = mempty+  , liftedPrivateReflects = mempty   , liftedAsmSigs  = mempty-  , liftedAsmReflectSigs  = mempty   , liftedSigs     = mempty   , liftedInvariants = mempty   , liftedIaliases   = mempty-  , liftedImports    = mempty   , liftedDataDecls  = mempty   , liftedNewtyDecls = mempty   , liftedAliases    = mempty@@ -655,15 +808,15 @@   , liftedAutosize   = mempty   , liftedCmeasures  = mempty   , liftedImeasures  = mempty+  , liftedOmeasures  = mempty   , liftedClasses    = mempty-  , liftedClaws      = mempty   , liftedRinstance  = mempty-  , liftedIlaws      = mempty   , liftedDvariance  = mempty   , liftedDsize      = mempty   , liftedBounds     = mempty-  , liftedDefs       = mempty   , liftedAxeqs      = mempty+  , liftedDefines    = mempty+  , liftedUsedDataCons = mempty   }  -- $trackingDeps@@ -671,7 +824,7 @@ -- | The /target/ dependencies that concur to the creation of a 'TargetSpec' and a 'LiftedSpec'. newtype TargetDependencies =   TargetDependencies { getDependencies :: HashMap StableModule LiftedSpec }-  deriving (Eq, Show, Generic)+  deriving (Data, Eq, Show, Generic)   deriving Binary via Generically TargetDependencies  -- instance S.Store TargetDependencies@@ -693,7 +846,7 @@  -- | Returns 'True' if the input 'Var' is a /PLE/ one. isPLEVar :: TargetSpec -> Var -> Bool-isPLEVar sp x = M.member x (gsAutoInst (gsRefl sp))+isPLEVar sp x = S.member x (gsAutoInst (gsRefl sp))  -- | Returns 'True' if the input 'Var' was exported in the module the input 'TargetSrc' represents. isExportedVar :: TargetSrc -> Var -> Bool@@ -726,9 +879,6 @@   , _gsFiTcs     :: ![TyCon]               -- ^ Family instance TyCons   , _gsFiDcs     :: ![(F.Symbol, DataCon)] -- ^ Family instance DataCons   , _gsPrimTcs   :: ![TyCon]               -- ^ Primitive GHC TyCons (from TysPrim.primTyCons)-  , _gsQualImps  :: !QImports              -- ^ Map of qualified imports-  , _gsAllImps   :: !(S.HashSet F.Symbol)  -- ^ Set of _all_ imported modules-  , _gsTyThings  :: ![TyThing]             -- ^ All the @TyThing@s known to GHC   }  data GhcSpec = SP@@ -739,10 +889,9 @@   , _gsVars   :: !GhcSpecVars   , _gsTerm   :: !GhcSpecTerm   , _gsRefl   :: !GhcSpecRefl-  , _gsLaws   :: !GhcSpecLaws   , _gsImps   :: ![(F.Symbol, F.Sort)]  -- ^ Imported Environment   , _gsConfig :: !Config-  , _gsLSpec  :: !(Spec LocBareType F.LocSymbol) -- ^ Lifted specification for the target module+  , _gsLSpec  :: !(Spec F.Symbol BareType) -- ^ Lifted specification for the target module   }  instance HasConfig GhcSpec where@@ -764,9 +913,6 @@   , gsFiTcs     = _gsFiTcs a   , gsFiDcs     = _gsFiDcs a   , gsPrimTcs   = _gsPrimTcs a-  , gsQualImps  = _gsQualImps a-  , gsAllImps   = _gsAllImps a-  , gsTyThings  = _gsTyThings a   }  fromTargetSrc :: TargetSrc -> GhcSrc@@ -784,16 +930,10 @@   , _gsFiTcs     = gsFiTcs a   , _gsFiDcs     = gsFiDcs a   , _gsPrimTcs   = gsPrimTcs a-  , _gsQualImps  = gsQualImps a-  , _gsAllImps   = gsAllImps a-  , _gsTyThings  = gsTyThings a   } -toTargetSpec :: GhcSpec -> (TargetSpec, LiftedSpec)-toTargetSpec ghcSpec =-  (targetSpec, (toLiftedSpec . _gsLSpec) ghcSpec)-  where-    targetSpec = TargetSpec+toTargetSpec ::  GhcSpec -> TargetSpec+toTargetSpec ghcSpec = TargetSpec       { gsSig    = _gsSig ghcSpec       , gsQual   = _gsQual ghcSpec       , gsData   = _gsData ghcSpec@@ -801,28 +941,24 @@       , gsVars   = _gsVars ghcSpec       , gsTerm   = _gsTerm ghcSpec       , gsRefl   = _gsRefl ghcSpec-      , gsLaws   = _gsLaws ghcSpec       , gsImps   = _gsImps ghcSpec       , gsConfig = _gsConfig ghcSpec       } -toBareSpec :: Spec LocBareType F.LocSymbol -> BareSpec-toBareSpec = MkBareSpec--fromBareSpec :: BareSpec -> Spec LocBareType F.LocSymbol-fromBareSpec = getBareSpec--toLiftedSpec :: Spec LocBareType F.LocSymbol -> LiftedSpec+toLiftedSpec :: BareSpecLHName -> LiftedSpec toLiftedSpec a = LiftedSpec-  { liftedMeasures   = S.fromList . measures $ a-  , liftedImpSigs    = S.fromList . impSigs  $ a+  { liftedMeasures   =+      M.fromList+        [ (dropModuleNames $ lhNameToResolvedSymbol n, m)+        | m <- measures a+        , let n = val $ msName m+        ]   , liftedExpSigs    = S.fromList . expSigs  $ a+  , liftedPrivateReflects = privateReflects a   , liftedAsmSigs    = S.fromList . asmSigs  $ a-  , liftedAsmReflectSigs = S.fromList . asmReflectSigs  $ a   , liftedSigs       = S.fromList . sigs     $ a   , liftedInvariants = S.fromList . invariants $ a   , liftedIaliases   = S.fromList . ialiases $ a-  , liftedImports    = S.fromList . imports $ a   , liftedDataDecls  = S.fromList . dataDecls $ a   , liftedNewtyDecls = S.fromList . newtyDecls $ a   , liftedAliases    = S.fromList . aliases $ a@@ -832,39 +968,39 @@   , liftedLvars      = lvars a   , liftedAutois     = autois a   , liftedAutosize   = autosize a-  , liftedCmeasures  = S.fromList . cmeasures $ a+  , liftedCmeasures  =+      M.fromList+        [ (dropModuleNames $ lhNameToResolvedSymbol n, m)+        | m <- cmeasures a+        , let n = val $ msName m+        ]   , liftedImeasures  = S.fromList . imeasures $ a+  , liftedOmeasures  = S.fromList . omeasures $ a   , liftedClasses    = S.fromList . classes $ a-  , liftedClaws      = S.fromList . claws $ a   , liftedRinstance  = S.fromList . rinstance $ a-  , liftedIlaws      = S.fromList . ilaws $ a   , liftedDvariance  = S.fromList . dvariance $ a   , liftedDsize      = dsize a   , liftedBounds     = bounds a-  , liftedDefs       = defs a   , liftedAxeqs      = S.fromList . axeqs $ a+  , liftedDefines    = M.fromList . map (first (lhNameToResolvedSymbol . F.val)) . defines $ a+  , liftedUsedDataCons = usedDataCons a   }  -- This is a temporary internal function that we use to convert the input dependencies into a format -- suitable for 'makeGhcSpec'.-unsafeFromLiftedSpec :: LiftedSpec -> Spec LocBareType F.LocSymbol+unsafeFromLiftedSpec :: LiftedSpec -> BareSpecLHName unsafeFromLiftedSpec a = Spec-  { measures   = S.toList . liftedMeasures $ a-  , impSigs    = S.toList . liftedImpSigs $ a+  { measures   = M.elems $ liftedMeasures a   , expSigs    = S.toList . liftedExpSigs $ a   , asmSigs    = S.toList . liftedAsmSigs $ a-  , asmReflectSigs = S.toList . liftedAsmReflectSigs $ a+  , asmReflectSigs = mempty   , sigs       = S.toList . liftedSigs $ a-  , localSigs  = mempty-  , reflSigs   = mempty   , relational = mempty   , asmRel     = mempty   , invariants = S.toList . liftedInvariants $ a   , ialiases   = S.toList . liftedIaliases $ a-  , imports    = S.toList . liftedImports $ a   , dataDecls  = S.toList . liftedDataDecls $ a   , newtyDecls = S.toList . liftedNewtyDecls $ a-  , includes   = mempty   , aliases    = S.toList . liftedAliases $ a   , ealiases   = S.toList . liftedEaliases $ a   , embeds     = liftedEmbeds a@@ -875,23 +1011,24 @@   , rewrites   = mempty   , rewriteWith = mempty   , reflects   = mempty+  , privateReflects = liftedPrivateReflects a+  , opaqueReflects   = mempty   , autois     = liftedAutois a   , hmeas      = mempty-  , hbounds    = mempty   , inlines    = mempty   , ignores    = mempty   , autosize   = liftedAutosize a   , pragmas    = mempty-  , cmeasures  = S.toList . liftedCmeasures $ a+  , cmeasures  = M.elems $ liftedCmeasures a   , imeasures  = S.toList . liftedImeasures $ a+  , omeasures  = S.toList . liftedOmeasures $ a   , classes    = S.toList . liftedClasses $ a-  , claws      = S.toList . liftedClaws $ a   , termexprs  = mempty   , rinstance  = S.toList . liftedRinstance $ a-  , ilaws      = S.toList . liftedIlaws $ a   , dvariance  = S.toList . liftedDvariance $ a   , dsize      = liftedDsize  a   , bounds     = liftedBounds a-  , defs       = liftedDefs a   , axeqs      = S.toList . liftedAxeqs $ a+  , defines    = map (first (dummyLoc . makeLocalLHName)) . M.toList . liftedDefines $ a+  , usedDataCons = liftedUsedDataCons a   }
src/Language/Haskell/Liquid/Types/Types.hs view
@@ -1,2514 +1,1004 @@ {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DerivingVia                #-}--{-# OPTIONS_GHC -Wno-orphans #-}---- | This module should contain all the global type definitions and basic instances.--module Language.Haskell.Liquid.Types.Types (--  -- * Options-    module Language.Haskell.Liquid.UX.Config--  -- * Ghc Information-  , TargetVars   (..)-  , TyConMap     (..)--  -- * F.Located Things-  , F.Located (..)-  , F.dummyLoc--  -- * Symbols-  , F.LocSymbol-  , F.LocText--  -- * Default unknown name-  , F.dummyName-  , F.isDummy--  -- * Bare Type Constructors and Variables-  , BTyCon(..)-  , mkBTyCon-  -- , mkClassBTyCon, mkPromotedBTyCon-  , isClassBTyCon-  , BTyVar(..)--  -- * Refined Type Constructors-  , RTyCon (RTyCon, rtc_tc, rtc_info)-  , TyConInfo(..), defaultTyConInfo-  , rTyConPVs-  , rTyConPropVs-  -- , isClassRTyCon-  , isClassType, isEqType, isRVar, isBool, isEmbeddedClass--  -- * Refinement Types-  , RType (..), Ref(..), RTProp, rPropP-  , RTyVar (..)-  , RTAlias (..)-  , OkRT-  , lmapEAlias--  -- * Worlds-  , HSeg (..)-  , World (..)--  -- * Classes describing operations on `RTypes`-  , TyConable (..)-  , SubsTy (..)--  -- * Type Variables-  , RTVar (..), RTVInfo (..)-  , makeRTVar, mapTyVarValue-  , dropTyVarInfo, rTVarToBind-  , setRtvPol--  -- * Predicate Variables-  , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType-  , PVKind (..)-  , Predicate (..)--  -- * Refinements-  , UReft(..)--  -- * Relational predicates-  , RelExpr (..)--  -- * Parse-time entities describing refined data types-  , SizeFun  (..), szFun-  , DataDecl (..)-  , DataName (..), dataNameSymbol-  , DataCtor (..)-  , DataConP (..)-  , HasDataDecl (..), hasDecl-  , DataDeclKind (..)-  , TyConP   (..)--  -- * Pre-instantiated RType-  , RRType, RRProp-  , BRType, BRProp-  , BSort, BPVar-  , RTVU, PVU--  -- * Instantiated RType-  , BareType, PrType-  , SpecType, SpecProp, SpecRTVar-  , SpecRep-  , LocBareType, LocSpecType-  , RSort-  , UsedPVar, RPVar, RReft-  , REnv-  , AREnv (..)--  -- * Constructing & Destructing RTypes-  , RTypeRep(..), fromRTypeRep, toRTypeRep-  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow-  , mkUnivs, bkUniv, bkClass, bkUnivClass, bkUnivClass'-  , rFun, rFun', rCls, rRCls, rFunDebug--  -- * Manipulating `Predicates`-  , pvars, pappSym, pApp--  -- * Some tests on RTypes-  , isBase-  , isFunTy-  , isTrivial-  , hasHole--  -- * Traversing `RType`-  , efoldReft, foldReft, foldReft'-  , emapReft, mapReft, mapReftM, mapPropM-  , mapExprReft-  , mapBot, mapBind, mapRFInfo-  , foldRType---  -- * ???-  , Oblig(..)-  , ignoreOblig-  , addInvCond--  -- * Inferred Annotations-  , AnnInfo (..)-  , Annot (..)--  -- * Hole Information-  , HoleInfo(..)--  -- * Overall Output-  , Output (..)--  -- * Refinement Hole-  , hole, isHole, hasHoleTy--  -- * Converting To and From Sort-  , ofRSort, toRSort-  , rTypeValueVar-  , rTypeReft-  , stripRTypeBase-  , topRTypeBase--  -- * Class for values that can be pretty printed-  , F.PPrint (..)-  , F.pprint-  , F.showpp--  -- * Printer Configuration-  , PPEnv (..)-  , ppEnv-  , ppEnvShort--  -- * Modules and Imports-  , ModName (..), ModType (..)-  , isSrcImport, isSpecImport, isTarget-  , getModName, getModString, qualifyModName--  -- * Refinement Type Aliases-  , RTEnv (..), BareRTEnv, SpecRTEnv, BareRTAlias, SpecRTAlias-  -- , mapRT, mapRE--  -- * Diagnostics, Warnings, Errors and Error Messages-  , module Language.Haskell.Liquid.Types.Errors-  , Error-  , ErrorResult-  , Warning-  , mkWarning-  , Diagnostics-  , mkDiagnostics-  , emptyDiagnostics-  , noErrors-  , allWarnings-  , allErrors-  , printWarning--  -- * Source information (associated with constraints)-  , Cinfo (..)--  -- * Measures-  , Measure (..)-  , UnSortedExprs, UnSortedExpr-  , MeasureKind (..)-  , CMeasure (..)-  , Def (..)-  , Body (..)-  , MSpec (..)--  -- * Scoping Info-  , BScope--  -- * Type Classes-  , RClass (..)--  -- * KV Profiling-  , KVKind (..)   -- types of kvars-  , KVProf        -- profile table-  , emptyKVProf   -- empty profile-  , updKVProf     -- extend profile--  -- * Misc-  , mapRTAVars-  , insertsSEnv--  -- * CoreToLogic-  , LogicMap(..), toLogicMap, eAppWithMap, LMap(..)--  -- * Refined Instances-  , RDEnv, DEnv(..), RInstance(..), RISig(..), RILaws(..)-  , MethodType(..), getMethodType--  -- * Ureftable Instances-  , UReftable(..)--  -- * String Literals-  , liquidBegin, liquidEnd--  , Axiom(..), HAxiom--  -- , rtyVarUniqueSymbol, tyVarUniqueSymbol-  , rtyVarType, tyVarVar--  -- * Refined Function Info-  , RFInfo(..), defRFInfo, mkRFInfo, classRFInfo, classRFInfoType--  , ordSrcSpan-  )-  where--import           Liquid.GHC.API as Ghc hiding ( Expr-                                                               , isFunTy-                                                               , ($+$)-                                                               , nest-                                                               , text-                                                               , blankLine-                                                               , (<+>)-                                                               , vcat-                                                               , hsep-                                                               , comma-                                                               , colon-                                                               , parens-                                                               , empty-                                                               , char-                                                               , panic-                                                               , int-                                                               , hcat-                                                               , showPpr-                                                               , punctuate-                                                               , ($$)-                                                               , braces-                                                               , angleBrackets-                                                               , brackets-                                                               )-import           Data.String-import           GHC.Generics-import           Prelude                          hiding  (error)-import qualified Prelude--import           Control.Monad                          (liftM2, liftM3, liftM4, void)-import           Control.DeepSeq-import           Data.Bifunctor-import           Data.Typeable                          (Typeable)-import           Data.Generics                          (Data)-import qualified Data.Binary                            as B-import qualified Data.Foldable                          as F-import           Data.Hashable-import qualified Data.HashMap.Strict                    as M-import qualified Data.HashSet                           as S-import qualified Data.List                              as L-import           Data.Maybe                             (mapMaybe)-import           Data.Function                          (on)-import           Data.List                              as L (nub, null)-import           Data.Text                              (Text)-import           Text.PrettyPrint.HughesPJ              hiding (first, (<>))-import           Text.Printf-import           Language.Fixpoint.Misc--import qualified Language.Fixpoint.Types as F--import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.GHC.Logging as GHC-import           Language.Haskell.Liquid.Types.Variance-import           Language.Haskell.Liquid.Types.Errors-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.UX.Config-import           Data.Default----------------------------------------------------------------------------------- | Information about scope Binders Scope in-------------------------------------------------------------------------------{- In types with base refinement, e.g., {out:T {inner:a | ri} | ro }-If BScope = True , then the outer binder out is     in scope on ri-If BScope = False, then the outer binder out is not in scope on ri--}--type BScope = Bool--------------------------------------------------------------------------------- | Information about Type Constructors-------------------------------------------------------------------------------data TyConMap = TyConMap-  { tcmTyRTy    :: M.HashMap TyCon             RTyCon  -- ^ Map from GHC TyCon to RTyCon-  , tcmFIRTy    :: M.HashMap (TyCon, [F.Sort]) RTyCon  -- ^ Map from GHC Family-Instances to RTyCon-  , tcmFtcArity :: M.HashMap TyCon             Int     -- ^ Arity of each Family-Tycon-  }---newtype RFInfo = RFInfo {permitTC :: Maybe Bool }-  deriving (Generic, Data, Typeable, Show, Eq)--defRFInfo :: RFInfo-defRFInfo = RFInfo Nothing--classRFInfo :: Bool -> RFInfo-classRFInfo b = RFInfo $ Just b--classRFInfoType :: Bool -> RType c tv r -> RType c tv r-classRFInfoType b = fromRTypeRep .-                    (\trep@RTypeRep{..} -> trep{ty_info = map (\i -> i{permitTC = pure b}) ty_info}) .-                    toRTypeRep--mkRFInfo :: Config  -> RFInfo-mkRFInfo cfg = RFInfo $ Just (typeclass cfg)--instance Hashable RFInfo-instance NFData RFInfo-instance B.Binary RFInfo---------------------------------------------------------------------------------- | Printer ------------------------------------------------------------------------------------------------------------------------------------------------data PPEnv = PP-  { ppPs    :: Bool -- ^ print abstract-predicates-  , ppTyVar :: Bool -- ^ print the unique suffix for each tyvar-  , ppShort :: Bool -- ^ print the tycons without qualification-  , ppDebug :: Bool -- ^ gross with full info-  }-  deriving (Show)--ppEnv :: PPEnv-ppEnv = ppEnvDef-          { ppPs    = True }-          { ppDebug = True }   -- RJ: needed for resolution, because pp is used for serialization?--{- | [NOTE:ppEnv] For some mysterious reason, `ppDebug` must equal `True`-     or various tests fail e.g. tests/classes/pos/TypeEquality0{0,1}.hs-     Yikes. Find out why!- -}--ppEnvDef :: PPEnv-ppEnvDef = PP False False False False--ppEnvShort :: PPEnv -> PPEnv-ppEnvShort pp = pp { ppShort = True }----------------------------------------------------------------------- Huh?--------------------------------------------------------------------type Expr      = F.Expr-type Symbol    = F.Symbol----- [NOTE:LIFTED-VAR-SYMBOLS]: Following NOTE:REFLECT-IMPORTS, by default--- each (lifted) `Var` is mapped to its `Symbol` via the `Symbolic Var`--- instance. For _generated_ vars, we may want a custom name e.g. see---   tests/pos/NatClass.hs--- and we maintain that map in `lmVarSyms` with the `Just s` case.--- Ideally, this bandaid should be replaced so we don't have these--- hacky corner cases.--data LogicMap = LM-  { lmSymDefs  :: M.HashMap Symbol LMap        -- ^ Map from symbols to equations they define-  , lmVarSyms  :: M.HashMap Var (Maybe Symbol) -- ^ Map from (lifted) Vars to `Symbol`; see:-                                              --   NOTE:LIFTED-VAR-SYMBOLS and NOTE:REFLECT-IMPORTs-  } deriving (Show)--instance Monoid LogicMap where-  mempty  = LM M.empty M.empty-  mappend = (<>)--instance Semigroup LogicMap where-  LM x1 x2 <> LM y1 y2 = LM (M.union x1 y1) (M.union x2 y2)--data LMap = LMap-  { lmVar  :: F.LocSymbol-  , lmArgs :: [Symbol]-  , lmExpr :: Expr-  }--instance Show LMap where-  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t |-> \t" ++ show e--toLogicMap :: [(F.LocSymbol, [Symbol], Expr)] -> LogicMap-toLogicMap ls = mempty {lmSymDefs = M.fromList $ map toLMap ls}-  where-    toLMap (x, ys, e) = (F.val x, LMap {lmVar = x, lmArgs = ys, lmExpr = e})--eAppWithMap :: LogicMap -> F.Located Symbol -> [Expr] -> Expr -> Expr-eAppWithMap lmap f es expr-  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)-  , length xs == length es-  = F.subst (F.mkSubst $ zip xs es) e-  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)-  , isApp e-  = F.subst (F.mkSubst $ zip xs es) $ dropApp e (length xs - length es)-  | otherwise-  = expr--dropApp :: Expr -> Int -> Expr-dropApp e i | i <= 0 = e-dropApp (F.EApp e _) i = dropApp e (i-1)-dropApp _ _          = errorstar "impossible"--isApp :: Expr -> Bool-isApp (F.EApp (F.EVar _) (F.EVar _)) = True-isApp (F.EApp e (F.EVar _))          = isApp e-isApp _                              = False--data TyConP = TyConP-  { tcpLoc          :: !F.SourcePos-  , tcpCon          :: !TyCon-  , tcpFreeTyVarsTy :: ![RTyVar]-  , tcpFreePredTy   :: ![PVar RSort]-  , tcpVarianceTs   :: !VarianceInfo-  , tcpVariancePs   :: !VarianceInfo-  , tcpSizeFun      :: !(Maybe SizeFun)-  } deriving (Generic, Data, Typeable)--instance F.Loc TyConP where-  srcSpan tc = F.SS (tcpLoc tc) (tcpLoc tc)----- TODO: just use Located instead of dc_loc, dc_locE-data DataConP = DataConP-  { dcpLoc        :: !F.SourcePos-  , dcpCon        :: !DataCon                -- ^ Corresponding GHC DataCon-  , dcpFreeTyVars :: ![RTyVar]               -- ^ Type parameters-  , dcpFreePred   :: ![PVar RSort]           -- ^ Abstract Refinement parameters-  , dcpTyConstrs  :: ![SpecType]             -- ^ ? Class constraints (via `dataConStupidTheta`)-  , dcpTyArgs     :: ![(Symbol, SpecType)]   -- ^ Value parameters-  , dcpTyRes      :: !SpecType               -- ^ Result type-  , dcpIsGadt     :: !Bool                   -- ^ Was this specified in GADT style (if so, DONT use function names as fields)-  , dcpModule     :: !F.Symbol               -- ^ Which module was this defined in-  , dcpLocE       :: !F.SourcePos-  } deriving (Generic, Data, Typeable)---- | [NOTE:DataCon-Data] for each 'DataConP' we also---   store the type of the constructed data. This is---   *the same as* 'tyRes' for *vanilla* ADTs---   (e.g. List, Maybe etc.) but may differ for GADTs.---   For example,------      data Thing a where---        X  :: Thing Int---        Y  :: Thing Bool------   Here the 'DataConP' associated with 'X' (resp. 'Y')---   has 'tyRes' corresponding to 'Thing Int' (resp. 'Thing Bool'),---   but in both cases, the 'tyData' should be 'Thing a'.-----instance F.Loc DataConP where-  srcSpan d = F.SS (dcpLoc d) (dcpLocE d)---- | Which Top-Level Binders Should be Verified-data TargetVars = AllVars | Only ![Var]-------------------------------------------------------------------------- | Abstract Predicate Variables ---------------------------------------------------------------------------------------------------------data PVar t = PV-  { pname :: !Symbol-  , ptype :: !(PVKind t)-  , parg  :: !Symbol-  , pargs :: ![(t, Symbol, Expr)]-  } deriving (Generic, Data, Typeable, Show, Functor)--instance Eq (PVar t) where-  pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}--instance Ord (PVar t) where-  compare (PV n _ _ _)  (PV n' _ _ _) = compare n n'--instance B.Binary t => B.Binary (PVar t)-instance NFData t   => NFData   (PVar t)--instance Hashable (PVar a) where-  hashWithSalt i (PV n _ _ _) = hashWithSalt i n--pvType :: PVar t -> t-pvType p = case ptype p of-             PVProp t -> t-             PVHProp  -> panic Nothing "pvType on HProp-PVar"--data PVKind t-  = PVProp t-  | PVHProp-  deriving (Generic, Data, Typeable, Functor, F.Foldable, Traversable, Show)--instance B.Binary a => B.Binary (PVKind a)-instance NFData a   => NFData   (PVKind a)-------------------------------------------------------------------------------------- | Predicates ---------------------------------------------------------------------------------------------------------------------------------------------------type UsedPVar      = PVar ()--newtype Predicate  = Pr [UsedPVar]-  deriving (Generic, Data, Typeable)-  deriving Hashable via Generically Predicate--instance Eq Predicate where-  (Pr vs) == (Pr ws)-      = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']-        where-          vs' = L.sort vs-          ws' = L.sort ws----instance B.Binary Predicate--instance NFData Predicate where-  rnf _ = ()--instance Monoid Predicate where-  mempty  = pdTrue-  mappend = (<>)--instance Semigroup Predicate where-  p <> p' = pdAnd [p, p']--instance Semigroup a => Semigroup (UReft a) where-  MkUReft x y <> MkUReft x' y' = MkUReft (x <> x') (y <> y')--instance (Monoid a) => Monoid (UReft a) where-  mempty  = MkUReft mempty mempty-  mappend = (<>)---pdTrue :: Predicate-pdTrue         = Pr []--pdAnd :: Foldable t => t Predicate -> Predicate-pdAnd ps       = Pr (nub $ concatMap pvars ps)--pvars :: Predicate -> [UsedPVar]-pvars (Pr pvs) = pvs--instance F.Subable UsedPVar where-  syms pv         = [ y | (_, x, F.EVar y) <- pargs pv, x /= y ]-  subst s pv      = pv { pargs = mapThd3 (F.subst s)  <$> pargs pv }-  substf f pv     = pv { pargs = mapThd3 (F.substf f) <$> pargs pv }-  substa f pv     = pv { pargs = mapThd3 (F.substa f) <$> pargs pv }---instance F.Subable Predicate where-  syms     (Pr pvs) = concatMap F.syms   pvs-  subst  s (Pr pvs) = Pr (F.subst s  <$> pvs)-  substf f (Pr pvs) = Pr (F.substf f <$> pvs)-  substa f (Pr pvs) = Pr (F.substa f <$> pvs)--instance NFData r => NFData (UReft r)--data RelExpr = ERBasic F.Expr | ERChecked Expr RelExpr | ERUnChecked Expr RelExpr-  deriving (Eq, Show, Data, Generic)--instance B.Binary RelExpr--instance F.PPrint RelExpr where-  pprintTidy k (ERBasic e)       = F.pprintTidy k e-  pprintTidy k (ERChecked e r)   = F.pprintTidy k e <+> "!=>" <+> F.pprintTidy k r-  pprintTidy k (ERUnChecked e r) = F.pprintTidy k e <+> ":=>" <+> F.pprintTidy k r--newtype BTyVar = BTV Symbol deriving (Show, Generic, Data, Typeable)--newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)--instance Eq BTyVar where-  (BTV x) == (BTV y) = x == y--instance Ord BTyVar where-  compare (BTV x) (BTV y) = compare x y--instance IsString BTyVar where-  fromString = BTV . fromString--instance B.Binary BTyVar-instance Hashable BTyVar-instance NFData   BTyVar-instance NFData   RTyVar--instance F.Symbolic BTyVar where-  symbol (BTV tv) = tv--instance F.Symbolic RTyVar where-  symbol (RTV tv) = F.symbol tv -- tyVarUniqueSymbol tv---- instance F.Symbolic RTyVar where-  -- symbol (RTV tv) = F.symbol . getName $ tv--- rtyVarUniqueSymbol  :: RTyVar -> Symbol--- rtyVarUniqueSymbol (RTV tv) = tyVarUniqueSymbol tv--- tyVarUniqueSymbol :: TyVar -> Symbol--- tyVarUniqueSymbol tv = F.symbol $ show (getName tv) ++ "_" ++ show (varUnique tv)--data BTyCon = BTyCon-  { btc_tc    :: !F.LocSymbol    -- ^ TyCon name with location information-  , btc_class :: !Bool           -- ^ Is this a class type constructor?-  , btc_prom  :: !Bool           -- ^ Is Promoted Data Con?-  }-  deriving (Generic, Data, Typeable)-  deriving Hashable via Generically BTyCon--instance B.Binary BTyCon--data RTyCon = RTyCon-  { rtc_tc    :: TyCon         -- ^ GHC Type Constructor-  , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters-  , rtc_info  :: !TyConInfo    -- ^ TyConInfo-  }-  deriving (Generic, Data, Typeable)--instance F.Symbolic RTyCon where-  symbol = F.symbol . rtc_tc--instance F.Symbolic BTyCon where-  symbol = F.val . btc_tc--instance NFData BTyCon--instance NFData RTyCon--rtyVarType :: RTyVar -> Type-rtyVarType (RTV v) = TyVarTy v--tyVarVar :: RTVar RTyVar c -> Var-tyVarVar (RTVar (RTV v) _) = v----mkBTyCon :: F.LocSymbol -> BTyCon-mkBTyCon x = BTyCon x False False----- | Accessors for @RTyCon@--isBool :: RType RTyCon t t1 -> Bool-isBool (RApp RTyCon{rtc_tc = c} _ _ _) = c == boolTyCon-isBool _                                 = False--isRVar :: RType c tv r -> Bool-isRVar (RVar _ _) = True-isRVar _          = False--isClassBTyCon :: BTyCon -> Bool-isClassBTyCon = btc_class---- isClassRTyCon :: RTyCon -> Bool--- isClassRTyCon x = (isClassTyCon $ rtc_tc x) || (rtc_tc x == eqPrimTyCon)--rTyConPVs :: RTyCon -> [RPVar]-rTyConPVs     = rtc_pvars--rTyConPropVs :: RTyCon -> [PVar RSort]-rTyConPropVs  = filter isPropPV . rtc_pvars--isPropPV :: PVar t -> Bool-isPropPV      = isProp . ptype--isEqType :: TyConable c => RType c t t1 -> Bool-isEqType (RApp c _ _ _) = isEqual c-isEqType _              = False---isClassType :: TyConable c => RType c t t1 -> Bool-isClassType (RApp c _ _ _) = isClass c-isClassType _              = False--isEmbeddedClass :: TyConable c => RType c t t1 -> Bool-isEmbeddedClass (RApp c _ _ _) = isEmbeddedDict c-isEmbeddedClass _              = False---- rTyConPVHPs = filter isHPropPV . rtc_pvars--- isHPropPV   = not . isPropPV--isProp :: PVKind t -> Bool-isProp (PVProp _) = True-isProp _          = False---defaultTyConInfo :: TyConInfo-defaultTyConInfo = TyConInfo [] [] Nothing--instance Default TyConInfo where-  def = defaultTyConInfo----------------------------------------------------------------------------- | Co- and Contra-variance for TyCon ------------------------------------------------------------------------------------------------------------ | Indexes start from 0 and type or predicate arguments can be both---   covariant and contravaariant e.g., for the below Foo dataType------     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>---       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)------  there will be:------    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant]---    variancePsArgs     = [Covariant, Contravatiant, Bivariant]-----data TyConInfo = TyConInfo-  { varianceTyArgs  :: !VarianceInfo      -- ^ variance info for type variables-  , variancePsArgs  :: !VarianceInfo      -- ^ variance info for predicate variables-  , sizeFunction    :: !(Maybe SizeFun)   -- ^ logical UNARY function that computes the size of the structure-  } deriving (Generic, Data, Typeable)--instance NFData TyConInfo--instance Show TyConInfo where-  show (TyConInfo x y _) = show x ++ "\n" ++ show y------------------------------------------------------------------------------------- | Unified Representation of Refinement Types -------------------------------------------------------------------------------------------------------------------type RTVU c tv = RTVar tv (RType c tv ())-type PVU  c tv = PVar     (RType c tv ())--instance Show tv => Show (RTVU c tv) where-  show (RTVar t _) = show t--data RType c tv r-  = RVar {-      rt_var    :: !tv-    , rt_reft   :: !r-    }--  | RFun  {-      rt_bind   :: !Symbol-    , rt_rinfo  :: !RFInfo-    , rt_in     :: !(RType c tv r)-    , rt_out    :: !(RType c tv r)-    , rt_reft   :: !r-    }--  | RAllT {-      rt_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ()))-    , rt_ty     :: !(RType c tv r)-    , rt_ref    :: !r-    }--  -- | "forall x y <z :: Nat, w :: Int> . TYPE"-  --               ^^^^^^^^^^^^^^^^^^^ (rt_pvbind)-  | RAllP {-      rt_pvbind :: !(PVU c tv)-    , rt_ty     :: !(RType c tv r)-    }--  -- | For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)-  --   * the `RProp`  denoted by `{\h -> v > h}` to-  --   * the `RTyCon` denoted by `[]`.-  | RApp  {-      rt_tycon  :: !c-    , rt_args   :: ![RType  c tv r]-    , rt_pargs  :: ![RTProp c tv r]-    , rt_reft   :: !r-    }--  | RAllE {-      rt_bind   :: !Symbol-    , rt_allarg :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | REx {-      rt_bind   :: !Symbol-    , rt_exarg  :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | RExprArg (F.Located Expr)                   -- ^ For expression arguments to type aliases-                                                --   see tests/pos/vector2.hs-  | RAppTy{-      rt_arg   :: !(RType c tv r)-    , rt_res   :: !(RType c tv r)-    , rt_reft  :: !r-    }--  | RRTy  {-      rt_env   :: ![(Symbol, RType c tv r)]-    , rt_ref   :: !r-    , rt_obl   :: !Oblig-    , rt_ty    :: !(RType c tv r)-    }--  | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`-            --   see tests/pos/Holes.hs-  deriving (Eq, Generic, Data, Typeable, Functor)-  deriving Hashable via Generically (RType c tv r)--instance (B.Binary c, B.Binary tv, B.Binary r) => B.Binary (RType c tv r)-instance (NFData c, NFData tv, NFData r)       => NFData (RType c tv r)--ignoreOblig :: RType t t1 t2 -> RType t t1 t2-ignoreOblig (RRTy _ _ _ t) = t-ignoreOblig t              = t--makeRTVar :: tv -> RTVar tv s-makeRTVar a = RTVar a (RTVNoInfo True)--instance (Eq tv) => Eq (RTVar tv s) where-  t1 == t2 = ty_var_value t1 == ty_var_value t2--data RTVar tv s = RTVar-  { ty_var_value :: tv-  , ty_var_info  :: RTVInfo s-  } deriving (Generic, Data, Typeable)-    deriving Hashable via Generically (RTVar tv s)--mapTyVarValue :: (tv1 -> tv2) -> RTVar tv1 s -> RTVar tv2 s-mapTyVarValue f v = v {ty_var_value = f $ ty_var_value v}--dropTyVarInfo :: RTVar tv s1 -> RTVar tv s2-dropTyVarInfo v = v{ty_var_info = RTVNoInfo True }--data RTVInfo s-  = RTVNoInfo { rtv_is_pol :: Bool }-  | RTVInfo { rtv_name   :: Symbol-            , rtv_kind   :: s-            , rtv_is_val :: Bool-            , rtv_is_pol :: Bool -- true iff the type variable gets instantiated with-                                 -- any refinement (ie is polymorphic on refinements),-                                 -- false iff instantiation is with true refinement-            } deriving (Generic, Data, Typeable, Functor, Eq)-              deriving Hashable via Generically (RTVInfo s)---setRtvPol :: RTVar tv a -> Bool -> RTVar tv a-setRtvPol (RTVar a i) b = RTVar a (i{rtv_is_pol = b})--rTVarToBind :: RTVar RTyVar s  -> Maybe (Symbol, s)-rTVarToBind = go . ty_var_info-  where-    go RTVInfo{..} | rtv_is_val = Just (rtv_name, rtv_kind)-    go _                        = Nothing--tyVarIsVal :: RTVar tv s -> Bool-tyVarIsVal = rtvinfoIsVal . ty_var_info--rtvinfoIsVal :: RTVInfo s -> Bool-rtvinfoIsVal RTVNoInfo{} = False-rtvinfoIsVal RTVInfo{..} = rtv_is_val--instance (B.Binary tv, B.Binary s) => B.Binary (RTVar tv s)-instance (NFData tv, NFData s)     => NFData   (RTVar tv s)-instance (NFData s)                => NFData   (RTVInfo s)-instance (B.Binary s)              => B.Binary (RTVInfo s)---- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors.---   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)---   * the `RProp`  denoted by `{\h -> v > h}` to---   * the `RTyCon` denoted by `[]`.---   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated---   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type.---   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies---   directly to any type and has semantics _independent of_ the data-type.--data Ref τ t = RProp-  { rf_args :: [(Symbol, τ)] -- ^ arguments. e.g. @h@ in the above example-  , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`. e.g. @v > h@ in the above example-  } deriving (Eq, Generic, Data, Typeable, Functor)-    deriving Hashable via Generically (Ref τ t)--instance (B.Binary τ, B.Binary t) => B.Binary (Ref τ t)-instance (NFData τ,   NFData t)   => NFData   (Ref τ t)--rPropP :: [(Symbol, τ)] -> r -> Ref τ (RType c tv r)-rPropP τ r = RProp τ (RHole r)---- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing.---   In general, perhaps we need not expose @Ref@ directly at all.-type RTProp c tv r = Ref (RType c tv ()) (RType c tv r)----- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders---   that satisfies two invariants (TODO:LIQUID):---   1. Each `hs_addr :: Symbol` appears at most once,---   2. There is at most one `HVar` in a list.--newtype World t = World [HSeg t]-                deriving (Generic, Data, Typeable)--data    HSeg  t = HBind {hs_addr :: !Symbol, hs_val :: t}-                | HVar UsedPVar-                deriving (Generic, Data, Typeable)--data UReft r = MkUReft-  { ur_reft   :: !r-  , ur_pred   :: !Predicate-  }-  deriving (Eq, Generic, Data, Typeable, Functor, Foldable, Traversable)-  deriving Hashable via Generically (UReft r)--instance B.Binary r => B.Binary (UReft r)--type BRType      = RType BTyCon BTyVar       -- ^ "Bare" parsed version-type RRType      = RType RTyCon RTyVar       -- ^ "Resolved" version-type RRep        = RTypeRep RTyCon RTyVar-type BSort       = BRType    ()-type RSort       = RRType    ()-type BPVar       = PVar      BSort-type RPVar       = PVar      RSort-type RReft       = UReft     F.Reft-type PrType      = RRType    Predicate-type BareType    = BRType    RReft-type SpecType    = RRType    RReft-type SpecRep     = RRep      RReft-type SpecProp    = RRProp    RReft-type RRProp r    = Ref       RSort (RRType r)-type BRProp r    = Ref       BSort (BRType r)-type SpecRTVar   = RTVar     RTyVar RSort----type LocBareType = F.Located BareType-type LocSpecType = F.Located SpecType--type SpecRTEnv   = RTEnv RTyVar SpecType-type BareRTEnv   = RTEnv Symbol BareType-type BareRTAlias = RTAlias Symbol BareType-type SpecRTAlias = RTAlias RTyVar SpecType---class SubsTy tv ty a where-  subt :: (tv, ty) -> a -> a--class (Eq c) => TyConable c where-  isFun    :: c -> Bool-  isList   :: c -> Bool-  isTuple  :: c -> Bool-  ppTycon  :: c -> Doc-  isClass  :: c -> Bool-  isEmbeddedDict :: c -> Bool-  isEqual  :: c -> Bool-  isOrdCls  :: c -> Bool-  isEqCls   :: c -> Bool--  isNumCls  :: c -> Bool-  isFracCls :: c -> Bool--  isClass   = const False-  isEmbeddedDict c = isNumCls c || isEqual c || isOrdCls c || isEqCls c-  isOrdCls  = const False-  isEqCls   = const False-  isEqual   = const False-  isNumCls  = const False-  isFracCls = const False----- Should just make this a @Pretty@ instance but its too damn tedious--- to figure out all the constraints.--type OkRT c tv r = ( TyConable c-                   , F.PPrint tv, F.PPrint c, F.PPrint r-                   , F.Reftable r, F.Reftable (RTProp c tv ()), F.Reftable (RTProp c tv r)-                   , Eq c, Eq tv-                   , Hashable tv-                   )------------------------------------------------------------------------------------ | TyConable Instances -----------------------------------------------------------------------------------------------------------------------------------------instance TyConable RTyCon where-  isFun      = isArrowTyCon . rtc_tc-  isList     = (listTyCon ==) . rtc_tc-  isTuple    = Ghc.isTupleTyCon   . rtc_tc-  isClass    = isClass . rtc_tc -- isClassRTyCon-  isEqual    = isEqual . rtc_tc-  ppTycon    = F.toFix--  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)-                (tyConClass_maybe $ rtc_tc c)-  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)-                (tyConClass_maybe $ rtc_tc c)-  isOrdCls  c = maybe False isOrdClass (tyConClass_maybe $ rtc_tc c)-  isEqCls   c = isEqCls (rtc_tc c)---instance TyConable TyCon where-  isFun      = isArrowTyCon-  isList     = (listTyCon ==)-  isTuple    = Ghc.isTupleTyCon-  isClass c  = isClassTyCon c   || isEqual c -- c == eqPrimTyCon-  isEqual c  = c == eqPrimTyCon || c == eqReprPrimTyCon-  ppTycon    = text . showPpr--  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)-                (tyConClass_maybe c)-  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)-                (tyConClass_maybe c)-  isOrdCls c  = maybe False isOrdClass-                (tyConClass_maybe c)-  isEqCls  c  = isPrelEqTyCon c--isClassOrSubClass :: (Class -> Bool) -> Class -> Bool-isClassOrSubClass p cls-  = p cls || any (isClassOrSubClass p . fst)-                 (mapMaybe getClassPredTys_maybe (classSCTheta cls))---- MOVE TO TYPES-instance TyConable Symbol where-  isFun   s = F.funConName == s-  isList  s = F.listConName == s-  isTuple s = F.tupConName == s-  ppTycon   = text . F.symbolString--instance TyConable F.LocSymbol where-  isFun   = isFun   . F.val-  isList  = isList  . F.val-  isTuple = isTuple . F.val-  ppTycon = ppTycon . F.val--instance TyConable BTyCon where-  isFun   = isFun . btc_tc-  isList  = isList . btc_tc-  isTuple = isTuple . btc_tc-  isClass = isClassBTyCon-  ppTycon = ppTycon . btc_tc---instance Eq RTyCon where-  x == y = rtc_tc x == rtc_tc y--instance Eq BTyCon where-  x == y = btc_tc x == btc_tc y--instance Ord BTyCon where-  compare x y = compare (btc_tc x) (btc_tc y)--instance F.Fixpoint RTyCon where-  toFix (RTyCon c _ _) = text $ showPpr c--instance F.Fixpoint BTyCon where-  toFix = text . F.symbolString . F.val . btc_tc--instance F.Fixpoint Cinfo where-  toFix = text . showPpr . ci_loc--instance Show Cinfo where-  show = show . F.toFix--instance F.PPrint RTyCon where-  pprintTidy k c-    | ppDebug ppEnv = F.pprintTidy k tc  <-> angleBrackets (F.pprintTidy k pvs)-    | otherwise     = text . showPpr . rtc_tc $ c-    where-      tc            = F.symbol (rtc_tc c)-      pvs           = rtc_pvars c--instance F.PPrint BTyCon where-  pprintTidy _ = text . F.symbolString . F.val . btc_tc--instance F.PPrint v => F.PPrint (RTVar v s) where-  pprintTidy k (RTVar x _) = F.pprintTidy k x--instance Show RTyCon where-  show = F.showpp--instance Show BTyCon where-  show = F.showpp--instance F.Loc BTyCon where-  srcSpan = F.srcSpan . btc_tc------------------------------------------------------------------------------------- | Refined Instances --------------------------------------------------------------------------------------------------------------------------------------------data RInstance t = RI-  { riclass :: BTyCon-  , ritype  :: [t]-  , risigs  :: [(F.LocSymbol, RISig t)]-  } deriving (Eq, Generic, Functor, Data, Typeable, Show)-    deriving Hashable via Generically (RInstance t)--data RILaws ty = RIL-  { rilName    :: BTyCon-  , rilSupers  :: [ty]-  , rilTyArgs  :: [ty]-  , rilEqus    :: [(F.LocSymbol, F.LocSymbol)]-  , rilPos     :: F.Located ()-  } deriving (Eq, Show, Functor, Data, Typeable, Generic)-    deriving Hashable via Generically (RILaws ty)--data RISig t = RIAssumed t | RISig t-  deriving (Eq, Generic, Functor, Data, Typeable, Show)-  deriving Hashable via Generically (RISig t)--instance F.PPrint t => F.PPrint (RISig t) where-  pprintTidy k = ppRISig k (empty :: Doc)--ppRISig :: (F.PPrint k, F.PPrint t) => F.Tidy -> k -> RISig t -> Doc-ppRISig k x (RIAssumed t) = "assume" <+> F.pprintTidy k x <+> "::" <+> F.pprintTidy k t-ppRISig k x (RISig t)     =              F.pprintTidy k x <+> "::" <+> F.pprintTidy k t--instance F.PPrint t => F.PPrint (RInstance t) where-  pprintTidy k (RI n ts mts) = ppMethods k "instance" n ts mts---instance (B.Binary t) => B.Binary (RInstance t)-instance (B.Binary t) => B.Binary (RISig t)-instance (B.Binary t) => B.Binary (RILaws t)--newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol (RISig ty)))-                    deriving (Semigroup, Monoid, Show, Functor)--type RDEnv = DEnv Var SpecType--data MethodType t = MT {tyInstance :: !(Maybe t), tyClass :: !(Maybe t) }-  deriving (Show)--getMethodType :: MethodType t -> Maybe t-getMethodType (MT (Just t) _ ) = Just t-getMethodType (MT _ t) = t------------------------------------------------------------------------------- | Values Related to Specifications -----------------------------------------------------------------------------------------------------------------data Axiom b s e = Axiom-  { aname  :: (Var, Maybe DataCon)-  , rname  :: Maybe b-  , abinds :: [b]-  , atypes :: [s]-  , alhs   :: e-  , arhs   :: e-  }--type HAxiom = Axiom Var    Type CoreExpr---- type AxiomEq = F.Equation--instance Show (Axiom Var Type CoreExpr) where-  show (Axiom (n, c) v bs _ts lhs rhs) = "Axiom : " ++-                                         "\nFun Name: " ++ showPpr n ++-                                         "\nReal Name: " ++ showPpr v ++-                                         "\nData Con: " ++ showPpr c ++-                                         "\nArguments:" ++ showPpr bs  ++-                                         -- "\nTypes    :" ++ (showPpr ts)  ++-                                         "\nLHS      :" ++ showPpr lhs ++-                                         "\nRHS      :" ++ showPpr rhs------------------------------------------------------------------------------------- | Data type refinements----------------------------------------------------------------------------------data DataDecl   = DataDecl-  { tycName   :: DataName              -- ^ Type  Constructor Name-  , tycTyVars :: [Symbol]              -- ^ Tyvar Parameters-  , tycPVars  :: [PVar BSort]          -- ^ PVar  Parameters-  , tycDCons  :: Maybe [DataCtor]      -- ^ Data Constructors (Nothing is reserved for non-GADT style empty data declarations)-  , tycSrcPos :: !F.SourcePos          -- ^ Source Position-  , tycSFun   :: Maybe SizeFun         -- ^ Default termination measure-  , tycPropTy :: Maybe BareType        -- ^ Type of Ind-Prop-  , tycKind   :: !DataDeclKind         -- ^ User-defined or Auto-lifted-  } deriving (Data, Typeable, Generic)-    deriving Hashable via Generically DataDecl---- | The name of the `TyCon` corresponding to a `DataDecl`-data DataName-  = DnName !F.LocSymbol                -- ^ for 'isVanillyAlgTyCon' we can directly use the `TyCon` name-  | DnCon  !F.LocSymbol                -- ^ for 'FamInst' TyCon we save some `DataCon` name-  deriving (Eq, Ord, Data, Typeable, Generic)---- | Data Constructor-data DataCtor = DataCtor-  { dcName   :: F.LocSymbol            -- ^ DataCon name-  , dcTyVars :: [F.Symbol]             -- ^ Type parameters-  , dcTheta  :: [BareType]             -- ^ The GHC ThetaType corresponding to DataCon.dataConSig-  , dcFields :: [(Symbol, BareType)]   -- ^ field-name and field-Type pairs-  , dcResult :: Maybe BareType         -- ^ Possible output (if in GADT form)-  } deriving (Data, Typeable, Generic, Eq)-    deriving Hashable via Generically DataCtor---- | Termination expressions-data SizeFun-  = IdSizeFun              -- ^ \x -> F.EVar x-  | SymSizeFun F.LocSymbol -- ^ \x -> f x-  deriving (Data, Typeable, Generic, Eq)-  deriving Hashable via Generically SizeFun---- | What kind of `DataDecl` is it?-data DataDeclKind-  = DataUser           -- ^ User defined data-definitions         (should have refined fields)-  | DataReflected      -- ^ Automatically lifted data-definitions (do not have refined fields)-  deriving (Eq, Data, Typeable, Generic, Show)-  deriving Hashable via Generically DataDeclKind--instance Show SizeFun where-  show IdSizeFun      = "IdSizeFun"-  show (SymSizeFun x) = "SymSizeFun " ++ show (F.val x)--szFun :: SizeFun -> Symbol -> Expr-szFun IdSizeFun      = F.EVar-szFun (SymSizeFun f) = \x -> F.mkEApp (F.symbol <$> f) [F.EVar x]--data HasDataDecl-  = NoDecl  (Maybe SizeFun)-  | HasDecl-  deriving (Show)--instance F.PPrint HasDataDecl where-  pprintTidy _ HasDecl    = text "HasDecl"-  pprintTidy k (NoDecl z) = text "NoDecl" <+> parens (F.pprintTidy k z)--hasDecl :: DataDecl -> HasDataDecl-hasDecl d-  | null (tycDCons d)-  = NoDecl (tycSFun d)-  -- // | Just s <- tycSFun d, null (tycDCons d)-  -- // = NoDecl (Just s)-  | otherwise-  = HasDecl--instance Hashable DataName where-  hashWithSalt i = hashWithSalt i . F.symbol---instance NFData   SizeFun-instance B.Binary SizeFun-instance NFData   DataDeclKind-instance B.Binary DataDeclKind-instance B.Binary DataName-instance B.Binary DataCtor-instance B.Binary DataDecl--instance Eq DataDecl where-  d1 == d2 = tycName d1 == tycName d2--instance Ord DataDecl where-  compare d1 d2 = compare (tycName d1) (tycName d2)--instance F.Loc DataCtor where-  srcSpan = F.srcSpan . dcName--instance F.Loc DataDecl where-  srcSpan = srcSpanFSrcSpan . sourcePosSrcSpan . tycSrcPos--instance F.Loc DataName where-  srcSpan (DnName z) = F.srcSpan z-  srcSpan (DnCon  z) = F.srcSpan z----- | For debugging.-instance Show DataDecl where-  show dd = printf "DataDecl: data = %s, tyvars = %s, sizeFun = %s, kind = %s" -- [at: %s]"-              (show $ tycName   dd)-              (show $ tycTyVars dd)-              (show $ tycSFun   dd)-              (show $ tycKind   dd)---instance Show DataName where-  show (DnName n) =               show (F.val n)-  show (DnCon  c) = "datacon:" ++ show (F.val c)--instance F.PPrint SizeFun where-  pprintTidy _ IdSizeFun      = "[id]"-  pprintTidy _ (SymSizeFun x) = brackets (F.pprint (F.val x))--instance F.Symbolic DataName where-  symbol = F.val . dataNameSymbol--instance F.Symbolic DataDecl where-  symbol = F.symbol . tycName--instance F.PPrint DataName where-  pprintTidy k (DnName n) = F.pprintTidy k (F.val n)-  pprintTidy k (DnCon  n) = F.pprintTidy k (F.val n)--  -- symbol (DnName z) = F.suffixSymbol "DnName" (F.val z)-  -- symbol (DnCon  z) = F.suffixSymbol "DnCon"  (F.val z)--dataNameSymbol :: DataName -> F.LocSymbol-dataNameSymbol (DnName z) = z-dataNameSymbol (DnCon  z) = z------------------------------------------------------------------------------------- | Refinement Type Aliases----------------------------------------------------------------------------------data RTAlias x a = RTA-  { rtName  :: Symbol             -- ^ name of the alias-  , rtTArgs :: [x]                -- ^ type parameters-  , rtVArgs :: [Symbol]           -- ^ value parameters-  , rtBody  :: a                  -- ^ what the alias expands to-  -- , rtMod   :: !ModName           -- ^ module where alias was defined-  } deriving (Eq, Data, Typeable, Generic, Functor)-    deriving Hashable via Generically (RTAlias x a)--- TODO support ghosts in aliases?--instance (B.Binary x, B.Binary a) => B.Binary (RTAlias x a)--mapRTAVars :: (a -> b) -> RTAlias a ty -> RTAlias b ty-mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt }--lmapEAlias :: LMap -> F.Located (RTAlias Symbol Expr)-lmapEAlias (LMap v ys e) = F.atLoc v (RTA (F.val v) [] ys e) -- (F.loc v) (F.loc v)-------------------------------------------------------------------------------------- | Constructor and Destructors for RTypes ----------------------------------------------------------------------------------------------------------------------data RTypeRep c tv r = RTypeRep-  { ty_vars   :: [(RTVar tv (RType c tv ()), r)]-  , ty_preds  :: [PVar (RType c tv ())]-  , ty_binds  :: [Symbol]-  , ty_info   :: [RFInfo]-  , ty_refts  :: [r]-  , ty_args   :: [RType c tv r]-  , ty_res    :: RType c tv r-  }--fromRTypeRep :: RTypeRep c tv r -> RType c tv r-fromRTypeRep RTypeRep{..}-  = mkArrow ty_vars ty_preds arrs ty_res-  where-    arrs = safeZip4WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_info, length ty_args, length ty_refts)) ty_binds ty_info ty_args ty_refts-----------------------------------------------------------------------------------toRTypeRep           :: RType c tv r -> RTypeRep c tv r----------------------------------------------------------------------------------toRTypeRep t         = RTypeRep αs πs xs is rs ts t''-  where-    (αs, πs, t') = bkUniv t-    ((xs, is, ts, rs), t'') = bkArrow t'--mkArrow :: [(RTVar tv (RType c tv ()), r)]-        -> [PVar (RType c tv ())]-        -> [(Symbol, RFInfo, RType c tv r, r)]-        -> RType c tv r-        -> RType c tv r-mkArrow αs πs zts = mkUnivs αs πs . mkRFuns zts-  where-    mkRFuns xts t = foldr (\(b,i,t1,r) t2 -> RFun b i t1 t2 r) t xts---- Do I need to keep track of implicits here too?-bkArrowDeep :: RType t t1 a -> ([Symbol], [RFInfo], [RType t t1 a], [a], RType t t1 a)-bkArrowDeep (RAllT _ t _)   = bkArrowDeep t-bkArrowDeep (RAllP _ t)     = bkArrowDeep t-bkArrowDeep (RFun x i t t' r) = let (xs, is, ts, rs, t'') = bkArrowDeep t' in-                                (x:xs, i:is, t:ts, r:rs, t'')-bkArrowDeep t               = ([], [], [], [], t)--bkArrow :: RType t t1 a -> ( ([Symbol], [RFInfo], [RType t t1 a], [a])-                           , RType t t1 a )-bkArrow t                = ((xs,is,ts,rs),t')-  where-    (xs, is, ts, rs, t') = bkFun t--bkFun :: RType t t1 a -> ([Symbol], [RFInfo], [RType t t1 a], [a], RType t t1 a)-bkFun (RFun x i t t' r) = let (xs, is, ts, rs, t'') = bkFun t' in-                          (x:xs, i:is, t:ts, r:rs, t'')-bkFun t                 = ([], [], [], [], t)--safeBkArrow ::(F.PPrint (RType t t1 a))-            => RType t t1 a -> ( ([Symbol], [RFInfo], [RType t t1 a], [a])-                               , RType t t1 a )-safeBkArrow t@RAllT {} = Prelude.error {- panic Nothing -} $ "safeBkArrow on RAllT" ++ F.showpp t-safeBkArrow (RAllP _ _)     = Prelude.error {- panic Nothing -} "safeBkArrow on RAllP"-safeBkArrow t               = bkArrow t--mkUnivs :: (Foldable t, Foldable t1)-        => t  (RTVar tv (RType c tv ()), r)-        -> t1 (PVar (RType c tv ()))-        -> RType c tv r-        -> RType c tv r-mkUnivs αs πs rt = foldr (\(a,r) t -> RAllT a t r) (foldr RAllP rt πs) αs--bkUnivClass :: SpecType -> ([(SpecRTVar, RReft)],[PVar RSort], [(RTyCon, [SpecType])], SpecType )-bkUnivClass t        = (as, ps, cs, t2)-  where-    (as, ps, t1) = bkUniv  t-    (cs, t2)     = bkClass t1---bkUniv :: RType tv c r -> ([(RTVar c (RType tv c ()), r)], [PVar (RType tv c ())], RType tv c r)-bkUniv (RAllT α t r) = let (αs, πs, t') = bkUniv t in ((α, r):αs, πs, t')-bkUniv (RAllP π t)   = let (αs, πs, t') = bkUniv t in (αs, π:πs, t')-bkUniv t             = ([], [], t)----- bkFun :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)--- bkFun (RFun x t t' r) = let (xs, ts, rs, t'') = bkFun t'  in (x:xs, t:ts, r:rs, t'')--- bkFun t               = ([], [], [], t)--bkUnivClass' :: SpecType ->-  ([(SpecRTVar, RReft)], [PVar RSort], [(Symbol, SpecType, RReft)], SpecType)-bkUnivClass' t = (as, ps, zip3 bs ts rs, t2)-  where-    (as, ps, t1) = bkUniv  t-    (bs, ts, rs, t2)     = bkClass' t1--bkClass' :: TyConable t => RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)-bkClass' (RFun x _ t@(RApp c _ _ _) t' r)-  | isClass c-  = let (xs, ts, rs, t'') = bkClass' t' in (x:xs, t:ts, r:rs, t'')-bkClass' (RRTy e r o t)-  = let (xs, ts, rs, t'') = bkClass' t in (xs, ts, rs, RRTy e r o t'')-bkClass' t-  = ([], [],[],t)--bkClass :: (F.PPrint c, TyConable c) => RType c tv r -> ([(c, [RType c tv r])], RType c tv r)-bkClass (RFun _ _ (RApp c t _ _) t' _)-  | F.notracepp ("IS-CLASS: " ++ F.showpp c) $ isClass c-  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')-bkClass (RRTy e r o t)-  = let (cs, t') = bkClass t in (cs, RRTy e r o t')-bkClass t-  = ([], t)--rFun :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rFun b t t' = RFun b defRFInfo t t' mempty--rFun' :: Monoid r => RFInfo -> Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rFun' i b t t' = RFun b i t t' mempty--rFunDebug :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rFunDebug b t t' = RFun b (classRFInfo True) t t' mempty--rCls :: Monoid r => TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r-rCls c ts   = RApp (RTyCon c [] defaultTyConInfo) ts [] mempty--rRCls :: Monoid r => c -> [RType c tv r] -> RType c tv r-rRCls rc ts = RApp rc ts [] mempty--addInvCond :: SpecType -> RReft -> SpecType-addInvCond t r'-  | F.isTauto $ ur_reft r' -- null rv-  = t-  | otherwise-  = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}-  where-    trep = toRTypeRep t-    tbd  = ty_res trep-    r    = r' {ur_reft = F.Reft (v, rx)}-    su   = (v, F.EVar x')-    x'   = "xInv"-    rx   = F.PIff (F.EVar v) $ F.subst1 rv su-    F.Reft(v, rv) = ur_reft r'-----------------------------------------------class F.Reftable r => UReftable r where-  ofUReft :: UReft F.Reft -> r-  ofUReft (MkUReft r _) = F.ofReft r---instance UReftable (UReft F.Reft) where-   ofUReft r = r--instance UReftable () where-   ofUReft _ = mempty--instance (F.PPrint r, F.Reftable r) => F.Reftable (UReft r) where-  isTauto               = isTautoUreft-  ppTy                  = ppTyUreft-  toReft (MkUReft r ps) = F.toReft r `F.meet` F.toReft ps-  params (MkUReft r _)  = F.params r-  bot (MkUReft r _)     = MkUReft (F.bot r) (Pr [])-  top (MkUReft r p)     = MkUReft (F.top r) (F.top p)-  ofReft r              = MkUReft (F.ofReft r) mempty--instance F.Expression (UReft ()) where-  expr = F.expr . F.toReft----isTautoUreft :: F.Reftable r => UReft r -> Bool-isTautoUreft u = F.isTauto (ur_reft u) && F.isTauto (ur_pred u)--ppTyUreft :: F.Reftable r => UReft r -> Doc -> Doc-ppTyUreft u@(MkUReft r p) d-  | isTautoUreft u = d-  | otherwise      = pprReft r (F.ppTy p d)--pprReft :: (F.Reftable r) => r -> Doc -> Doc-pprReft r d = braces (F.pprint v <+> colon <+> d <+> text "|" <+> F.pprint r')-  where-    r'@(F.Reft (v, _)) = F.toReft r--instance F.Subable r => F.Subable (UReft r) where-  syms (MkUReft r p)     = F.syms r ++ F.syms p-  subst s (MkUReft r z)  = MkUReft (F.subst s r)  (F.subst s z)-  substf f (MkUReft r z) = MkUReft (F.substf f r) (F.substf f z)-  substa f (MkUReft r z) = MkUReft (F.substa f r) (F.substa f z)--instance (F.Reftable r, TyConable c) => F.Subable (RTProp c tv r) where-  syms (RProp  ss r)     = (fst <$> ss) ++ F.syms r--  subst su (RProp ss (RHole r)) = RProp ss (RHole (F.subst su r))-  subst su (RProp  ss t) = RProp ss (F.subst su <$> t)--  substf f (RProp ss (RHole r)) = RProp ss (RHole (F.substf f r))-  substf f (RProp  ss t) = RProp ss (F.substf f <$> t)--  substa f (RProp ss (RHole r)) = RProp ss (RHole (F.substa f r))-  substa f (RProp  ss t) = RProp ss (F.substa f <$> t)---instance (F.Subable r, F.Reftable r, TyConable c) => F.Subable (RType c tv r) where-  syms        = foldReft False (\_ r acc -> F.syms r ++ acc) []-  -- 'substa' will substitute bound vars-  substa f    = emapExprArg (\_ -> F.substa f) []      . mapReft  (F.substa f)-  -- 'substf' will NOT substitute bound vars-  substf f    = emapExprArg (\_ -> F.substf f) []      . emapReft (F.substf . F.substfExcept f) []-  subst su    = emapExprArg (\_ -> F.subst su) []      . emapReft (F.subst  . F.substExcept su) []-  subst1 t su = emapExprArg (\_ e -> F.subst1 e su) [] $ emapReft (\xs r -> F.subst1Except xs r su) [] t---instance F.Reftable Predicate where-  isTauto (Pr ps)      = null ps--  bot (Pr _)           = panic Nothing "No BOT instance for Predicate"-  ppTy r d | F.isTauto r      = d-           | not (ppPs ppEnv) = d-           | otherwise        = d <-> angleBrackets (F.pprint r)--  toReft (Pr ps@(p:_))        = F.Reft (parg p, F.pAnd $ pToRef <$> ps)-  toReft _                    = mempty-  params                      = todo Nothing "TODO: instance of params for Predicate"--  ofReft = todo Nothing "TODO: Predicate.ofReft"--pToRef :: PVar a -> F.Expr-pToRef p = pApp (pname p) $ F.EVar (parg p) : (thd3 <$> pargs p)--pApp      :: Symbol -> [Expr] -> Expr-pApp p es = F.mkEApp fn (F.EVar p:es)-  where-    fn    = F.dummyLoc (pappSym n)-    n     = length es--pappSym :: Show a => a -> Symbol-pappSym n  = F.symbol $ "papp" ++ show n------------------------------------------------------------------------------------- | Visitors ----------------------------------------------------------------------------------------------------------------------------------------------------mapExprReft :: (Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft-mapExprReft f = mapReft g-  where-    g (MkUReft (F.Reft (x, e)) p) = MkUReft (F.Reft (x, f x e)) p---- const False (not dropping dict) is probably fine since there will not be refinement on--- dictionaries-isTrivial :: (F.Reftable r, TyConable c) => RType c tv r -> Bool-isTrivial = foldReft False (\_ r b -> F.isTauto r && b) True--mapReft ::  (r1 -> r2) -> RType c tv r1 -> RType c tv r2-mapReft f = emapReft (const f) []--emapReft ::  ([Symbol] -> r1 -> r2) -> [Symbol] -> RType c tv r1 -> RType c tv r2-emapReft f γ (RVar α r)        = RVar  α (f γ r)-emapReft f γ (RAllT α t r)     = RAllT α (emapReft f γ t) (f γ r)-emapReft f γ (RAllP π t)       = RAllP π (emapReft f γ t)-emapReft f γ (RFun x i t t' r) = RFun  x i (emapReft f γ t) (emapReft f (x:γ) t') (f (x:γ) r)-emapReft f γ (RApp c ts rs r)  = RApp  c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r)-emapReft f γ (RAllE z t t')    = RAllE z (emapReft f γ t) (emapReft f γ t')-emapReft f γ (REx z t t')      = REx   z (emapReft f γ t) (emapReft f γ t')-emapReft _ _ (RExprArg e)      = RExprArg e-emapReft f γ (RAppTy t t' r)   = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)-emapReft f γ (RRTy e r o t)    = RRTy  (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)-emapReft f γ (RHole r)         = RHole (f γ r)--emapRef :: ([Symbol] -> t -> s) ->  [Symbol] -> RTProp c tv t -> RTProp c tv s-emapRef  f γ (RProp s (RHole r))  = RProp s $ RHole (f γ r)-emapRef  f γ (RProp s t)         = RProp s $ emapReft f γ t--emapExprArg :: ([Symbol] -> Expr -> Expr) -> [Symbol] -> RType c tv r -> RType c tv r-emapExprArg f = go-  where-    go _ t@RVar{}          = t-    go _ t@RHole{}         = t-    go γ (RAllT α t r)     = RAllT α (go γ t) r-    go γ (RAllP π t)       = RAllP π (go γ t)-    go γ (RFun x i t t' r) = RFun  x i (go γ t) (go (x:γ) t') r-    go γ (RApp c ts rs r)  = RApp  c (go γ <$> ts) (mo γ <$> rs) r-    go γ (RAllE z t t')    = RAllE z (go γ t) (go γ t')-    go γ (REx z t t')      = REx   z (go γ t) (go γ t')-    go γ (RExprArg e)      = RExprArg (f γ <$> F.notracepp "RExprArg" e) -- <---- actual substitution-    go γ (RAppTy t t' r)   = RAppTy (go γ t) (go γ t') r-    go γ (RRTy e r o t)    = RRTy  (mapSnd (go γ) <$> e) r o (go γ t)--    mo _ t@(RProp _ RHole{}) = t-    mo γ (RProp s t)         = RProp s (go γ t)--foldRType :: (acc -> RType c tv r -> acc) -> acc -> RType c tv r -> acc-foldRType f = go-  where-    step a t                = go (f a t) t-    prep a (RProp _ RHole{}) = a-    prep a (RProp _ t)      = step a t-    go a RVar{}             = a-    go a RHole{}            = a-    go a RExprArg{}         = a-    go a (RAllT _ t _)      = step a t-    go a (RAllP _ t)        = step a t-    go a (RFun _ _ t t' _)  = foldl' step a [t, t']-    go a (RAllE _ t t')     = foldl' step a [t, t']-    go a (REx _ t t')       = foldl' step a [t, t']-    go a (RAppTy t t' _)    = foldl' step a [t, t']-    go a (RApp _ ts rs _)   = foldl' prep (foldl' step a ts) rs-    go a (RRTy e _ _ t)     = foldl' step a (t : (snd <$> e))----------------------------------------------------------------------------------------------------------- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t--- same as GhcMisc isBaseType---- isBase :: RType a -> Bool---- set all types to basic types, haskell `tx -> t` is translated to Arrow tx t--- isBase _ = True--isBase :: RType t t1 t2 -> Bool-isBase (RAllT _ t _)    = isBase t-isBase (RAllP _ t)      = isBase t-isBase (RVar _ _)       = True-isBase (RApp _ ts _ _)  = all isBase ts-isBase RFun{}           = False-isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2-isBase (RRTy _ _ _ t)   = isBase t-isBase (RAllE _ _ t)    = isBase t-isBase (REx _ _ t)      = isBase t-isBase _                = False--hasHoleTy :: RType t t1 t2 -> Bool-hasHoleTy (RVar _ _)        = False-hasHoleTy (RAllT _ t _)     = hasHoleTy t-hasHoleTy (RAllP _ t)       = hasHoleTy t-hasHoleTy (RFun _ _ t t' _) = hasHoleTy t || hasHoleTy t'-hasHoleTy (RApp _ ts _ _)   = any hasHoleTy ts-hasHoleTy (RAllE _ t t')    = hasHoleTy t || hasHoleTy t'-hasHoleTy (REx _ t t')      = hasHoleTy t || hasHoleTy t'-hasHoleTy (RExprArg _)      = False-hasHoleTy (RAppTy t t' _)   = hasHoleTy t || hasHoleTy t'-hasHoleTy (RHole _)         = True-hasHoleTy (RRTy xts _ _ t)  = hasHoleTy t || any hasHoleTy (snd <$> xts)--isFunTy :: RType t t1 t2 -> Bool-isFunTy (RAllE _ _ t)    = isFunTy t-isFunTy (RAllT _ t _)    = isFunTy t-isFunTy (RAllP _ t)      = isFunTy t-isFunTy RFun{}           = True-isFunTy _                = False--mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType c tv r2)-mapReftM f (RVar α r)        = fmap   (RVar  α)  (f r)-mapReftM f (RAllT α t r)     = liftM2 (RAllT α)  (mapReftM f t)         (f r)-mapReftM f (RAllP π t)       = fmap   (RAllP π)  (mapReftM f t)-mapReftM f (RFun x i t t' r) = liftM3 (RFun x i) (mapReftM f t)         (mapReftM f t')       (f r)-mapReftM f (RApp c ts rs r)  = liftM3 (RApp  c)  (mapM (mapReftM f) ts) (mapM (mapRefM f) rs) (f r)-mapReftM f (RAllE z t t')    = liftM2 (RAllE z)  (mapReftM f t)         (mapReftM f t')-mapReftM f (REx z t t')      = liftM2 (REx z)    (mapReftM f t)         (mapReftM f t')-mapReftM _ (RExprArg e)      = return $ RExprArg e-mapReftM f (RAppTy t t' r)   = liftM3 RAppTy (mapReftM f t) (mapReftM f t') (f r)-mapReftM f (RHole r)         = fmap   RHole      (f r)-mapReftM f (RRTy xts r o t)  = liftM4 RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t)--mapRefM  :: (Monad m) => (t -> m s) -> RTProp c tv t -> m (RTProp c tv s)-mapRefM  f (RProp s t)        = fmap    (RProp s)      (mapReftM f t)--mapPropM :: (Monad m) => (RTProp c tv r -> m (RTProp c tv r)) -> RType c tv r -> m (RType c tv r)-mapPropM _ (RVar α r)        = return $ RVar  α r-mapPropM f (RAllT α t r)     = liftM2 (RAllT α)   (mapPropM f t)          (return r)-mapPropM f (RAllP π t)       = fmap   (RAllP π)   (mapPropM f t)-mapPropM f (RFun x i t t' r) = liftM3 (RFun x i)  (mapPropM f t)          (mapPropM f t') (return r)-mapPropM f (RApp c ts rs r)  = liftM3 (RApp  c)   (mapM (mapPropM f) ts)  (mapM f rs)     (return r)-mapPropM f (RAllE z t t')    = liftM2 (RAllE z)   (mapPropM f t)          (mapPropM f t')-mapPropM f (REx z t t')      = liftM2 (REx z)     (mapPropM f t)          (mapPropM f t')-mapPropM _ (RExprArg e)      = return $ RExprArg e-mapPropM f (RAppTy t t' r)   = liftM3 RAppTy (mapPropM f t) (mapPropM f t') (return r)-mapPropM _ (RHole r)         = return $ RHole r-mapPropM f (RRTy xts r o t)  = liftM4 RRTy (mapM (mapSndM (mapPropM f)) xts) (return r) (return o) (mapPropM f t)-------------------------------------------------------------------------------------- foldReft :: (F.Reftable r, TyConable c) => (r -> a -> a) -> a -> RType c tv r -> a------------------------------------------------------------------------------------ foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptyF.SEnv-----------------------------------------------------------------------------------foldReft :: (F.Reftable r, TyConable c) => BScope -> (F.SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a----------------------------------------------------------------------------------foldReft bsc f = foldReft'  (\_ _ -> False) bsc id (\γ _ -> f γ)-----------------------------------------------------------------------------------foldReft' :: (F.Reftable r, TyConable c)-          => (Symbol -> RType c tv r -> Bool)-          -> BScope-          -> (RType c tv r -> b)-          -> (F.SEnv b -> Maybe (RType c tv r) -> r -> a -> a)-          -> a -> RType c tv r -> a----------------------------------------------------------------------------------foldReft' logicBind bsc g f-  = efoldReft logicBind bsc-              (\_ _ -> [])-              (const [])-              g-              (\γ t r z -> f γ t r z)-              (\_ γ -> γ)-              F.emptySEnv------ efoldReft :: F.Reftable r =>(p -> [RType c tv r] -> [(Symbol, a)])-> (RType c tv r -> a)-> (SEnv a -> Maybe (RType c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType c tv r-> c1-efoldReft :: (F.Reftable r, TyConable c)-          => (Symbol -> RType c tv r -> Bool)-          -> BScope-          -> (c  -> [RType c tv r] -> [(Symbol, a)])-          -> (RTVar tv (RType c tv ()) -> [(Symbol, a)])-          -> (RType c tv r -> a)-          -> (F.SEnv a -> Maybe (RType c tv r) -> r -> b -> b)-          -> (PVar (RType c tv ()) -> F.SEnv a -> F.SEnv a)-          -> F.SEnv a-          -> b-          -> RType c tv r-          -> b-efoldReft logicBind bsc cb dty g f fp = go-  where-    -- folding over RType-    go γ z me@(RVar _ r)                = f γ (Just me) r z-    go γ z me@(RAllT a t r)-       | tyVarIsVal a                   = f γ (Just me) r (go (insertsSEnv γ (dty a)) z t)-       | otherwise                      = f γ (Just me) r (go γ z t)-    go γ z (RAllP p t)                  = go (fp p γ) z t-    go γ z me@(RFun _ RFInfo{permitTC = permitTC} (RApp c ts _ _) t' r)-       | (if permitTC == Just True then isEmbeddedDict else isClass)-         c  = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')-    go γ z me@(RFun x _ t t' r)-       | logicBind x t                  = f γ (Just me) r (go γ' (go γ z t) t')-       | otherwise                      = f γ (Just me) r (go γ  (go γ z t) t')-       where-         γ'                             = insertSEnv x (g t) γ-    go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' γ' z ts) rs)-       where γ' = if bsc then insertSEnv (rTypeValueVar me) (g me) γ else γ--    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z me@(RRTy [] r _ t)           = f γ (Just me) r (go γ z t)-    go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)-    go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')-    go _ z (RExprArg _)                 = z-    go γ z me@(RHole r)                 = f γ (Just me) r z--    -- folding over Ref-    ho  γ z (RProp ss (RHole r))       = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z-    ho  γ z (RProp ss t)               = go (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) z t--    -- folding over [RType]-    go' γ z ts                 = foldr (flip $ go γ) z ts--    -- folding over [Ref]-    ho' γ z rs                 = foldr (flip $ ho γ) z rs--    envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)--mapRFInfo :: (RFInfo -> RFInfo) -> RType c tv r -> RType c tv r-mapRFInfo f (RAllT α t r)     = RAllT α (mapRFInfo f t) r-mapRFInfo f (RAllP π t)       = RAllP π (mapRFInfo f t)-mapRFInfo f (RFun x i t t' r) = RFun x (f i) (mapRFInfo f t) (mapRFInfo f t') r-mapRFInfo f (RAppTy t t' r)   = RAppTy (mapRFInfo f t) (mapRFInfo f t') r-mapRFInfo f (RApp c ts rs r)  = RApp c (mapRFInfo f <$> ts) (mapRFInfoRef f <$> rs) r-mapRFInfo f (REx b t1 t2)     = REx b  (mapRFInfo f t1) (mapRFInfo f t2)-mapRFInfo f (RAllE b t1 t2)   = RAllE b (mapRFInfo f t1) (mapRFInfo f t2)-mapRFInfo f (RRTy e r o t)    = RRTy (mapSnd (mapRFInfo f) <$> e) r o (mapRFInfo f t)-mapRFInfo _ t'                = t'--mapRFInfoRef :: (RFInfo -> RFInfo)-          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapRFInfoRef _ (RProp s (RHole r)) = RProp s $ RHole r-mapRFInfoRef f (RProp s t)    = RProp  s $ mapRFInfo f t--mapBot :: (RType c tv r -> RType c tv r) -> RType c tv r -> RType c tv r-mapBot f (RAllT α t r)     = RAllT α (mapBot f t) r-mapBot f (RAllP π t)       = RAllP π (mapBot f t)-mapBot f (RFun x i t t' r) = RFun x i (mapBot f t) (mapBot f t') r-mapBot f (RAppTy t t' r)   = RAppTy (mapBot f t) (mapBot f t') r-mapBot f (RApp c ts rs r)  = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r-mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2)-mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2)-mapBot f (RRTy e r o t)    = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t)-mapBot f t'                = f t'--mapBotRef :: (RType c tv r -> RType c tv r)-          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapBotRef _ (RProp s (RHole r)) = RProp s $ RHole r-mapBotRef f (RProp s t)         = RProp s $ mapBot f t--mapBind :: (Symbol -> Symbol) -> RType c tv r -> RType c tv r-mapBind f (RAllT α t r)      = RAllT α (mapBind f t) r-mapBind f (RAllP π t)        = RAllP π (mapBind f t)-mapBind f (RFun b i t1 t2 r) = RFun (f b) i (mapBind f t1) (mapBind f t2) r-mapBind f (RApp c ts rs r)   = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r-mapBind f (RAllE b t1 t2)    = RAllE  (f b) (mapBind f t1) (mapBind f t2)-mapBind f (REx b t1 t2)      = REx    (f b) (mapBind f t1) (mapBind f t2)-mapBind _ (RVar α r)         = RVar α r-mapBind _ (RHole r)          = RHole r-mapBind f (RRTy e r o t)     = RRTy e r o (mapBind f t)-mapBind _ (RExprArg e)       = RExprArg e-mapBind f (RAppTy t t' r)    = RAppTy (mapBind f t) (mapBind f t') r--mapBindRef :: (Symbol -> Symbol)-           -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapBindRef f (RProp s (RHole r)) = RProp (mapFst f <$> s) (RHole r)-mapBindRef f (RProp s t)         = RProp (mapFst f <$> s) $ mapBind f t------------------------------------------------------ofRSort ::  F.Reftable r => RType c tv () -> RType c tv r-ofRSort = fmap mempty--toRSort :: RType c tv r -> RType c tv ()-toRSort = stripAnnotations . mapBind (const F.dummySymbol) . void--stripAnnotations :: RType c tv r -> RType c tv r-stripAnnotations (RAllT α t r)     = RAllT α (stripAnnotations t) r-stripAnnotations (RAllP _ t)       = stripAnnotations t-stripAnnotations (RAllE _ _ t)     = stripAnnotations t-stripAnnotations (REx _ _ t)       = stripAnnotations t-stripAnnotations (RFun x i t t' r) = RFun x i (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RAppTy t t' r)   = RAppTy (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RApp c ts rs r)  = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r-stripAnnotations (RRTy _ _ _ t)    = stripAnnotations t-stripAnnotations t                 = t--stripAnnotationsRef :: Ref τ (RType c tv r) -> Ref τ (RType c tv r)-stripAnnotationsRef (RProp s (RHole r)) = RProp s (RHole r)-stripAnnotationsRef (RProp s t)         = RProp s $ stripAnnotations t--insertSEnv :: F.Symbol -> a -> F.SEnv a -> F.SEnv a-insertSEnv = F.insertSEnv--insertsSEnv :: F.SEnv a -> [(Symbol, a)] -> F.SEnv a-insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)--rTypeValueVar :: (F.Reftable r) => RType c tv r -> Symbol-rTypeValueVar t = vv where F.Reft (vv,_) =  rTypeReft t--rTypeReft :: (F.Reftable r) => RType c tv r -> F.Reft-rTypeReft = maybe F.trueReft F.toReft . stripRTypeBase---- stripRTypeBase ::  RType a -> Maybe a-stripRTypeBase :: RType c tv r -> Maybe r-stripRTypeBase (RApp _ _ _ x)   = Just x-stripRTypeBase (RVar _ x)       = Just x-stripRTypeBase (RFun _ _ _ _ x) = Just x-stripRTypeBase (RAppTy _ _ x)   = Just x-stripRTypeBase (RAllT _ _ x)    = Just x-stripRTypeBase _                = Nothing--topRTypeBase :: (F.Reftable r) => RType c tv r -> RType c tv r-topRTypeBase = mapRBase F.top--mapRBase :: (r -> r) -> RType c tv r -> RType c tv r-mapRBase f (RApp c ts rs r)   = RApp c ts rs $ f r-mapRBase f (RVar a r)         = RVar a $ f r-mapRBase f (RFun x i t1 t2 r) = RFun x i t1 t2 $ f r-mapRBase f (RAppTy t1 t2 r)   = RAppTy t1 t2 $ f r-mapRBase _ t                  = t---------------------------------------------------------------------------------- | F.PPrint -------------------------------------------------------------------------------------------------------------------------------------------------instance F.PPrint (PVar a) where-  pprintTidy _ = pprPvar--pprPvar :: PVar a -> Doc-pprPvar (PV s _ _ xts) = F.pprint s <+> hsep (F.pprint <$> dargs xts)-  where-    dargs              = map thd3 . takeWhile (\(_, x, y) -> F.EVar x /= y)---instance F.PPrint Predicate where-  pprintTidy _ (Pr [])  = text "True"-  pprintTidy k (Pr pvs) = hsep $ punctuate (text "&") (F.pprintTidy k <$> pvs)----- | The type used during constraint generation, used---   also to define contexts for errors, hence in this---   file, and NOT in elsewhere. **DO NOT ATTEMPT TO MOVE**---   Am splitting into---   + global : many bindings, shared across all constraints---   + local  : few bindings, relevant to particular constraints--type REnv = AREnv SpecType--data AREnv t = REnv-  { reGlobal :: M.HashMap Symbol t -- ^ the "global" names for module-  , reLocal  :: M.HashMap Symbol t -- ^ the "local" names for sub-exprs-  }--instance Functor AREnv where-  fmap f (REnv g l) = REnv (fmap f g) (fmap f l)--instance (F.PPrint t) => F.PPrint (AREnv t) where-  pprintTidy k re =-    "RENV LOCAL"-    $+$-    ""-    $+$-    F.pprintTidy k (reLocal re)-    $+$-    ""-    $+$-    "RENV GLOBAL"-    $+$-    ""-    $+$-    F.pprintTidy k (reGlobal re)--instance Semigroup REnv where-  REnv g1 l1 <> REnv g2 l2 = REnv (g1 <> g2) (l1 <> l2)--instance Monoid REnv where-  mempty = REnv mempty mempty--instance NFData REnv where-  rnf REnv{} = ()------------------------------------------------------------------------------------- | Diagnostic info ----------------------------------------------------------------------------------------------------------------------------------------------data Warning = Warning {-    warnSpan :: SrcSpan-  , warnDoc  :: Doc-  } deriving (Eq, Show)--mkWarning :: SrcSpan -> Doc -> Warning-mkWarning = Warning--data Diagnostics = Diagnostics {-    dWarnings :: [Warning]-  , dErrors   :: [Error]-  } deriving Eq--instance Semigroup Diagnostics where-  (Diagnostics w1 e1) <> (Diagnostics w2 e2) = Diagnostics (w1 <> w2) (e1 <> e2)--instance Monoid Diagnostics where-  mempty  = emptyDiagnostics-  mappend = (<>)--mkDiagnostics :: [Warning] -> [Error] -> Diagnostics-mkDiagnostics = Diagnostics--emptyDiagnostics :: Diagnostics-emptyDiagnostics = Diagnostics mempty mempty--noErrors :: Diagnostics -> Bool-noErrors = L.null . dErrors--allWarnings :: Diagnostics -> [Warning]-allWarnings = dWarnings--allErrors :: Diagnostics -> [Error]-allErrors = dErrors------------------------------------------------------------------------------------- | Printing Warnings --------------------------------------------------------------------------------------------------------------------------------------------printWarning :: Logger -> Warning -> IO ()-printWarning logger (Warning srcSpan doc) = GHC.putWarnMsg logger srcSpan doc------------------------------------------------------------------------------------- | Error Data Type ----------------------------------------------------------------------------------------------------------------------------------------------type ErrorResult    = F.FixResult UserError-type Error          = TError SpecType---instance NFData a => NFData (TError a)------------------------------------------------------------------------------------- | Source Information Associated With Constraints ---------------------------------------------------------------------------------------------------------------data Cinfo    = Ci-  { ci_loc :: !SrcSpan-  , ci_err :: !(Maybe Error)-  , ci_var :: !(Maybe Var)-  }-  deriving (Eq, Generic)--instance F.Loc Cinfo where-  srcSpan = srcSpanFSrcSpan . ci_loc--instance NFData Cinfo--instance F.PPrint Cinfo where-  pprintTidy k = F.pprintTidy k . ci_loc------------------------------------------------------------------------------------ | Module Names -------------------------------------------------------------------------------------------------------------------------------------------------data ModName = ModName !ModType !ModuleName-  deriving (Eq, Ord, Show, Generic, Data, Typeable)--data ModType = Target | SrcImport | SpecImport-  deriving (Eq, Ord, Show, Generic, Data, Typeable)---- instance B.Binary ModType--- instance B.Binary ModName--instance Hashable ModType--instance Hashable ModName where-  hashWithSalt i (ModName t n) = hashWithSalt i (t, show n)--instance F.PPrint ModName where-  pprintTidy _ = text . show--instance F.Symbolic ModName where-  symbol (ModName _ m) = F.symbol m--instance F.Symbolic ModuleName where-  symbol = F.symbol . moduleNameFS---isTarget :: ModName -> Bool-isTarget (ModName Target _) = True-isTarget _                  = False--isSrcImport :: ModName -> Bool-isSrcImport (ModName SrcImport _) = True-isSrcImport _                     = False--isSpecImport :: ModName -> Bool-isSpecImport (ModName SpecImport _) = True-isSpecImport _                      = False--getModName :: ModName -> ModuleName-getModName (ModName _ m) = m--getModString :: ModName -> String-getModString = moduleNameString . getModName--qualifyModName :: ModName -> Symbol -> Symbol-qualifyModName n = qualifySymbol nSym-  where-    nSym         = F.symbol n------------------------------------------------------------------------------------- | Refinement Type Aliases -------------------------------------------------------------------------------------------------------------------------------------data RTEnv tv t = RTE-  { typeAliases :: M.HashMap Symbol (F.Located (RTAlias tv t))-  , exprAliases :: M.HashMap Symbol (F.Located (RTAlias Symbol Expr))-  }---instance Monoid (RTEnv tv t) where-  mempty  = RTE M.empty M.empty-  mappend = (<>)--instance Semigroup (RTEnv tv t) where-  RTE x y <> RTE x' y' = RTE (x `M.union` x') (y `M.union` y')---- mapRT :: (M.HashMap Symbol (RTAlias tv t) -> M.HashMap Symbol (RTAlias tv t))---      -> RTEnv tv t -> RTEnv tv t--- mapRT f e = e { typeAliases = f (typeAliases e) }---- mapRE :: (M.HashMap Symbol (RTAlias Symbol Expr)---       -> M.HashMap Symbol (RTAlias Symbol Expr))---      -> RTEnv tv t -> RTEnv tv t--- mapRE f e = e { exprAliases = f $ exprAliases e }-------------------------------------------------------------------------------------- | Measures----------------------------------------------------------------------------------data Body-  = E Expr          -- ^ Measure Refinement: {v | v = e }-  | P Expr          -- ^ Measure Refinement: {v | (? v) <=> p }-  | R Symbol Expr   -- ^ Measure Refinement: {v | p}-  deriving (Show, Data, Typeable, Generic, Eq)-  deriving Hashable via Generically Body--data Def ty ctor = Def-  { measure :: F.LocSymbol-  , ctor    :: ctor-  , dsort   :: Maybe ty-  , binds   :: [(Symbol, Maybe ty)]    -- measure binders: the ADT argument fields-  , body    :: Body-  } deriving (Show, Data, Typeable, Generic, Eq, Functor)-    deriving Hashable via Generically (Def ty ctor)--data Measure ty ctor = M-  { msName :: F.LocSymbol-  , msSort :: ty-  , msEqns :: [Def ty ctor]-  , msKind :: !MeasureKind-  , msUnSorted :: !UnSortedExprs -- potential unsorted expressions used at measure denifinitions-  } deriving (Eq, Data, Typeable, Generic, Functor)-    deriving Hashable via Generically (Measure ty ctor)--type UnSortedExprs = [UnSortedExpr] -- mempty = []-type UnSortedExpr  = ([F.Symbol], F.Expr)--data MeasureKind-  = MsReflect     -- ^ due to `reflect foo`-  | MsMeasure     -- ^ due to `measure foo` with old-style (non-haskell) equations-  | MsLifted      -- ^ due to `measure foo` with new-style haskell equations-  | MsClass       -- ^ due to `class measure` definition-  | MsAbsMeasure  -- ^ due to `measure foo` without equations c.f. tests/pos/T1223.hs-  | MsSelector    -- ^ due to selector-fields e.g. `data Foo = Foo { fld :: Int }`-  | MsChecker     -- ^ due to checkers  e.g. `is-F` for `data Foo = F ... | G ...`-  deriving (Eq, Ord, Show, Data, Typeable, Generic)-  deriving Hashable via Generically MeasureKind--instance F.Loc (Measure a b) where-  srcSpan = F.srcSpan . msName--instance Bifunctor Def where-  -- first f  (Def m ps c s bs b) = Def m (second f <$> ps) c (f <$> s) ((second (fmap f)) <$> bs) b-  -- second f (Def m ps c s bs b) = Def m ps (f c) s bs b-  first f  (Def m c s bs b) = Def m c (f <$> s) (second (fmap f) <$> bs) b-  second f (Def m c s bs b) = Def m (f c) s bs b---instance Bifunctor Measure where-  first  f (M n s es k u) = M n (f s) (first f <$> es) k u-  second f (M n s es k u) = M n s (second f <$> es)    k u--instance                             B.Binary MeasureKind-instance                             B.Binary Body-instance (B.Binary t, B.Binary c) => B.Binary (Def     t c)-instance (B.Binary t, B.Binary c) => B.Binary (Measure t c)---- NOTE: don't use the TH versions since they seem to cause issues--- building on windows :(--- deriveBifunctor ''Def--- deriveBifunctor ''Measure--data CMeasure ty = CM-  { cName :: F.LocSymbol-  , cSort :: ty-  } deriving (Data, Typeable, Generic, Functor)--instance F.PPrint Body where-  pprintTidy k (E e)   = F.pprintTidy k e-  pprintTidy k (P p)   = F.pprintTidy k p-  pprintTidy k (R v p) = braces (F.pprintTidy k v <+> "|" <+> F.pprintTidy k p)--instance F.PPrint a => F.PPrint (Def t a) where-  pprintTidy k (Def m c _ bs body)-           = F.pprintTidy k m <+> cbsd <+> "=" <+> F.pprintTidy k body-    where-      cbsd = parens (F.pprintTidy k c <-> hsep (F.pprintTidy k `fmap` (fst <$> bs)))--instance (F.PPrint t, F.PPrint a) => F.PPrint (Measure t a) where-  pprintTidy k (M n s eqs _ _) =  F.pprintTidy k n <+> {- parens (pprintTidy k (loc n)) <+> -} "::" <+> F.pprintTidy k s-                                  $$ vcat (F.pprintTidy k `fmap` eqs)---instance F.PPrint (Measure t a) => Show (Measure t a) where-  show = F.showpp--instance F.PPrint t => F.PPrint (CMeasure t) where-  pprintTidy k (CM n s) =  F.pprintTidy k n <+> "::" <+> F.pprintTidy k s--instance F.PPrint (CMeasure t) => Show (CMeasure t) where-  show = F.showpp---instance F.Subable (Measure ty ctor) where-  syms  m     = concatMap F.syms (msEqns m)-  substa f m  = m { msEqns = F.substa f  <$> msEqns m }-  substf f m  = m { msEqns = F.substf f  <$> msEqns m }-  subst  su m = m { msEqns = F.subst  su <$> msEqns m }-  -- substa f  (M n s es _) = M n s (F.substa f  <$> es) k-  -- substf f  (M n s es _) = M n s $ F.substf f  <$> es-  -- subst  su (M n s es _) = M n s $ F.subst  su <$> es--instance F.Subable (Def ty ctor) where-  syms (Def _ _ _ sb bd)  = (fst <$> sb) ++ F.syms bd-  substa f  (Def m c t b bd) = Def m c t b $ F.substa f  bd-  substf f  (Def m c t b bd) = Def m c t b $ F.substf f  bd-  subst  su (Def m c t b bd) = Def m c t b $ F.subst  su bd--instance F.Subable Body where-  syms (E e)       = F.syms e-  syms (P e)       = F.syms e-  syms (R s e)     = s : F.syms e--  substa f (E e)   = E   (F.substa f e)-  substa f (P e)   = P   (F.substa f e)-  substa f (R s e) = R s (F.substa f e)--  substf f (E e)   = E   (F.substf f e)-  substf f (P e)   = P   (F.substf f e)-  substf f (R s e) = R s (F.substf f e)--  subst su (E e)   = E   (F.subst su e)-  subst su (P e)   = P   (F.subst su e)-  subst su (R s e) = R s (F.subst su e)--instance F.Subable t => F.Subable (WithModel t) where-  syms (NoModel t)     = F.syms t-  syms (WithModel _ t) = F.syms t-  substa f             = fmap (F.substa f)-  substf f             = fmap (F.substf f)-  subst su             = fmap (F.subst su)--data RClass ty = RClass-  { rcName    :: BTyCon-  , rcSupers  :: [ty]-  , rcTyVars  :: [BTyVar]-  , rcMethods :: [(F.LocSymbol, ty)]-  } deriving (Eq, Show, Functor, Data, Typeable, Generic)-    deriving Hashable via Generically (RClass ty)---instance F.PPrint t => F.PPrint (RClass t) where-  pprintTidy k (RClass n ts as mts)-                = ppMethods k ("class" <+> supers ts) n as [(m, RISig t) | (m, t) <- mts]-    where-      supers [] = ""-      supers xs = tuplify (F.pprintTidy k   <$> xs) <+> "=>"-      tuplify   = parens . hcat . punctuate ", "---instance F.PPrint t => F.PPrint (RILaws t) where-  pprintTidy k (RIL n ss ts mts _) = ppEqs k ("instance laws" <+> supers ss) n ts mts-   where-    supers [] = ""-    supers xs = tuplify (F.pprintTidy k   <$> xs) <+> "=>"-    tuplify   = parens . hcat . punctuate ", "---ppEqs :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n)-          => F.Tidy -> Doc -> n -> [a] -> [(x, t)] -> Doc-ppEqs k hdr name args mts-  = vcat $ hdr <+> dName <+> "where"-         : [ nest 4 (bind m t) | (m, t) <- mts ]-    where-      dName    = parens  (F.pprintTidy k name <+> dArgs)-      dArgs    = gaps    (F.pprintTidy k      <$> args)-      gaps     = hcat . punctuate " "-      bind m t = F.pprintTidy k m <+> "=" <+> F.pprintTidy k t--ppMethods :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n)-          => F.Tidy -> Doc -> n -> [a] -> [(x, RISig t)] -> Doc-ppMethods k hdr name args mts-  = vcat $ hdr <+> dName <+> "where"-         : [ nest 4 (bind m t) | (m, t) <- mts ]-    where-      dName    = parens  (F.pprintTidy k name <+> dArgs)-      dArgs    = gaps    (F.pprintTidy k      <$> args)-      gaps     = hcat . punctuate " "-      bind m t = ppRISig k m t -- F.pprintTidy k m <+> "::" <+> F.pprintTidy k t--instance B.Binary ty => B.Binary (RClass ty)------------------------------------------------------------------------------ | Var Hole Info --------------------------------------------------------------------------------------------------------------------------------data HoleInfo i t = HoleInfo {htype :: t, hloc :: SrcSpan, henv :: AREnv t, info :: i }--instance Functor (HoleInfo i) where-  fmap f hinfo = hinfo{htype = f (htype hinfo), henv = fmap f (henv hinfo)}--instance (F.PPrint t) => F.PPrint (HoleInfo  i t) where-  pprintTidy k hinfo = text "type:" <+> F.pprintTidy k (htype hinfo)-                       <+> text "\n loc:" <+> F.pprintTidy k (hloc hinfo)-  -- to print the hole environment uncomment the following-  --                     <+> text "\n env:" <+> F.pprintTidy k (henv hinfo)----------------------------------------------------------------------------- | Annotations ----------------------------------------------------------------------------------------------------------------------------------newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)])-                    deriving (Data, Typeable, Generic, Functor)--data Annot t-  = AnnUse t-  | AnnDef t-  | AnnRDf t-  | AnnLoc SrcSpan-  deriving (Data, Typeable, Generic, Functor)--instance Monoid (AnnInfo a) where-  mempty  = AI M.empty-  mappend = (<>)--instance Semigroup (AnnInfo a) where-  AI m1 <> AI m2 = AI $ M.unionWith (++) m1 m2--instance NFData a => NFData (AnnInfo a)--instance NFData a => NFData (Annot a)------------------------------------------------------------------------------------- | Output -------------------------------------------------------------------------------------------------------------------------------------------------------data Output a = O-  { o_vars   :: Maybe [String]-  , o_types  :: !(AnnInfo a)-  , o_templs :: !(AnnInfo a)-  , o_bots   :: ![SrcSpan]-  , o_result :: ErrorResult-  } deriving (Typeable, Generic, Functor)--instance (F.PPrint a) => F.PPrint (Output a) where-  pprintTidy _ out = F.resultDoc (F.pprint <$> o_result out)--emptyOutput :: Output a-emptyOutput = O Nothing mempty mempty [] mempty--instance Monoid (Output a) where-  mempty  = emptyOutput-  mappend = (<>)--instance Semigroup (Output a) where-  o1 <> o2 = O { o_vars   =            sortNub <$> mappend (o_vars   o1) (o_vars   o2)-               , o_types  =                        mappend (o_types  o1) (o_types  o2)-               , o_templs =                        mappend (o_templs o1) (o_templs o2)-               , o_bots   = sortNubBy ordSrcSpan $ mappend (o_bots o1)   (o_bots   o2)-               , o_result =                        mappend (o_result o1) (o_result o2)-               }---- Ord a 'SrcSpan' if it's meaningful to do so (i.e. we have a 'RealSrcSpan'). Otherwise we default to EQ.-ordSrcSpan :: SrcSpan -> SrcSpan -> Ordering-ordSrcSpan (RealSrcSpan r1 _) (RealSrcSpan r2 _) = r1 `compare` r2-ordSrcSpan (RealSrcSpan _ _ ) _                  = GT-ordSrcSpan _                  (RealSrcSpan _ _ ) = LT-ordSrcSpan _                  _                  = EQ-------------------------------------------------------------------------------------- | KVar Profile -------------------------------------------------------------------------------------------------------------------------------------------------data KVKind-  = RecBindE    Var -- ^ Recursive binder      @letrec x = ...@-  | NonRecBindE Var -- ^ Non recursive binder  @let x = ...@-  | TypeInstE-  | PredInstE-  | LamE-  | CaseE       Int -- ^ Int is the number of cases-  | LetE-  | ProjectE        -- ^ Projecting out field of-  deriving (Generic, Eq, Ord, Show, Data, Typeable)--instance Hashable KVKind--newtype KVProf = KVP (M.HashMap KVKind Int) deriving (Generic)--emptyKVProf :: KVProf-emptyKVProf = KVP M.empty--updKVProf :: KVKind -> F.Kuts -> KVProf -> KVProf-updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + n) m-  where-    kn                  = M.lookupDefault 0 k m-    n                   = S.size (F.ksVars kvs)--instance NFData KVKind--instance F.PPrint KVKind where-  pprintTidy _ = text . show--instance F.PPrint KVProf where-  pprintTidy k (KVP m) = F.pprintTidy k (M.toList m)--instance NFData KVProf--hole :: Expr-hole = F.PKVar "HOLE" mempty--isHole :: Expr -> Bool-isHole (F.PKVar "HOLE" _) = True-isHole _                  = False--hasHole :: F.Reftable r => r -> Bool-hasHole = any isHole . F.conjuncts . F.reftPred . F.toReft--instance F.Symbolic DataCon where-  symbol = F.symbol . dataConWorkId--instance F.PPrint DataCon where-  pprintTidy _ = text . showPpr--instance Ord TyCon where-  compare = compare `on` F.symbol--instance Ord DataCon where-  compare = compare `on` F.symbol--instance F.PPrint TyThing where-  pprintTidy _ = text . showPpr--instance Show DataCon where-  show = F.showpp---- instance F.Symbolic TyThing where---  symbol = tyThingSymbol--liquidBegin :: String-liquidBegin = ['{', '-', '@']--liquidEnd :: String-liquidEnd = ['@', '-', '}']--data MSpec ty ctor = MSpec-  { ctorMap  :: M.HashMap Symbol [Def ty ctor]-  , measMap  :: M.HashMap F.LocSymbol (Measure ty ctor)-  , cmeasMap :: M.HashMap F.LocSymbol (Measure ty ())-  , imeas    :: ![Measure ty ctor]-  } deriving (Data, Typeable, Generic, Functor)--instance Bifunctor MSpec   where-  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c)-                                    (fmap (first f) m)-                                    (fmap (first f) cm)-                                    (fmap (first f) im)-  second                    = fmap--instance (F.PPrint t, F.PPrint a) => F.PPrint (MSpec t a) where-  pprintTidy k =  vcat . fmap (F.pprintTidy k . snd) . M.toList . measMap--instance (Show ty, Show ctor, F.PPrint ctor, F.PPrint ty) => Show (MSpec ty ctor) where-  show (MSpec ct m cm im)-    = "\nMSpec:\n" ++-      "\nctorMap:\t "  ++ show ct ++-      "\nmeasMap:\t "  ++ show m  ++-      "\ncmeasMap:\t " ++ show cm ++-      "\nimeas:\t "    ++ show im ++-      "\n"--instance Eq ctor => Semigroup (MSpec ty ctor) where-  MSpec c1 m1 cm1 im1 <> MSpec c2 m2 cm2 im2-    | (k1, k2) : _ <- dups-      -- = panic Nothing $ err (head dups)-    = uError $ err k1 k2-    | otherwise-    = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2) (cm1 `M.union` cm2) (im1 ++ im2)-    where-      dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, F.val k1 == F.val k2]-      err k1 k2 = ErrDupMeas (fSrcSpan k1) (F.pprint (F.val k1)) (fSrcSpan <$> [k1, k2])---instance Eq ctor => Monoid (MSpec ty ctor) where-  mempty = MSpec M.empty M.empty M.empty []-  mappend = (<>)--------------------------------------------------------------------------------------- Nasty PP stuff-----------------------------------------------------------------------------------instance F.PPrint BTyVar where-  pprintTidy _ (BTV α) = text (F.symbolString α)--instance F.PPrint RTyVar where-  pprintTidy k (RTV α)-   | ppTyVar ppEnv  = F.pprintTidy k (F.symbol α) -- shows full tyvar-   | otherwise      = ppr_tyvar_short α           -- drops the unique-suffix-   where-     ppr_tyvar_short :: TyVar -> Doc-     ppr_tyvar_short = text . showPpr--instance (F.PPrint r, F.Reftable r, F.PPrint t, F.PPrint (RType c tv r)) => F.PPrint (Ref t (RType c tv r)) where-  pprintTidy k (RProp ss s) = ppRefArgs k (fst <$> ss) <+> F.pprintTidy k s--ppRefArgs :: F.Tidy -> [Symbol] -> Doc-ppRefArgs _ [] = empty-ppRefArgs k ss = text "\\" <-> hsep (ppRefSym k <$> ss ++ [F.vv Nothing]) <+> "->"--ppRefSym :: (Eq a, IsString a, F.PPrint a) => F.Tidy -> a -> Doc-ppRefSym _ "" = text "_"-ppRefSym k s  = F.pprintTidy k s+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE TupleSections              #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Core types++module Language.Haskell.Liquid.Types.Types (++  -- * Ghc Information+    TyConMap     (..)++  -- * F.Located Things+  , F.Located (..)+  , F.dummyLoc++  -- * Symbols+  , F.LocSymbol+  , F.LocText++  -- * Default unknown name+  , F.dummyName+  , F.isDummy++  -- * Refinement Types+  , RTAlias (..)+  , lmapEAlias++  -- * Classes describing operations on `RTypes`+  , TyConable (..)+  , SubsTy (..)++  -- * Relational predicates+  , RelExpr+  , RelExprV (..)++  -- * Pre-instantiated RType+  , REnv+  , AREnv (..)++  -- * ???+  , Oblig(..)+  , ignoreOblig++  -- * Inferred Annotations+  , AnnInfo (..)+  , Annot (..)++  -- * Hole Information+  , HoleInfo(..)++  -- * Overall Output+  , Output (..)++  -- * Refinement Hole+  , hole, isHole, hasHole++  -- * Class for values that can be pretty printed+  , F.PPrint (..)+  , F.pprint+  , F.showpp++  -- * Modules and Imports+  , ModName (..), ModType (..)+  , isSrcImport, isSpecImport, isTarget+  , getModName, getModString++  -- * Refinement Type Aliases+  , RTEnv (..), BareRTEnv, SpecRTEnv, BareRTAlias, SpecRTAlias+  -- , mapRT, mapRE++  -- * Diagnostics, Warnings, Errors and Error Messages+  , Error+  , ErrorResult+  , Warning+  , mkWarning+  , Diagnostics+  , mkDiagnostics+  , emptyDiagnostics+  , noErrors+  , allWarnings+  , allErrors+  , printWarning++  -- * Source information (associated with constraints)+  , Cinfo (..)++  -- * Measures+  , Measure+  , MeasureV (..)+  , UnSortedExprs, UnSortedExpr+  , MeasureKind (..)+  , CMeasure (..)+  , Def+  , DefV (..)+  , Body+  , BodyV (..)+  , MSpec (..)+  , mapDefTy+  , mapMeasureTy+  , emapDefM+  , mapDefV+  , mapMeasureV+  , emapMeasureM+  , emapRelExprV++  -- * Type Classes+  , RClass (..)++  -- * KV Profiling+  , KVKind (..)   -- types of kvars+  , KVProf        -- profile table+  , emptyKVProf   -- empty profile+  , updKVProf     -- extend profile++  -- * Misc+  , mapRTAVars++  -- * CoreToLogic+  , LogicMap(..), toLMapV, mkLogicMap, toLogicMap, eAppWithMap, emapLMapM, LMapV(..), LMap++  -- * Refined Instances+  , RDEnv, DEnv(..), RInstance(..), RISig(..)+  , MethodType(..), getMethodType++  -- * String Literals+  , liquidBegin, liquidEnd++  , Axiom(..), HAxiom++  , ordSrcSpan+  )+  where++import           Liquid.GHC.API as Ghc hiding ( Binary+                                              , Expr+                                              , isFunTy+                                              , ($+$)+                                              , nest+                                              , text+                                              , blankLine+                                              , (<+>)+                                              , vcat+                                              , hsep+                                              , comma+                                              , colon+                                              , parens+                                              , empty+                                              , char+                                              , panic+                                              , int+                                              , hcat+                                              , showPpr+                                              , punctuate+                                              , ($$)+                                              , braces+                                              , angleBrackets+                                              , brackets+                                              )+import           Data.String+import           Data.Binary+import           GHC.Generics+import           Prelude                          hiding  (error)++import           Control.DeepSeq+import           Data.Bifunctor+import           Data.Typeable                          (Typeable)+import           Data.Generics                          (Data)+import qualified Data.Binary                            as B+import           Data.Hashable+import qualified Data.HashMap.Strict                    as M+import qualified Data.HashSet                           as S+import           Data.Function                          (on)+import           Data.Text                              (Text)+import           Text.PrettyPrint.HughesPJ              hiding (first, (<>))+import           Language.Fixpoint.Misc++import qualified Language.Fixpoint.Types as F+import           Language.Fixpoint.Types (Expr, Symbol)++import           Language.Haskell.Liquid.GHC.Misc+import           Language.Haskell.Liquid.GHC.Logging as GHC+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.Names+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Misc+++-----------------------------------------------------------------------------+-- | Information about Type Constructors+-----------------------------------------------------------------------------+data TyConMap = TyConMap+  { tcmTyRTy    :: M.HashMap TyCon             RTyCon  -- ^ Map from GHC TyCon to RTyCon+  , tcmFIRTy    :: M.HashMap (TyCon, [F.Sort]) RTyCon  -- ^ Map from GHC Family-Instances to RTyCon+  , tcmFtcArity :: M.HashMap TyCon             Int     -- ^ Arity of each Family-Tycon+  }++-----------------------------------------------------------------------------+-- | Relational predicates --------------------------------------------------+-----------------------------------------------------------------------------++type RelExpr = RelExprV F.Symbol+data RelExprV v = ERBasic (F.ExprV v) | ERChecked (F.ExprV v) (RelExprV v) | ERUnChecked (F.ExprV v) (RelExprV v)+  deriving (Eq, Show, Data, Generic, Functor, Foldable, Traversable)+  deriving B.Binary via Generically (RelExprV v)++emapRelExprV :: Monad m => ([Symbol] -> v0 -> m v1) -> RelExprV v0 -> m (RelExprV v1)+emapRelExprV f = go+  where+    go (ERBasic e) = ERBasic <$> emapExprVM f e+    go (ERChecked e re) = ERChecked <$> emapExprVM f e <*> go re+    go (ERUnChecked e re) = ERUnChecked <$> emapExprVM f e <*> go re++instance F.PPrint RelExpr where+  pprintTidy k (ERBasic e)       = F.pprintTidy k e+  pprintTidy k (ERChecked e r)   = F.pprintTidy k e <+> "!=>" <+> F.pprintTidy k r+  pprintTidy k (ERUnChecked e r) = F.pprintTidy k e <+> ":=>" <+> F.pprintTidy k r+++ignoreOblig :: RType t t1 t2 -> RType t t1 t2+ignoreOblig (RRTy _ _ _ t) = t+ignoreOblig t              = t+++type SpecRTEnv   = RTEnv RTyVar SpecType+type BareRTEnv   = RTEnv Symbol BareType+type BareRTAlias = RTAlias Symbol BareType+type SpecRTAlias = RTAlias RTyVar SpecType+++class SubsTy tv ty a where+  subt :: (tv, ty) -> a -> a++-- [NOTE:LIFTED-VAR-SYMBOLS]: Following NOTE:REFLECT-IMPORTS, by default+-- each (lifted) `Var` is mapped to its `Symbol` via the `Symbolic Var`+-- instance. For _generated_ vars, we may want a custom name e.g. see+--   tests/pos/NatClass.hs+-- and we maintain that map in `lmVarSyms` with the `Just s` case.+-- Ideally, this bandaid should be replaced so we don't have these+-- hacky corner cases.++data LogicMap = LM+  { lmSymDefs  :: M.HashMap Symbol LMap        -- ^ Map from symbols to equations they define+  , lmVarSyms  :: M.HashMap Var (Maybe Symbol) -- ^ Map from (lifted) Vars to `Symbol`; see:+                                              --   NOTE:LIFTED-VAR-SYMBOLS and NOTE:REFLECT-IMPORTs+  } deriving (Show)++instance Monoid LogicMap where+  mempty  = LM M.empty M.empty+  mappend = (<>)++instance Semigroup LogicMap where+  LM x1 x2 <> LM y1 y2 = LM (M.union x1 y1) (M.union x2 y2)++data LMapV v = LMap+  { lmVar  :: F.LocSymbol+  , lmArgs :: [Symbol]+  , lmExpr :: F.ExprV v+  } deriving (Eq, Data, Generic, Functor)+    deriving (Binary, Hashable) via Generically (LMapV v)+type LMap = LMapV F.Symbol++instance (Show v, Ord v, F.Fixpoint v) => Show (LMapV v) where+  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t |-> \t" ++ show e++toLMapV :: (F.Located LHName, ([Symbol], F.ExprV v)) -> (F.Located LHName, LMapV v)+toLMapV (x, (ys, e)) = (x, LMap {lmVar = getLHNameSymbol <$> x, lmArgs = ys, lmExpr = e})++mkLogicMap :: M.HashMap Symbol LMap -> LogicMap+mkLogicMap ls = mempty {lmSymDefs = ls}++toLogicMap :: [(F.LocSymbol, ([Symbol], Expr))] -> LogicMap+toLogicMap = mkLogicMap . M.fromList . map toLMapV0+  where+  toLMapV0 :: (F.LocSymbol, ([Symbol], F.ExprV v)) -> (Symbol, LMapV v)+  toLMapV0 (x, (ys, e)) = (F.val x, LMap {lmVar = x, lmArgs = ys, lmExpr = e})++eAppWithMap :: LogicMap -> Symbol -> [Expr] -> Expr -> Expr+eAppWithMap lmap f es expr+  | Just (LMap _ xs e) <- M.lookup f (lmSymDefs lmap)+  , length xs == length es+  = F.subst (F.mkSubst $ zip xs es) e+  | otherwise+  = expr++emapLMapM :: Monad m => ([Symbol] -> v0 -> m v1) -> LMapV v0 -> m (LMapV v1)+emapLMapM f l = do+    lmExpr <- emapExprVM (f . (++ lmArgs l)) (lmExpr l)+    return l {lmExpr}++--------------------------------------------------------------------------------+-- | Refined Instances ---------------------------------------------------------+--------------------------------------------------------------------------------++data RInstance t = RI+  { riclass :: BTyCon+    -- | The name of the dictionary+    -- Provided when resolving names+  , riDictName :: Maybe (F.Located LHName)+  , ritype  :: [t]+  , risigs  :: [(F.Located LHName, RISig t)]+  } deriving (Eq, Generic, Functor, Data, Typeable, Foldable, Traversable, Show)+    deriving Hashable via Generically (RInstance t)+    deriving B.Binary via Generically (RInstance t)++data RISig t = RIAssumed t | RISig t+  deriving (Eq, Generic, Functor, Data, Typeable, Show, Foldable, Traversable)+  deriving Hashable via Generically (RISig t)+  deriving B.Binary via Generically (RISig t)++instance F.PPrint t => F.PPrint (RISig t) where+  pprintTidy k = ppRISig k (empty :: Doc)++ppRISig :: (F.PPrint k, F.PPrint t) => F.Tidy -> k -> RISig t -> Doc+ppRISig k x (RIAssumed t) = "assume" <+> F.pprintTidy k x <+> "::" <+> F.pprintTidy k t+ppRISig k x (RISig t)     =              F.pprintTidy k x <+> "::" <+> F.pprintTidy k t++instance F.PPrint t => F.PPrint (RInstance t) where+  pprintTidy k (RI n _ ts mts) = ppMethods k "instance" n ts mts++newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol (RISig ty)))+                    deriving (Semigroup, Monoid, Show, Functor)++type RDEnv = DEnv Var SpecType++data MethodType t = MT {tyInstance :: !(Maybe t), tyClass :: !(Maybe t) }+  deriving (Show)++getMethodType :: MethodType t -> Maybe t+getMethodType (MT (Just t) _ ) = Just t+getMethodType (MT _ t) = t++--------------------------------------------------------------------------+-- | Values Related to Specifications ------------------------------------+--------------------------------------------------------------------------++data Axiom b s e = Axiom+  { aname  :: (Var, Maybe DataCon)+  , rname  :: Maybe b+  , abinds :: [b]+  , atypes :: [s]+  , alhs   :: e+  , arhs   :: e+  }++type HAxiom = Axiom Var    Type CoreExpr++-- type AxiomEq = F.Equation++instance Show (Axiom Var Type CoreExpr) where+  show (Axiom (n, c) v bs _ts lhs rhs) = "Axiom : " +++                                         "\nFun Name: " ++ showPpr n +++                                         "\nReal Name: " ++ showPpr v +++                                         "\nData Con: " ++ showPpr c +++                                         "\nArguments:" ++ showPpr bs  +++                                         -- "\nTypes    :" ++ (showPpr ts)  +++                                         "\nLHS      :" ++ showPpr lhs +++                                         "\nRHS      :" ++ showPpr rhs++--------------------------------------------------------------------------------+-- | Refinement Type Aliases+--------------------------------------------------------------------------------+data RTAlias x a = RTA+  { rtName  :: Symbol             -- ^ name of the alias+  , rtTArgs :: [x]                -- ^ type parameters+  , rtVArgs :: [Symbol]           -- ^ value parameters+  , rtBody  :: a                  -- ^ what the alias expands to+  -- , rtMod   :: !ModName           -- ^ module where alias was defined+  } deriving (Eq, Data, Typeable, Generic, Functor, Foldable, Traversable)+    deriving Hashable via Generically (RTAlias x a)+    deriving B.Binary via Generically (RTAlias x a)+-- TODO support ghosts in aliases?++mapRTAVars :: (a -> b) -> RTAlias a ty -> RTAlias b ty+mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt }++lmapEAlias :: LMap -> F.Located (RTAlias Symbol Expr)+lmapEAlias (LMap v ys e) = F.atLoc v (RTA (F.val v) [] ys e) -- (F.loc v) (F.loc v)+++-- | The type used during constraint generation, used+--   also to define contexts for errors, hence in this+--   file, and NOT in elsewhere. **DO NOT ATTEMPT TO MOVE**+--   Am splitting into+--   + global : many bindings, shared across all constraints+--   + local  : few bindings, relevant to particular constraints++type REnv = AREnv SpecType++data AREnv t = REnv+  { reGlobal :: M.HashMap Symbol t -- ^ the "global" names for module+  , reLocal  :: M.HashMap Symbol t -- ^ the "local" names for sub-exprs+  }++instance Functor AREnv where+  fmap f (REnv g l) = REnv (fmap f g) (fmap f l)++instance (F.PPrint t) => F.PPrint (AREnv t) where+  pprintTidy k re =+    "RENV LOCAL"+    $+$+    ""+    $+$+    F.pprintTidy k (reLocal re)+    $+$+    ""+    $+$+    "RENV GLOBAL"+    $+$+    ""+    $+$+    F.pprintTidy k (reGlobal re)++instance Semigroup REnv where+  REnv g1 l1 <> REnv g2 l2 = REnv (g1 <> g2) (l1 <> l2)++instance Monoid REnv where+  mempty = REnv mempty mempty++instance NFData REnv where+  rnf REnv{} = ()++--------------------------------------------------------------------------------+-- | Diagnostic info -----------------------------------------------------------+--------------------------------------------------------------------------------++data Warning = Warning {+    warnSpan :: SrcSpan+  , warnDoc  :: Doc+  } deriving (Eq, Show)++mkWarning :: SrcSpan -> Doc -> Warning+mkWarning = Warning++data Diagnostics = Diagnostics {+    dWarnings :: [Warning]+  , dErrors   :: [Error]+  } deriving Eq++instance Semigroup Diagnostics where+  (Diagnostics w1 e1) <> (Diagnostics w2 e2) = Diagnostics (w1 <> w2) (e1 <> e2)++instance Monoid Diagnostics where+  mempty  = emptyDiagnostics+  mappend = (<>)++mkDiagnostics :: [Warning] -> [Error] -> Diagnostics+mkDiagnostics = Diagnostics++emptyDiagnostics :: Diagnostics+emptyDiagnostics = Diagnostics mempty mempty++noErrors :: Diagnostics -> Bool+noErrors = null . dErrors++allWarnings :: Diagnostics -> [Warning]+allWarnings = dWarnings++allErrors :: Diagnostics -> [Error]+allErrors = dErrors++--------------------------------------------------------------------------------+-- | Printing Warnings ---------------------------------------------------------+--------------------------------------------------------------------------------++printWarning :: Logger -> Warning -> IO ()+printWarning logger (Warning srcSpan doc) = GHC.putWarnMsg logger srcSpan doc++--------------------------------------------------------------------------------+-- | Error Data Type -----------------------------------------------------------+--------------------------------------------------------------------------------++type ErrorResult    = F.FixResult UserError+type Error          = TError SpecType+++instance NFData a => NFData (TError a)++--------------------------------------------------------------------------------+-- | Source Information Associated With Constraints ----------------------------+--------------------------------------------------------------------------------++data Cinfo    = Ci+  { ci_loc :: !SrcSpan+  , ci_err :: !(Maybe Error)+  , ci_var :: !(Maybe Var)+  }+  deriving (Eq, Generic)++instance F.Loc Cinfo where+  srcSpan = srcSpanFSrcSpan . ci_loc++instance NFData Cinfo++instance F.PPrint Cinfo where+  pprintTidy k = F.pprintTidy k . ci_loc++instance F.Fixpoint Cinfo where+  toFix = text . showPpr . ci_loc++instance Show Cinfo where+  show = show . F.toFix++--------------------------------------------------------------------------------+-- | Module Names --------------------------------------------------------------+--------------------------------------------------------------------------------++data ModName = ModName !ModType !ModuleName+  deriving (Eq, Ord, Show, Generic, Data, Typeable)++data ModType = Target | SrcImport | SpecImport+  deriving (Eq, Ord, Show, Generic, Data, Typeable)++-- instance B.Binary ModType+-- instance B.Binary ModName++instance Hashable ModType++instance Hashable ModName where+  hashWithSalt i (ModName t n) = hashWithSalt i (t, show n)++instance F.PPrint ModName where+  pprintTidy _ = text . show++instance F.Symbolic ModName where+  symbol (ModName _ m) = F.symbol m++instance F.Symbolic ModuleName where+  symbol = F.symbol . moduleNameFS+++isTarget :: ModName -> Bool+isTarget (ModName Target _) = True+isTarget _                  = False++isSrcImport :: ModName -> Bool+isSrcImport (ModName SrcImport _) = True+isSrcImport _                     = False++isSpecImport :: ModName -> Bool+isSpecImport (ModName SpecImport _) = True+isSpecImport _                      = False++getModName :: ModName -> ModuleName+getModName (ModName _ m) = m++getModString :: ModName -> String+getModString = moduleNameString . getModName++--------------------------------------------------------------------------------+-- | Refinement Type Aliases ---------------------------------------------------+--------------------------------------------------------------------------------+data RTEnv tv t = RTE+  { typeAliases :: M.HashMap Symbol (F.Located (RTAlias tv t))+  , exprAliases :: M.HashMap Symbol (F.Located (RTAlias Symbol Expr))+  }+++instance Monoid (RTEnv tv t) where+  mempty  = RTE M.empty M.empty+  mappend = (<>)++instance Semigroup (RTEnv tv t) where+  RTE x y <> RTE x' y' = RTE (x `M.union` x') (y `M.union` y')++-- mapRT :: (M.HashMap Symbol (RTAlias tv t) -> M.HashMap Symbol (RTAlias tv t))+--      -> RTEnv tv t -> RTEnv tv t+-- mapRT f e = e { typeAliases = f (typeAliases e) }++-- mapRE :: (M.HashMap Symbol (RTAlias Symbol Expr)+--       -> M.HashMap Symbol (RTAlias Symbol Expr))+--      -> RTEnv tv t -> RTEnv tv t+-- mapRE f e = e { exprAliases = f $ exprAliases e }+++--------------------------------------------------------------------------------+-- | Measures+--------------------------------------------------------------------------------+type Body = BodyV F.Symbol+data BodyV v+  = E (F.ExprV v)          -- ^ Measure Refinement: {v | v = e }+  | P (F.ExprV v)          -- ^ Measure Refinement: {v | (? v) <=> p }+  | R Symbol (F.ExprV v)   -- ^ Measure Refinement: {v | p}+  deriving (Show, Data, Typeable, Generic, Eq, Functor, Foldable, Traversable)+  deriving B.Binary via Generically (BodyV v)+  deriving Hashable via Generically (BodyV v)++emapBody+  :: Monad m+  => ([Symbol] -> v0 -> m v1)+  -> BodyV v0+  -> m (BodyV v1)+emapBody f b = case b of+    E e -> E <$> emapExprVM f e+    P e -> P <$> emapExprVM f e+    R s e -> R s <$> emapExprVM (f . (s:)) e++type Def ty ctor = DefV Symbol ty ctor+data DefV v ty ctor = Def+  { measure :: F.Located LHName+  , ctor    :: ctor+  , dsort   :: Maybe ty+  , binds   :: [(Symbol, Maybe ty)]    -- measure binders: the ADT argument fields+  , body    :: BodyV v+  } deriving (Show, Data, Typeable, Generic, Eq, Functor)+  deriving B.Binary via Generically (DefV v ty ctor)+  deriving Hashable via Generically (DefV v ty ctor)++emapDefM+  :: Monad m+  => ([Symbol] -> v0 -> m v1)+  -> ([Symbol] -> ty0 -> m ty1)+  -> DefV v0 ty0 ctor -> m (DefV v1 ty1 ctor)+emapDefM vf f d = do+    dsort <- traverse (f []) (dsort d)+    binds <- snd <$> mapAccumM (\e (s, t) -> (s:e,) . (s,) <$> traverse (f e) t) [] (binds d)+    body <- emapBody (vf . (++ map fst binds)) $ body d+    return d {dsort, binds, body}++mapDefTy :: (ty0 -> ty1) -> DefV v ty0 ctor -> DefV v ty1 ctor+mapDefTy f Def{..} =+    Def+      { dsort = fmap f dsort+      , binds = map (fmap (fmap f)) binds+      , ..+      }++mapDefV :: (v -> v') -> DefV v ty ctor -> DefV v' ty ctor+mapDefV f Def{..} =+    Def+      { body = fmap f body+      , ..+      }++type Measure ty ctor = MeasureV Symbol ty ctor+data MeasureV v ty ctor = M+  { msName :: F.Located LHName+  , msSort :: ty+  , msEqns :: [DefV v ty ctor]+  , msKind :: !MeasureKind+  , msUnSorted :: !UnSortedExprs -- potential unsorted expressions used at measure denifinitions+  } deriving (Eq, Data, Typeable, Generic, Functor)+  deriving B.Binary via Generically (MeasureV v ty ctor)+  deriving Hashable via Generically (MeasureV v ty ctor)++emapMeasureM+  :: Monad m+  => ([Symbol] -> v0 -> m v1)+  -> ([Symbol] -> ty0 -> m ty1)+  -> MeasureV v0 ty0 ctor+  -> m (MeasureV v1 ty1 ctor)+emapMeasureM vf f m = do+    msSort <- f [] (msSort m)+    msEqns <- mapM (emapDefM vf f) (msEqns m)+    return m{msSort, msEqns}++mapMeasureTy :: (ty0 -> ty1) -> MeasureV v ty0 ctor -> MeasureV v ty1 ctor+mapMeasureTy f M{..} =+    M+      { msSort = f msSort+      , msEqns = map (mapDefTy f) msEqns+      , ..+      }++mapMeasureV :: (v -> v') -> MeasureV v ty ctor -> MeasureV v' ty ctor+mapMeasureV f M{..} =+    M+      { msEqns = map (mapDefV f) msEqns+      , ..+      }++type UnSortedExprs = [UnSortedExpr] -- mempty = []+type UnSortedExpr  = ([F.Symbol], F.Expr)++data MeasureKind+  = MsReflect     -- ^ due to `reflect foo`, used for opaque reflection+  | MsMeasure     -- ^ due to `measure foo` with old-style (non-haskell) equations+  | MsLifted      -- ^ due to `measure foo` with new-style haskell equations+  | MsClass       -- ^ due to `class measure` definition+  | MsAbsMeasure  -- ^ due to `measure foo` without equations c.f. tests/pos/T1223.hs+  | MsSelector    -- ^ due to selector-fields e.g. `data Foo = Foo { fld :: Int }`+  | MsChecker     -- ^ due to checkers  e.g. `is-F` for `data Foo = F ... | G ...`+  deriving (Eq, Ord, Show, Data, Typeable, Generic)+  deriving B.Binary via Generically MeasureKind+  deriving Hashable via Generically MeasureKind++instance F.Loc (Measure a b) where+  srcSpan = F.srcSpan . msName++instance Bifunctor (DefV v) where+  -- first f  (Def m ps c s bs b) = Def m (second f <$> ps) c (f <$> s) ((second (fmap f)) <$> bs) b+  -- second f (Def m ps c s bs b) = Def m ps (f c) s bs b+  first f  (Def m c s bs b) = Def m c (f <$> s) (second (fmap f) <$> bs) b+  second f (Def m c s bs b) = Def m (f c) s bs b+++instance Bifunctor (MeasureV v) where+  first  f (M n s es k u) = M n (f s) (first f <$> es) k u+  second f (M n s es k u) = M n s (second f <$> es)    k u++-- NOTE: don't use the TH versions since they seem to cause issues+-- building on windows :(+-- deriveBifunctor ''Def+-- deriveBifunctor ''Measure++data CMeasure ty = CM+  { cName :: F.Located LHName+  , cSort :: ty+  } deriving (Data, Typeable, Generic, Functor)++instance (F.PPrint v, Ord v, F.Fixpoint v) => F.PPrint (BodyV v) where+  pprintTidy k (E e)   = F.pprintTidy k e+  pprintTidy k (P p)   = F.pprintTidy k p+  pprintTidy k (R v p) = braces (F.pprintTidy k v <+> "|" <+> F.pprintTidy k p)++instance (F.PPrint a, F.PPrint v, Ord v, F.Fixpoint v) => F.PPrint (DefV v t a) where+  pprintTidy k (Def m c _ bs body)+           = F.pprintTidy k m <+> cbsd <+> "=" <+> F.pprintTidy k body+    where+      cbsd = parens (F.pprintTidy k c <-> hsep (F.pprintTidy k `fmap` (fst <$> bs)))++instance (F.PPrint v, Ord v, F.Fixpoint v, F.PPrint t, F.PPrint a) => F.PPrint (MeasureV v t a) where+  pprintTidy k (M n s eqs _ _) =  F.pprintTidy k n <+> {- parens (pprintTidy k (loc n)) <+> -} "::" <+> F.pprintTidy k s+                                  $$ vcat (F.pprintTidy k `fmap` eqs)+++instance F.PPrint (MeasureV v t a) => Show (MeasureV v t a) where+  show = F.showpp++instance F.PPrint t => F.PPrint (CMeasure t) where+  pprintTidy k (CM n s) =  F.pprintTidy k n <+> "::" <+> F.pprintTidy k s++instance F.PPrint (CMeasure t) => Show (CMeasure t) where+  show = F.showpp+++instance F.Subable (Measure ty ctor) where+  syms  m     = concatMap F.syms (msEqns m)+  substa f m  = m { msEqns = F.substa f  <$> msEqns m }+  substf f m  = m { msEqns = F.substf f  <$> msEqns m }+  subst  su m = m { msEqns = F.subst  su <$> msEqns m }+  -- substa f  (M n s es _) = M n s (F.substa f  <$> es) k+  -- substf f  (M n s es _) = M n s $ F.substf f  <$> es+  -- subst  su (M n s es _) = M n s $ F.subst  su <$> es++instance F.Subable (Def ty ctor) where+  syms (Def _ _ _ sb bd)  = (fst <$> sb) ++ F.syms bd+  substa f  (Def m c t b bd) = Def m c t b $ F.substa f  bd+  substf f  (Def m c t b bd) = Def m c t b $ F.substf f  bd+  subst  su (Def m c t b bd) = Def m c t b $ F.subst  su bd++instance F.Subable Body where+  syms (E e)       = F.syms e+  syms (P e)       = F.syms e+  syms (R s e)     = s : F.syms e++  substa f (E e)   = E   (F.substa f e)+  substa f (P e)   = P   (F.substa f e)+  substa f (R s e) = R s (F.substa f e)++  substf f (E e)   = E   (F.substf f e)+  substf f (P e)   = P   (F.substf f e)+  substf f (R s e) = R s (F.substf f e)++  subst su (E e)   = E   (F.subst su e)+  subst su (P e)   = P   (F.subst su e)+  subst su (R s e) = R s (F.subst su e)++instance F.Subable t => F.Subable (WithModel t) where+  syms (NoModel t)     = F.syms t+  syms (WithModel _ t) = F.syms t+  substa f             = fmap (F.substa f)+  substf f             = fmap (F.substf f)+  subst su             = fmap (F.subst su)++data RClass ty = RClass+  { rcName    :: BTyCon+  , rcSupers  :: [ty]+  , rcTyVars  :: [BTyVar]+  , rcMethods :: [(F.Located LHName, ty)]+  } deriving (Eq, Show, Functor, Data, Typeable, Generic, Foldable, Traversable)+    deriving B.Binary via Generically (RClass ty)+    deriving Hashable via Generically (RClass ty)+++instance F.PPrint t => F.PPrint (RClass t) where+  pprintTidy k (RClass n ts as mts)+                = ppMethods k ("class" <+> supers ts) n as [(m, RISig t) | (m, t) <- mts]+    where+      supers [] = ""+      supers xs = tuplify (F.pprintTidy k   <$> xs) <+> "=>"+      tuplify   = parens . hcat . punctuate ", "+++ppMethods :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n)+          => F.Tidy -> Doc -> n -> [a] -> [(x, RISig t)] -> Doc+ppMethods k hdr name args mts+  = vcat $ hdr <+> dName <+> "where"+         : [ nest 4 (bind m t) | (m, t) <- mts ]+    where+      dName    = parens  (F.pprintTidy k name <+> dArgs)+      dArgs    = gaps    (F.pprintTidy k      <$> args)+      gaps     = hcat . punctuate " "+      bind m t = ppRISig k m t -- F.pprintTidy k m <+> "::" <+> F.pprintTidy k t++------------------------------------------------------------------------+-- | Var Hole Info -----------------------------------------------------+------------------------------------------------------------------------++data HoleInfo i t = HoleInfo {htype :: t, hloc :: SrcSpan, henv :: AREnv t, info :: i }++instance Functor (HoleInfo i) where+  fmap f hinfo = hinfo{htype = f (htype hinfo), henv = fmap f (henv hinfo)}++instance (F.PPrint t) => F.PPrint (HoleInfo  i t) where+  pprintTidy k hinfo = text "type:" <+> F.pprintTidy k (htype hinfo)+                       <+> text "\n loc:" <+> F.pprintTidy k (hloc hinfo)+  -- to print the hole environment uncomment the following+  --                     <+> text "\n env:" <+> F.pprintTidy k (henv hinfo)++------------------------------------------------------------------------+-- | Annotations -------------------------------------------------------+------------------------------------------------------------------------++newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)])+                    deriving (Data, Typeable, Generic, Functor)++data Annot t+  = AnnUse t+  | AnnDef t+  | AnnRDf t+  | AnnLoc SrcSpan+  deriving (Data, Typeable, Generic, Functor)++instance Monoid (AnnInfo a) where+  mempty  = AI M.empty+  mappend = (<>)++instance Semigroup (AnnInfo a) where+  AI m1 <> AI m2 = AI $ M.unionWith (++) m1 m2++instance NFData a => NFData (AnnInfo a)++instance NFData a => NFData (Annot a)++--------------------------------------------------------------------------------+-- | Output --------------------------------------------------------------------+--------------------------------------------------------------------------------++data Output a = O+  { o_vars   :: Maybe [String]+  , o_types  :: !(AnnInfo a)+  , o_templs :: !(AnnInfo a)+  , o_bots   :: ![SrcSpan]+  , o_result :: ErrorResult+  } deriving (Typeable, Generic, Functor)++instance (F.PPrint a) => F.PPrint (Output a) where+  pprintTidy _ out = F.resultDoc (F.pprint <$> o_result out)++emptyOutput :: Output a+emptyOutput = O Nothing mempty mempty [] mempty++instance Monoid (Output a) where+  mempty  = emptyOutput+  mappend = (<>)++instance Semigroup (Output a) where+  o1 <> o2 = O { o_vars   =            sortNub <$> mappend (o_vars   o1) (o_vars   o2)+               , o_types  =                        mappend (o_types  o1) (o_types  o2)+               , o_templs =                        mappend (o_templs o1) (o_templs o2)+               , o_bots   = sortNubBy ordSrcSpan $ mappend (o_bots o1)   (o_bots   o2)+               , o_result =                        mappend (o_result o1) (o_result o2)+               }++-- Ord a 'SrcSpan' if it's meaningful to do so (i.e. we have a 'RealSrcSpan'). Otherwise we default to EQ.+ordSrcSpan :: SrcSpan -> SrcSpan -> Ordering+ordSrcSpan (RealSrcSpan r1 _) (RealSrcSpan r2 _) = r1 `compare` r2+ordSrcSpan (RealSrcSpan _ _ ) _                  = GT+ordSrcSpan _                  (RealSrcSpan _ _ ) = LT+ordSrcSpan _                  _                  = EQ+++--------------------------------------------------------------------------------+-- | KVar Profile --------------------------------------------------------------+--------------------------------------------------------------------------------++data KVKind+  = RecBindE    Var -- ^ Recursive binder      @letrec x = ...@+  | NonRecBindE Var -- ^ Non recursive binder  @let x = ...@+  | TypeInstE+  | PredInstE+  | LamE+  | CaseE       Int -- ^ Int is the number of cases+  | LetE+  | ProjectE        -- ^ Projecting out field of+  deriving (Generic, Eq, Ord, Show, Data, Typeable)++instance Hashable KVKind++newtype KVProf = KVP (M.HashMap KVKind Int) deriving (Generic)++emptyKVProf :: KVProf+emptyKVProf = KVP M.empty++updKVProf :: KVKind -> F.Kuts -> KVProf -> KVProf+updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + n) m+  where+    kn                  = M.lookupDefault 0 k m+    n                   = S.size (F.ksVars kvs)++instance NFData KVKind++instance F.PPrint KVKind where+  pprintTidy _ = text . show++instance F.PPrint KVProf where+  pprintTidy k (KVP m) = F.pprintTidy k (M.toList m)++instance NFData KVProf++hole :: F.ExprV v+hole = F.PKVar "HOLE" (F.Su mempty)++isHole :: Expr -> Bool+isHole (F.PKVar "HOLE" _) = True+isHole _                  = False++hasHole :: Reftable r => r -> Bool+hasHole = any isHole . F.conjuncts . F.reftPred . toReft++instance F.Symbolic DataCon where+  symbol = F.symbol . dataConWorkId++instance Ord TyCon where+  compare = compare `on` F.symbol++instance Ord DataCon where+  compare = compare `on` F.symbol++instance F.PPrint TyThing where+  pprintTidy _ = text . showPpr++-- instance F.Symbolic TyThing where+--  symbol = tyThingSymbol++liquidBegin :: String+liquidBegin = ['{', '-', '@']++liquidEnd :: String+liquidEnd = ['@', '-', '}']++data MSpec ty ctor = MSpec+  { ctorMap  :: M.HashMap LHName [Def ty ctor]+  , measMap  :: M.HashMap (F.Located LHName) (Measure ty ctor)+  , cmeasMap :: M.HashMap (F.Located LHName) (Measure ty ())+  , imeas    :: ![Measure ty ctor]+  } deriving (Data, Typeable, Generic, Functor)++instance Bifunctor MSpec   where+  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c)+                                    (fmap (first f) m)+                                    (fmap (first f) cm)+                                    (fmap (first f) im)+  second                    = fmap++instance (F.PPrint t, F.PPrint a) => F.PPrint (MSpec t a) where+  pprintTidy k =  vcat . fmap (F.pprintTidy k . snd) . M.toList . measMap++instance (Show ty, Show ctor, F.PPrint ctor, F.PPrint ty) => Show (MSpec ty ctor) where+  show (MSpec ct m cm im)+    = "\nMSpec:\n" +++      "\nctorMap:\t "  ++ show ct +++      "\nmeasMap:\t "  ++ show m  +++      "\ncmeasMap:\t " ++ show cm +++      "\nimeas:\t "    ++ show im +++      "\n"++instance Eq ctor => Semigroup (MSpec ty ctor) where+  MSpec c1 m1 cm1 im1 <> MSpec c2 m2 cm2 im2+    | (k1, k2) : _ <- dups+      -- = panic Nothing $ err (head dups)+    = uError $ err k1 k2+    | otherwise+    = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2) (cm1 `M.union` cm2) (im1 ++ im2)+    where+      dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, F.val k1 == F.val k2, F.loc k1 /= F.loc k2]+      err k1 k2 = ErrDupMeas (fSrcSpan k1) (F.pprint (F.val k1)) (fSrcSpan <$> [k1, k2])+++instance Eq ctor => Monoid (MSpec ty ctor) where+  mempty = MSpec M.empty M.empty M.empty []+  mappend = (<>)
src/Language/Haskell/Liquid/Types/Variance.hs view
@@ -25,7 +25,7 @@ import qualified Language.Fixpoint.Types as F  import qualified Language.Haskell.Liquid.GHC.Misc as GM-import           Liquid.GHC.API        as Ghc hiding (text)+import           Liquid.GHC.API        as Ghc hiding (Binary, text)  type VarianceInfo = [Variance]
src/Language/Haskell/Liquid/Types/Visitors.hs view
@@ -19,7 +19,7 @@ import qualified Data.HashSet                     as S import           Prelude                          hiding (error) import           Language.Fixpoint.Misc-import           Liquid.GHC.API+import           Liquid.GHC.API                   hiding (exprFreeVars) import           Language.Haskell.Liquid.GHC.Misc ()
src/Language/Haskell/Liquid/UX/Annotate.hs view
@@ -67,8 +67,12 @@ import           Language.Haskell.Liquid.Types.PrettyPrint import           Language.Haskell.Liquid.Types.RefType +import           Language.Haskell.Liquid.UX.Config import           Language.Haskell.Liquid.UX.Tidy-import           Language.Haskell.Liquid.Types                hiding (Located(..), Def(..))+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types -- import           Language.Haskell.Liquid.Types.Specifications
src/Language/Haskell/Liquid/UX/CTags.hs view
@@ -31,7 +31,6 @@ import Liquid.GHC.API import Language.Haskell.Liquid.Types.Visitors (freeVars) import Language.Haskell.Liquid.Types.PrettyPrint ()-import Language.Fixpoint.Misc     (mapSnd)  -- | The @TagKey@ is the top-level binder, and @Tag@ is a singleton Int list @@ -66,7 +65,7 @@         index    = zipWith (\i -> map (, i) . G.flattenSCC) [1..]  makeCallGraph :: [CoreBind] -> CallGraph-makeCallGraph cbs = mapSnd calls `fmap` xes+makeCallGraph cbs = fmap calls `fmap` xes   where xes       = concatMap bindEqns cbs         xs        = S.fromList $ map fst xes         calls     = filter (`S.member` xs) . freeVars S.empty
src/Language/Haskell/Liquid/UX/CmdLine.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE TupleSections             #-} {-# LANGUAGE NamedFieldPuns            #-} {-# LANGUAGE ViewPatterns              #-}+{-# LANGUAGE LambdaCase                #-}  {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wwarn=deprecations #-}@@ -37,9 +38,6 @@    -- * Diff check mode    , diffcheck -   -- * Show info about this version of LiquidHaskell-   , printLiquidHaskellBanner- ) where  import Prelude hiding (error)@@ -57,8 +55,7 @@ import System.Exit import System.Environment import System.Console.CmdArgs.Explicit-import System.Console.CmdArgs.Implicit     hiding (Loud)-import qualified System.Console.CmdArgs.Verbosity as CmdArgs+import System.Console.CmdArgs.Implicit     hiding (Verbosity(..)) import System.Console.CmdArgs.Text import GitHash @@ -68,7 +65,7 @@ import System.FilePath                     (isAbsolute, takeDirectory, (</>))  import qualified Language.Fixpoint.Types.Config as FC-import Language.Fixpoint.Misc+import qualified Language.Fixpoint.Misc as F import Language.Fixpoint.Types.Names import Language.Fixpoint.Types             hiding (panic, Error, Result, saveQuery) import qualified Language.Fixpoint.Types as F@@ -77,8 +74,9 @@ import Language.Haskell.Liquid.UX.Config import Language.Haskell.Liquid.UX.SimpleVersion (simpleVersion) import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.Errors hiding (typ) import Language.Haskell.Liquid.Types.PrettyPrint ()-import Language.Haskell.Liquid.Types       hiding (typ)+import Language.Haskell.Liquid.Types.Types import qualified Language.Haskell.Liquid.UX.ACSS as ACSS  import qualified Liquid.GHC.API as GHC@@ -101,9 +99,10 @@ config :: Mode (CmdArgs Config) config = cmdArgsMode $ Config {   loggingVerbosity-    = enum [ Quiet        &= name "quiet"   &= help "Minimal logging verbosity"+    = enum [ Minimal      &= name "minimal" &= help "Minimal logging verbosity"+           , Quiet        &= name "quiet"   &= help "Silent logging verbosity"            , Normal       &= name "normal"  &= help "Normal logging verbosity"-           , CmdArgs.Loud &= name "verbose" &= help "Verbose logging"+           , Loud         &= name "verbose" &= help "Verbose logging"            ]   , files@@ -289,21 +288,11 @@     = def &= help "Expect an error, no matter which kind or what it contains"           &= name "expect-any-error" - , scrapeImports-    = False &= help "Scrape qualifiers from imported specifications"-            &= name "scrape-imports"-            &= explicit-  , scrapeInternals     = False &= help "Scrape qualifiers from auto generated specifications"             &= name "scrape-internals"             &= explicit - , scrapeUsedImports-    = False &= help "Scrape qualifiers from used, imported specifications"-            &= name "scrape-used-imports"-            &= explicit-  , elimStats     = False &= name "elimStats"             &= help "Print eliminate stats"@@ -383,6 +372,16 @@         &= help "Enable Proof-by-Logical-Evaluation locally, per function"         &= name "ple-local" +  , etabeta+    = def+        &= help "Eta expand and beta reduce terms to aid PLE"+        &= name "etabeta"+  +  , dependantCase+    = def+        &= help "Allow PLE to reason about dependent cases"+        &= name "dependant-case"+   , extensionality     = def         &= help "Enable extensional interpretation of function equality"@@ -467,6 +466,18 @@       &= name "exclude-automatic-assumptions-for"       &= help "Stop loading LHAssumptions modules for imports in these packages."       &= typ "PACKAGE"+  , dumpOpaqueReflections+    = def &= help "Dump all generated opaque reflections"+          &= name "dump-opaque-reflections"+          &= explicit+  , dumpPreNormalizedCore+    = def &= help "Dump pre-normalized core (before a-normalization)"+          &= name "dump-pre-normalized-core"+          &= explicit+  , allowUnsafeConstructors+    = def &= help "Allow refining constructors with unsafe refinements"+          &= name "allow-unsafe-constructors"+          &= explicit   } &= program "liquid"     &= help    "Refinement Types for Haskell"     &= summary copyright@@ -488,15 +499,10 @@                                                 }                                 }                          as-  cfg    <- fixConfig cfg1-  setVerbosity (loggingVerbosity cfg)-  when (json cfg) $ setVerbosity Quiet-  withSmtSolver cfg---- | Shows the LiquidHaskell banner, that includes things like the copyright, the--- git commit and the version.-printLiquidHaskellBanner :: IO ()-printLiquidHaskellBanner = whenNormal $ putStrLn copyright+  cfg2   <- fixConfig cfg1+  let cfg3 = if json cfg2 then cfg2 {loggingVerbosity = Quiet} else cfg2+  setVerbosity (cmdargsVerbosity $ loggingVerbosity cfg3)+  withSmtSolver cfg3  cmdArgsRun' :: Mode (CmdArgs a) -> [String] -> IO a cmdArgsRun' md as@@ -527,7 +533,9 @@     missingSmtError smt = "Could not find SMT solver '" ++ show smt ++ "'. Is it on your PATH?"  findSmtSolver :: FC.SMTSolver -> IO (Maybe FC.SMTSolver)-findSmtSolver smt = maybe Nothing (const $ Just smt) <$> findExecutable (show smt)+findSmtSolver = \case+    FC.Z3mem -> return $ Just FC.Z3mem+    smt      -> maybe Nothing (const $ Just smt) <$> findExecutable (show smt)  fixConfig :: Config -> IO Config fixConfig config' = do@@ -607,7 +615,7 @@  mkOpts :: Config -> IO Config mkOpts cfg = do-  let files' = sortNub $ files cfg+  let files' = F.sortNub $ files cfg   return     $ cfg { files       = files'                                    -- See NOTE [searchpath]                    }@@ -627,9 +635,9 @@ withPragmas cfg fp ps action   = do cfg' <- liftIO $ (processPragmas cfg ps >>= canonicalizePaths fp) <&> canonConfig        -- As the verbosity is set /globally/ via the cmdargs lib, re-set it.-       liftIO $ setVerbosity (loggingVerbosity cfg')+       liftIO $ setVerbosity (cmdargsVerbosity $ loggingVerbosity cfg')        res <- action cfg'-       liftIO $ setVerbosity (loggingVerbosity cfg) -- restore the original verbosity.+       liftIO $ setVerbosity (cmdargsVerbosity $ loggingVerbosity cfg) -- restore the original verbosity.        pure res  processPragmas :: Config -> [Located String] -> IO Config@@ -649,7 +657,7 @@  defConfig :: Config defConfig = Config-  { loggingVerbosity         = Quiet+  { loggingVerbosity         = Minimal   , files                    = def   , idirs                    = def   , fullcheck                = def@@ -695,8 +703,6 @@   , cFiles                   = def   , port                     = defaultPort   , scrapeInternals          = False-  , scrapeImports            = False-  , scrapeUsedImports        = False   , elimStats                = False   , elimBound                = Nothing   , json                     = False@@ -714,6 +720,8 @@   , oldPLE                   = False   , interpreter              = False   , proofLogicEvalLocal      = False+  , etabeta                  = False+  , dependantCase            = False   , reflection               = False   , extensionality           = False   , nopolyinfer              = False@@ -730,6 +738,9 @@   , inlineANFBindings        = False   , pandocHtml               = False   , excludeAutomaticAssumptionsFor = []+  , dumpOpaqueReflections    = False+  , dumpPreNormalizedCore    = False+  , allowUnsafeConstructors  = False   }  -- | Write the annotations (i.e. the files in the \".liquid\" hidden folder) and@@ -743,7 +754,7 @@              -> m () reportResult logResultFull cfg targets out = do   annm <- {-# SCC "annotate" #-} liftIO $ annotate cfg targets out-  liftIO $ whenNormal $ donePhase Loud "annotate"+  liftIO $ when (loggingVerbosity cfg >= Normal) $ F.donePhase F.Loud "annotate"   if json cfg then     liftIO $ reportResultJson annm    else do@@ -753,14 +764,15 @@          let outputResult = resDocs tidy cr          -- For now, always print the \"header\" with colours, irrespective to the logger          -- passed as input.-         liftIO $ printHeader (colorResult r) (orHeader outputResult)+         when (loggingVerbosity cfg >= Minimal) $+             liftIO $ printHeader (colorResult r) (orHeader outputResult)          logResultFull outputResult   where     tidy :: F.Tidy     tidy = if shortErrors cfg then F.Lossy else F.Full -    printHeader :: Moods -> Doc -> IO ()-    printHeader mood d = colorPhaseLn mood "" (render d)+    printHeader :: F.Moods -> Doc -> IO ()+    printHeader mood d = F.colorPhaseLn mood "" (render d)   reportResultJson :: ACSS.AnnMap -> IO ()@@ -784,8 +796,8 @@  writeCheckVars :: Symbolic a => Maybe [a] -> IO () writeCheckVars Nothing    = return ()-writeCheckVars (Just [])   = colorPhaseLn Loud "Checked Binders: None" ""-writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" ""+writeCheckVars (Just [])   = F.colorPhaseLn F.Loud "Checked Binders: None" ""+writeCheckVars (Just ns)   = F.colorPhaseLn F.Loud "Checked Binders:" ""                           >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)  type CError = CtxError Doc
src/Language/Haskell/Liquid/UX/Config.hs view
@@ -6,7 +6,9 @@ module Language.Haskell.Liquid.UX.Config (      Config (..)    , HasConfig (..)+   , Verbosity (..)    , allowPLE, allowLocalPLE, allowGlobalPLE+   , cmdargsVerbosity    , patternFlag    , higherOrderFlag    , pruneFlag@@ -21,11 +23,23 @@ import Prelude hiding (error) import Language.Fixpoint.Types.Config hiding (Config) import GHC.Generics-import System.Console.CmdArgs+import System.Console.CmdArgs hiding (Verbosity(..))+import qualified System.Console.CmdArgs as CmdArgs +data Verbosity = Quiet | Minimal | Normal | Loud+  deriving (Data, Generic, Show, Eq, Ord)++-- | liquid-fixpoint uses CmdArg.Verbosity at least to show the progress bar.+cmdargsVerbosity :: Verbosity -> CmdArgs.Verbosity+cmdargsVerbosity Quiet   = CmdArgs.Quiet+cmdargsVerbosity Minimal = CmdArgs.Quiet+cmdargsVerbosity Normal  = CmdArgs.Normal+cmdargsVerbosity Loud    = CmdArgs.Loud++ -- NOTE: adding strictness annotations breaks the help message data Config = Config-  { loggingVerbosity         :: Verbosity  -- ^ the logging verbosity to use (defaults to 'Quiet')+  { loggingVerbosity         :: Verbosity  -- ^ the logging verbosity to use (defaults to 'Minimal')   , files                    :: [FilePath] -- ^ source files to check   , idirs                    :: [FilePath] -- ^ path to directory for including specs   , diffcheck                :: Bool       -- ^ check subset of binders modified (+ dependencies) since last check@@ -72,9 +86,7 @@   , noADT                    :: Bool       -- ^ Disable ADTs (only used with exactDC)   , expectErrorContaining    :: [String]   -- ^ expect failure from Liquid with at least one of the following messages   , expectAnyError           :: Bool       -- ^ expect failure from Liquid with any message-  , scrapeImports            :: Bool       -- ^ scrape qualifiers from imported specifications   , scrapeInternals          :: Bool       -- ^ scrape qualifiers from auto specifications-  , scrapeUsedImports        :: Bool       -- ^ scrape qualifiers from used, imported specifications   , elimStats                :: Bool       -- ^ print eliminate stats   , elimBound                :: Maybe Int  -- ^ eliminate upto given depth of KVar chains   , json                     :: Bool       -- ^ print results (safe/errors) as JSON@@ -91,6 +103,8 @@   , oldPLE                   :: Bool       -- ^ Enable proof-by-logical-evaluation   , interpreter              :: Bool       -- ^ Use an interpreter to assist PLE   , proofLogicEvalLocal      :: Bool       -- ^ Enable proof-by-logical-evaluation locally, per function+  , etabeta                  :: Bool       -- ^ Eta expand and beta reduce terms to aid PLE+  , dependantCase            :: Bool       -- ^ Enable PLE for dependent cases   , extensionality           :: Bool       -- ^ Enable extensional interpretation of function equality   , nopolyinfer              :: Bool       -- ^ No inference of polymorphic type application.   , reflection               :: Bool       -- ^ Allow "reflection"; switches on "--higherorder" and "--exactdc"@@ -108,6 +122,9 @@                                            -- Sometimes improves performance and sometimes worsens it.   , pandocHtml               :: Bool       -- ^ Use pandoc to generate html   , excludeAutomaticAssumptionsFor :: [String]+  , dumpOpaqueReflections    :: Bool       -- Dumps all opaque reflections to the stdout+  , dumpPreNormalizedCore    :: Bool       -- Dumps the prenormalized core (before a-normalization)+  , allowUnsafeConstructors  :: Bool       -- ^ Allow refining constructors with unsafe refinements   } deriving (Generic, Data, Typeable, Show, Eq)  allowPLE :: Config -> Bool
src/Language/Haskell/Liquid/UX/DiffCheck.hs view
@@ -60,7 +60,11 @@ import qualified Data.ByteString                        as B import qualified Data.ByteString.Lazy                   as LB -import           Language.Haskell.Liquid.Types          hiding (Def, LMap)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.Specs+import           Language.Haskell.Liquid.Types.Types hiding (Def, LMap)+import           Language.Haskell.Liquid.Types.Visitors  -------------------------------------------------------------------------------- -- | Data Types ----------------------------------------------------------------
src/Language/Haskell/Liquid/UX/Errors.hs view
@@ -9,19 +9,24 @@ module Language.Haskell.Liquid.UX.Errors ( tidyError ) where  import           Control.Arrow                       (second)+import           Data.Either                         (partitionEithers) import qualified Data.HashMap.Strict                 as M import qualified Data.HashSet                        as S import qualified Data.List                           as L import           Data.Hashable import           Data.Maybe                          (maybeToList) import qualified Language.Fixpoint.Types             as F+import qualified Language.Fixpoint.Solver.EnvironmentReduction as F import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Transforms.Simplify+import           Language.Haskell.Liquid.UX.Config import           Language.Haskell.Liquid.UX.Tidy-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp+import           Language.Haskell.Liquid.Types.Types import qualified Language.Haskell.Liquid.GHC.Misc    as GM import qualified Language.Haskell.Liquid.Misc        as Misc-import qualified Language.Fixpoint.Misc              as Misc  -- import Debug.Trace @@ -92,7 +97,7 @@ tidyREnv xts    = (θ, second (F.subst θ) <$> zts)   where     θ           = expandVarDefs yes-    (yes, zts)  = Misc.mapEither isInline xts+    (yes, zts)  = partitionEithers $ map isInline xts  -- | 'expandVarDefs [(x1, e1), ... ,(xn, en)] returns a `Subst` that   --   contains the fully substituted definitions for each `xi`. For example, @@ -114,14 +119,20 @@     isDef xs e     = not (any (`S.member` xs) (F.syms e))  isInline :: (a, SpecType) -> Either (a, F.Expr) (a, SpecType)-isInline (x, t) = either (Left . (x,)) (Right . (x,)) (isInline' t)+isInline (x, t) =+    either (Left . (x,)) (Right . (x,)) (isInline' t')+  where+    -- tidyInternalRefas could drop some conjuncts which affects whether+    -- bindings are eliminated in isInline'+    t' = tidyInternalRefas t  isInline' :: SpecType -> Either F.Expr SpecType isInline' t = case ro of                 Nothing -> Right t'                 Just rr -> case F.isSingletonReft (ur_reft rr) of-                             Just e  -> Left e-                             Nothing -> Right (strengthen t' rr)+                  Just e -- Treat as singleton only if there aren't other conjucts+                    | [_] <- F.conjuncts (F.reftPred (ur_reft rr)) -> Left e+                  _ -> Right (strengthen t' rr)               where                   (t', ro) = stripRType t @@ -137,11 +148,16 @@     ro        = stripRTypeBase  t     t         = simplifyBounds st +-- | @sliceREnv xs m@ collects all bindings needed by @xs@.+-- A symbol needs a binding, if the binding binds the symbol, or it contains the+-- symbol, or it contains symbols used by bindings that are needed by the+-- symbol. sliceREnv :: [F.Symbol] -> Ctx -> [(F.Symbol, SpecType)]-sliceREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]+sliceREnv xs m =+    [(x, t) | x <- relatedSyms, Just t <- [M.lookup x m], ok t]   where-    xs'       = expandFix deps xs-    deps y    = maybe [] (F.syms . rTypeReft) (M.lookup y m)+    directlyUses = M.map (F.exprSymbolsSet . F.reftPred . rTypeReft) m+    relatedSyms = L.sort $ S.toList $ F.relatedSymbols (S.fromList xs) directlyUses     ok        = not . isFunTy  tidyREnvM      :: [F.Symbol] -> CtxM -> [(F.Symbol, WithModel SpecType)]
src/Language/Haskell/Liquid/UX/QuasiQuoter.hs view
@@ -12,7 +12,7 @@  --     -- * QuasiQuoter Annotations --   , LiquidQuote(..)---   ) +--   )   where  import Data.Data@@ -23,13 +23,20 @@ import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote -import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan)+import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan, panic) import qualified Language.Fixpoint.Types as F  import Language.Haskell.Liquid.GHC.Misc (fSrcSpan) import Liquid.GHC.API  (SrcSpan)+import qualified Liquid.GHC.API as GHC+import qualified GHC.Types.Name.Occurrence import Language.Haskell.Liquid.Parse-import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.Names+import Language.Haskell.Liquid.Types.RType+import Language.Haskell.Liquid.Types.RTypeOp+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Types.Types  import System.IO import Text.Megaparsec.Error@@ -77,16 +84,13 @@  mkSpecDecs :: BPspec -> Either UserError [Dec] mkSpecDecs (Asrt (name, ty)) =-  return . SigD (symbolName name)-    <$> simplifyBareType name (quantifyFreeRTy $ val ty)-mkSpecDecs (LAsrt (name, ty)) =-  return . SigD (symbolName name)-    <$> simplifyBareType name (quantifyFreeRTy $ val ty)+  return . SigD (lhNameToName name)+    <$> simplifyBareType id name (quantifyFreeRTy $ parsedToBareType $ val ty) mkSpecDecs (Asrts (names, (ty, _))) =-  (\t -> (`SigD` t) . symbolName <$> names)-    <$> simplifyBareType (head names) (quantifyFreeRTy $ val ty)+  (\t -> (`SigD` t) . lhNameToName <$> names)+    <$> simplifyBareType id (head names) (quantifyFreeRTy $ parsedToBareType $ val ty) mkSpecDecs (Alias rta) =-  return . TySynD name tvs <$> simplifyBareType lsym (rtBody (val rta))+  return . TySynD name tvs <$> simplifyBareType parsedToBareType lsym (rtBody (val rta))   where     lsym = F.atLoc rta n     name = symbolName n@@ -100,23 +104,51 @@ symbolName :: Symbolic s => s -> Name symbolName = mkName . symbolString . symbol +lhNameToName :: Located LHName -> Name+lhNameToName lname = case val lname of+    LHNUnresolved _ s -> symbolName s+    LHNResolved rn _ -> case rn of+      LHRGHC n -> case GHC.nameModule_maybe n of+        Nothing -> mkName (GHC.getOccString n)+        Just m ->+          mkNameG+            (toTHNameSpace $ GHC.nameNameSpace n)+            (GHC.unitString $ GHC.moduleUnit m)+            (GHC.moduleNameString $ GHC.moduleName m)+            (GHC.getOccString n)+      LHRLocal s -> symbolName s+      LHRIndex i -> panic (Just $ fSrcSpan lname) $ "Cannot produce a TH Name for a LHRIndex " ++ show i+      LHRLogic _ ->+        panic (Just $ fSrcSpan lname) $ "Cannot produce a TH Name for a LogicName: " ++ show (lhNameToResolvedSymbol $ val lname)++  where+    toTHNameSpace :: GHC.NameSpace -> NameSpace+    toTHNameSpace ns+      | ns == GHC.dataName = DataName+      | ns == GHC.tcName = TcClsName+      | ns == GHC.Types.Name.Occurrence.varName = VarName+      | GHC.isFieldNameSpace ns = panic (Just $ fSrcSpan lname) "lhNameToName: Unimplemented case for FieldName NameSpace"+      | otherwise = panic (Just $ fSrcSpan lname) "lhNameToName: Unknown GHC.NameSpace"++ -- BareType to TH Type --------------------------------------------------------- -simplifyBareType :: LocSymbol -> BareType -> Either UserError Type-simplifyBareType s t = case simplifyBareType' t of+simplifyBareType+  :: PPrint a => (BareTypeV v -> BareType) -> Located a -> BareTypeV v -> Either UserError Type+simplifyBareType toBareType s t = case simplifyBareType' t of   Simplified t' ->     Right t'   FoundExprArg l ->-    Left $ ErrTySpec l Nothing (pprint $ val s) (pprint t)+    Left $ ErrTySpec l Nothing (pprint $ val s) (pprint $ toBareType t)       "Found expression argument in bad location in type"   FoundHole ->-    Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint t)+    Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint $ toBareType t)       "Can't write LiquidHaskell type with hole in a quasiquoter" -simplifyBareType' :: BareType -> Simpl Type+simplifyBareType' :: BareTypeV v -> Simpl Type simplifyBareType' = simplifyBareType'' ([], []) -simplifyBareType'' :: ([BTyVar], [BareType]) -> BareType -> Simpl Type+simplifyBareType'' :: ([BTyVar], [BareTypeV v]) -> BareTypeV v -> Simpl Type  simplifyBareType'' ([], []) (RVar v _) =   return $ VarT $ symbolName v@@ -126,11 +158,10 @@   (\x y -> ArrowT `AppT` x `AppT` y)     <$> simplifyBareType' i <*> simplifyBareType' o simplifyBareType'' ([], []) (RApp cc as _ _) =-  let c  = btc_tc cc-      c' | isFun   c = ArrowT-         | isTuple c = TupleT (length as)-         | isList  c = ListT-         | otherwise = ConT $ symbolName c+  let c' | isFun   cc = ArrowT+         | isTuple cc = TupleT (length as)+         | isList  cc = ListT+         | otherwise = ConT $ lhNameToName (btc_tc cc)   in  foldl' AppT c' <$> sequenceA (filterExprArgs $ simplifyBareType' <$> as)  simplifyBareType'' _ (RExprArg e) =
src/Language/Haskell/Liquid/UX/Tidy.hs view
@@ -14,6 +14,7 @@      -- * Tidying functions     tidySpecType+  , tidyInternalRefas   , tidySymbol      -- * Panic and Exit@@ -39,6 +40,9 @@ import qualified Language.Haskell.Liquid.GHC.Misc          as GM -- (dropModuleNames, showPpr, stringTyVar) import           Language.Fixpoint.Types                   hiding (Result, SrcSpan, Error)+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.RType+import           Language.Haskell.Liquid.Types.RTypeOp import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.RefType     (rVar, subsTyVarsMeet, FreeVar) import           Language.Haskell.Liquid.Types.PrettyPrint@@ -124,6 +128,8 @@     txReft u                      = u { ur_reft = mapPredReft dropInternals $ ur_reft u }     dropInternals                 = pAnd . L.nub . conjuncts +-- | Drop conjuncts that contain data constructor testing or+-- selector functions. tidyInternalRefas   :: SpecType -> SpecType tidyInternalRefas = mapReft txReft   where@@ -237,6 +243,7 @@              . tidySpecType k              . fmap (everywhere (mkT noCasts))   where+    noCasts :: Expr -> Expr     noCasts (ECst x _) = x     noCasts e          = e
src/Language/Haskell/Liquid/WiredIn.hs view
@@ -32,15 +32,21 @@ import Language.Haskell.Liquid.GHC.Misc import qualified Liquid.GHC.API as Ghc import Liquid.GHC.API (Var, Arity, TyVar, Bind(..), Boxity(..), Expr(..), ForAllTyFlag(Required))+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.Names+import Language.Haskell.Liquid.Types.RType import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Types.Variance import Language.Haskell.Liquid.Types.PredType-import Language.Haskell.Liquid.Types.Names (selfSymbol)  -- import Language.Fixpoint.Types hiding (panic)+import qualified Language.Fixpoint.Types.Config as F+import qualified Language.Fixpoint.Smt.Theories as F import qualified Language.Fixpoint.Types as F+import           Data.Bifunctor (first) import qualified Data.HashSet as S+import           Data.Maybe  import Language.Haskell.Liquid.GHC.TypeRep () @@ -75,8 +81,49 @@ dcPrefix = "lqdc"  wiredSortedSyms :: [(F.Symbol, F.Sort)]-wiredSortedSyms = (selfSymbol,selfSort):[(pappSym n, pappSort n) | n <- [1..pappArity]]-  where selfSort = F.FAbs 1 (F.FVar 0)+wiredSortedSyms =+    (selfSymbol,selfSort) :+    [(pappSym n, pappSort n) | n <- [1..pappArity]] +++    wiredTheorySortedSyms+  where+    selfSort = F.FAbs 1 (F.FVar 0)++wiredTheorySortedSyms :: [(F.Symbol, F.Sort)]+wiredTheorySortedSyms =+    [ (s, srt)+    | s <- wiredTheorySyms+    , let srt = F.tsSort $+                  fromMaybe (panic Nothing ("unknown symbol: " ++ show s)) $+                    F.lookupSEnv s (F.theorySymbols F.Z3 [])+    ]+  where+    wiredTheorySyms =+      [ "Map_default"+      , "Map_select"+      , "Map_store"++      , "Set_cup"+      , "Set_cap"+      , "Set_dif"+      , "Set_sng"+      , "Set_emp"+      , "Set_empty"+      , "Set_mem"+      , "Set_sub"+      , "Set_add"+      , "Set_com"++      , "Bag_count"+      , "Bag_empty"+      , "Bag_inter_min"+      , "Bag_sng"+      , "Bag_sub"+      , "Bag_union"+      , "Bag_union_max"++      , "strLen"+      ]+ -------------------------------------------------------------------------------- -- | LH Primitive TyCons ------------------------------------------------------- --------------------------------------------------------------------------------@@ -123,7 +170,7 @@     (tcs, dcs)  = unzip $ listTyDataCons : map tupleTyDataCons [2..maxArity]  charDataCon :: Located DataConP-charDataCon = dummyLoc (DataConP l0 Ghc.charDataCon  [] [] [] [("charX",lt)] lt False wiredInName l0)+charDataCon = dummyLoc (DataConP l0 Ghc.charDataCon  [] [] [] [(makeGeneratedLogicLHName "charX",lt)] lt False wiredInName l0)   where     l0 = F.dummyPos "LH.Bare.charTyDataCons"     c  = Ghc.charTyCon@@ -141,13 +188,13 @@       fld        = "fldList"       xHead      = "head"       xTail      = "tail"-      p          = PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar fld)]-      px         = pdVarReft $ PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar xHead)]+      p          = PV "p" t (F.vv Nothing) [(t, fld, F.EVar fld)]+      px         = pdVarReft $ PV "p" t (F.vv Nothing) [(t, fld, F.EVar xHead)]       lt         = rApp c [xt] [rPropP [] $ pdVarReft p] mempty       xt         = rVar tyv       xst        = rApp c [RVar (RTV tyv) px] [rPropP [] $ pdVarReft p] mempty-      cargs      = [(xTail, xst), (xHead, xt)]-      fsize      = SymSizeFun (dummyLoc "len")+      cargs      = map (first makeGeneratedLogicLHName) [(xTail, xst), (xHead, xt)]+      fsize      = SymSizeFun (dummyLoc "GHC.Types_LHAssumptions.len")  wiredInName :: F.Symbol wiredInName = "WiredIn"@@ -171,7 +218,7 @@     pxs           = mkps pnames (ta:ts) ((fld, F.EVar x1) : zip flds (F.EVar <$> xs))     lt            = rApp c (rVar <$> tyvs) (rPropP [] . pdVarReft <$> ups) mempty     xts           = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs-    cargs         = reverse $ (x1, rVar tv) : zip xs xts+    cargs         = map (first makeGeneratedLogicLHName) $ reverse $ (x1, rVar tv) : zip xs xts     pnames        = mks_ "p"     mks  x        = (\i -> F.symbol (x++ show i)) <$> [1..n]     mks_ x        = (\i -> F.symbol (x++ show i)) <$> [2..n]@@ -191,7 +238,7 @@ mkps_ []     _       _          _    ps = ps mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps)   where-    p                                   = PV n (PVProp t) (F.vv Nothing) args+    p                                   = PV n t (F.vv Nothing) args     a                                   = (t, f, x) mkps_ _     _       _          _    _ = panic Nothing "Bare : mkps_"
tests/Parser.hs view
@@ -13,7 +13,7 @@  module Main where -import           Control.Monad (filterM, unless)+import           Control.Monad (unless) import           Data.Data import           Data.Char (isSpace) import           Data.Generics.Aliases@@ -23,9 +23,6 @@ import qualified Language.Haskell.Liquid.Parse as LH import qualified Language.Fixpoint.Types       as F -import           System.Directory-import           System.FilePath- import           Text.Megaparsec.Error import           Text.Megaparsec.Pos @@ -37,46 +34,18 @@  -- | Test suite entry point, returns exit failure if any test fails. main :: IO ()--- main = do---   print $ parseSingleSpec "type IncrListD a D = [a]<{\\x y -> (x+D) <= y}>"---   return () main = do-  testSpecFiles' <- testSpecFiles-  defaultMainWithIngredients (antXMLRunner:defaultIngredients) (tests testSpecFiles')+  defaultMainWithIngredients (antXMLRunner:defaultIngredients) tests -tests :: TestTree -> TestTree-tests extra =+tests :: TestTree+tests =   testGroup "ParserTests"-    ([ testSucceeds+    [ testSucceeds     , testSpecP     , testReservedAliases     , testFails     , testErrorReporting-    ] ++ [ extra ])---- ------------------------------------------------------------------------- | Test parsing of entire spec files.------ These are included in the normal parser tests, because they call the--- parser directly, rather than via an external invocation of the executable--- or the plugin.----testSpecFiles :: IO TestTree-testSpecFiles =-  testGroup "spec files" <$> do-    rawFiles <- listDirectory dir-    files <- filterM (doesFileExist . (dir </>)) (filter ((== ".spec") . takeExtension) rawFiles)-    pure ((\ f -> testCase f (go f)) <$> files)-  where-    dir = "tests/specfiles/pos"-    go :: FilePath -> Assertion-    go f = do-      txt <- readFile (dir </> f)-      let r = LH.specSpecificationP f txt-      case r of-        Left peb -> assertFailure (errorBundlePretty peb)-        Right _ -> pure ()+    ]  -- Test that the top level production works, each of the sub-elements will be tested separately testSpecP :: TestTree@@ -94,10 +63,6 @@        parseSingleSpec "autosize List" @?==             "autosize List" -    , testCase "local" $-       parseSingleSpec "local foo :: Nat -> Nat" @?==-            "local assert foo :: lq_tmp$db##0:Nat -> Nat"-     , testCase "axiomatize" $        parseSingleSpec "axiomatize fibA" @?==             "reflect fibA"@@ -114,10 +79,6 @@        parseSingleSpec "measure fv :: Expr -> (Set Bndr)" @?==           "measure fv :: lq_tmp$db##0:Expr -> (Set Bndr)" -    , testCase "define" $-       parseSingleSpec "define $ceq = eqN" @?==-          "define $ceq = eqN"-     , testCase "infixl" $        parseSingleSpec "infixl 9 +++" @?==             "fixity"@@ -138,10 +99,6 @@        parseSingleSpec "bound Foo = true" @?==           "bound Foo forall [] . [] =  true" -    , testCase "bound HBound" $-       parseSingleSpec "bound step" @?==-            "bound step"-     , testCase "class measure" $        parseSingleSpec "class measure sz :: forall a. a -> Int" @?==             "class measure sz :: forall a . lq_tmp$db##0:a -> Int"@@ -158,10 +115,6 @@        parseSingleSpec "class Sized s where\n  size :: forall a. x:s a -> {v:Nat | v = sz x}" @?==             "class  (Sized s) where\n    size :: forall a . x:s a -> {v : Nat | v == sz x}" -    , testCase "import" $-       parseSingleSpec "import Foo" @?==-          "import Foo"-     , testCase "data variance" $        parseSingleSpec "data variance IO bivariant" @?==           "data variance IO Bivariant"@@ -174,10 +127,6 @@        parseSingleSpec "newtype Foo = Bar {x :: Nat}" @?==           "newtype data Foo  [] =\n            | Bar :: forall . x : Nat -> *" -    , testCase "include" $-       parseSingleSpec "include <listSet.hquals>" @?==-            "include <listSet.hquals>"-     , testCase "invariant" $        parseSingleSpec "invariant {v:Tree a | 0 <= ht v}" @?==             "invariant {v : (Tree a) | 0 <= ht v}"@@ -253,10 +202,6 @@        parseSingleSpec "define :: Int -> Bool " @?==             "define :: lq_tmp$db##0:Int -> Bool" -    , testCase "define 2" $-       parseSingleSpec "define GHC.Types.True = (true)" @?==-            "define GHC.Types.True = (true)"-     , testCase "defined" $        parseSingleSpec "defined :: Int -> Bool " @?==             "defined :: lq_tmp$db##0:Int -> Bool"@@ -523,7 +468,7 @@          , "  fst (a,b) = a"          ])         @?==-            "measure fst :: lq_tmp$db##0:(a, b) -> a\n        fst ((,)a b) = a"+            "measure fst :: lq_tmp$db##0:(a, b) -> a\n        fst (GHC.Tuple.(,)a b) = a"     ]  -- ---------------------------------------------------------------------
− tests/specfiles/pos/Empty.spec 
@@ -1,1 +0,0 @@-module spec Empty where
− tests/specfiles/pos/T707.spec 
@@ -1,17 +0,0 @@-module spec T707 where--uncons-    :: i : Data.ByteString.ByteString-    -> Maybe (Data.Word.Word8, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 })--unsnoc-    :: i : Data.ByteString.ByteString-    -> Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, Data.Word.Word8)--uncons'-    :: i : Data.ByteString.ByteString-    -> (Maybe (Data.Word.Word8, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 }))--unsnoc'-    :: i : Data.ByteString.ByteString-    -> (Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, Data.Word.Word8))
− tests/specfiles/pos/T788.spec 
@@ -1,26 +0,0 @@-module spec T788 where--import GHC.Base--measure mvlen     :: Data.Vector.MVector s a -> Int--invariant         {v:Data.Vector.MVector s a | 0 <= mvlen v }--assume length     :: forall a. x:(Data.Vector.MVector s a) -> {v : Nat | v = mvlen x }--assume unsafeRead :: Control.Monad.Primitive.PrimMonad m-                  => x:(Data.Vector.MVector (Control.Monad.Primitive.PrimState m) a)-                  -> ix:{v:Nat | v < mvlen x }-		  -> m a--assume unsafeWrite :: Control.Monad.Primitive.PrimMonad m-                   => x:(Data.Vector.MVector (Control.Monad.Primitive.PrimState m) a)-                   -> ix:{v:Nat | v < mvlen x }-		   -> a-		   -> m ()--assume unsafeSwap :: Control.Monad.Primitive.PrimMonad m-                  => x:(Data.Vector.MVector (Control.Monad.Primitive.PrimState m) a)-                  -> i:{v:Nat | v < mvlen x }-                  -> j:{v:Nat | v < mvlen x }-		  -> m ()
− tests/specfiles/pos/T924.spec 
@@ -1,381 +0,0 @@-module spec T924 where--measure bslen :: Data.ByteString.ByteString -> { n : Int | 0 <= n }--invariant { bs : Data.ByteString.ByteString  | 0 <= bslen bs }--empty :: { bs : Data.ByteString.ByteString | bslen bs == 0 }--singleton-    :: Data.Word.Word8 -> { bs : Data.ByteString.ByteString | bslen bs == 1 }--pack-    :: w8s : [Data.Word.Word8]-    -> { bs : Data.ByteString.ByteString | bslen bs == len w8s }--unpack-    :: bs : Data.ByteString.ByteString-    -> { w8s : [Data.Word.Word8] | len w8s == bslen bs }--cons-    :: Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }--snoc-    :: i : Data.ByteString.ByteString-    -> Data.Word.Word8-    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }--append-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen l + bslen r }--head :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8--unsnoc-    :: i : Data.ByteString.ByteString-    -> Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, Data.Word.Word8)--last :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8--tail :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8--init :: {i:Data.ByteString.ByteString | 1 <= bslen i } -     -> {o:Data.ByteString.ByteString | bslen o == bslen i - 1 }--null-    :: bs : Data.ByteString.ByteString-    -> { b : Bool | b <=> bslen bs == 0 }--length :: bs : Data.ByteString.ByteString -> { n : Int | bslen bs == n }--map-    :: (Data.Word.Word8 -> Data.Word.Word8)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--reverse-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--intersperse-    :: Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (bslen i == 0 <=> bslen o == 0) && (1 <= bslen i <=> bslen o == 2 * bslen i - 1) }--intercalate-    :: l : Data.ByteString.ByteString-    -> rs : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | len rs == 0 ==> bslen o == 0 }--transpose-    :: is : [Data.ByteString.ByteString]-    -> { os : [{ bs : Data.ByteString.ByteString | bslen bs <= len is }] | len is == 0 ==> len os == 0}--foldl1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8--foldl1'-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8--foldr1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8--foldr1'-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8--concat-    :: is : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | len is == 0 ==> bslen o }--concatMap-    :: (Data.Word.Word8 -> Data.ByteString.ByteString)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 }--any :: (Data.Word.Word8 -> Bool)-    -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen bs == 0 ==> not b }--all :: (Data.Word.Word8 -> Bool)-    -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen bs == 0 ==> b }--maximum-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8--minimum-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8--scanl-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--scanl1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--scanr-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--scanr1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--mapAccumL-    :: (acc -> Data.Word.Word8 -> (acc, Data.Word.Word8))-    -> acc-    -> i : Data.ByteString.ByteString-    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })--mapAccumR-    :: (acc -> Data.Word.Word8 -> (acc, Data.Word.Word8))-    -> acc-    -> i : Data.ByteString.ByteString-    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })--replicate-    :: n : Int-    -> Data.Word.Word8-    -> { bs : Data.ByteString.ByteString | bslen bs == n }--unfoldrN-    :: n : Int-    -> (a -> Maybe (Data.Word.Word8, a))-    -> a-    -> ({ bs : Data.ByteString.ByteString | bslen bs <= n }, Maybe a)--take-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == 0) &&-                                          ((0 <= n && n <= bslen i) <=> bslen o == n) &&-                                          (bslen i <= n <=> bslen o = bslen i) }--drop-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == bslen i) &&-                                          ((0 <= n && n <= bslen i) <=> bslen o == bslen i - n) &&-                                          (bslen i <= n <=> bslen o == 0) }--splitAt-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | (n <= 0 <=> bslen l == 0) &&-                                            ((0 <= n && n <= bslen i) <=> bslen l == n) &&-                                            (bslen i <= n <=> bslen l == bslen i) }-       , { r : Data.ByteString.ByteString | (n <= 0 <=> bslen r == bslen i) &&-                                            ((0 <= n && n <= bslen i) <=> bslen r == bslen i - n) &&-                                            (bslen i <= n <=> bslen r == 0) }-       )--takeWhile-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--dropWhile-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--span-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--spanEnd-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--break-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--breakEnd-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--group-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]--groupBy-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]--inits-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--tails-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--split-    :: Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--splitWith-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--isPrefixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l >= bslen r ==> not b }--isSuffixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l > bslen r ==> not b }--isInfixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l > bslen r ==> not b }--breakSubstring-    :: il : Data.ByteString.ByteString-    -> ir : Data.ByteString.ByteString-    -> ( { ol : Data.ByteString.ByteString | bslen ol <= bslen ir && (bslen il > bslen ir ==> bslen ol == bslen ir)}-       , { or : Data.ByteString.ByteString | bslen or <= bslen ir && (bslen il > bslen ir ==> bslen or == 0) }-       )--elem-    :: Data.Word.Word8-    -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen b == 0 ==> not b }--notElem-    :: Data.Word.Word8-    -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen b == 0 ==> b }--find-    :: (Data.Word.Word8 -> Bool)-    -> bs : Data.ByteString.ByteString-    -> Maybe { w8 : Data.Word.Word8 | bslen bs /= 0 }--filter-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--partition-    :: (Data.Word.Word8 -> Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--index-    :: bs : Data.ByteString.ByteString-    -> { n : Int | 0 <= n && n < bslen bs }-    -> Data.Word.Word8--elemIndex-    :: Data.Word.Word8-    -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }--elemIndices-    :: Data.Word.Word8-    -> bs : Data.ByteString.ByteString-    -> [{ n : Int | 0 <= n && n < bslen bs }]--elemIndexEnd-    :: Data.Word.Word8-    -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }--findIndex-    :: (Data.Word.Word8 -> Bool)-    -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }--findIndices-    :: (Data.Word.Word8 -> Bool)-    -> bs : Data.ByteString.ByteString-    -> [{ n : Int | 0 <= n && n < bslen bs }]--count-    :: Data.Word.Word8-    -> bs : Data.ByteString.ByteString-    -> { n : Int | 0 <= n && n < bslen bs }--zip-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : [(Data.Word.Word8, Data.Word.Word8)] | len o <= bslen l && len o <= bslen r }--zipWith-    :: (Data.Word.Word8 -> Data.Word.Word8 -> a)-    -> l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : [a] | len o <= bslen l && len o <= bslen r }--unzip-    :: i : [(Data.Word.Word8, Data.Word.Word8)]-    -> ( { l : Data.ByteString.ByteString | bslen l == len i }-       , { r : Data.ByteString.ByteString | bslen r == len i }-       )--sort-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--copy-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--hGet-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs == n || bslen bs == 0 }--hGetSome-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs <= n }--hGetNonBlocking-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs <= n }--uncons-    :: i : Data.ByteString.ByteString-    -> Maybe (Data.Word.Word8, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 })