liquidhaskell-boot (empty) → 0.9.2.5.0
raw patch · 93 files changed
+35690/−0 lines, 93 filesdep +Cabaldep +Diffdep +aeson
Dependencies added: Cabal, Diff, aeson, base, binary, bytestring, cereal, cmdargs, containers, data-default, data-fix, deepseq, directory, exceptions, extra, filepath, fingertree, free, ghc, ghc-boot, ghc-paths, ghc-prim, githash, gitrev, hashable, hscolour, liquid-fixpoint, liquidhaskell-boot, megaparsec, mtl, optparse-applicative, pretty, recursion-schemes, split, syb, tasty, tasty-ant-xml, tasty-hunit, template-haskell, temporary, text, th-compat, time, transformers, unordered-containers, vector
Files
- ghc-api-tests/GhcApiTests.hs +146/−0
- include/CoreToLogic.lg +49/−0
- liquidhaskell-boot.cabal +207/−0
- src-ghc/Liquid/GHC/API.hs +699/−0
- src-ghc/Liquid/GHC/API/Extra.hs +273/−0
- src-ghc/Liquid/GHC/API/StableModule.hs +78/−0
- src/Language/Haskell/Liquid/Bare.hs +1325/−0
- src/Language/Haskell/Liquid/Bare/Axiom.hs +266/−0
- src/Language/Haskell/Liquid/Bare/Check.hs +758/−0
- src/Language/Haskell/Liquid/Bare/Class.hs +280/−0
- src/Language/Haskell/Liquid/Bare/DataType.hs +819/−0
- src/Language/Haskell/Liquid/Bare/Elaborate.hs +717/−0
- src/Language/Haskell/Liquid/Bare/Expand.hs +842/−0
- src/Language/Haskell/Liquid/Bare/Laws.hs +54/−0
- src/Language/Haskell/Liquid/Bare/Measure.hs +502/−0
- src/Language/Haskell/Liquid/Bare/Misc.hs +211/−0
- src/Language/Haskell/Liquid/Bare/Plugged.hs +309/−0
- src/Language/Haskell/Liquid/Bare/Resolve.hs +1052/−0
- src/Language/Haskell/Liquid/Bare/Slice.hs +174/−0
- src/Language/Haskell/Liquid/Bare/ToBare.hs +89/−0
- src/Language/Haskell/Liquid/Bare/Typeclass.hs +427/−0
- src/Language/Haskell/Liquid/Bare/Types.hs +160/−0
- src/Language/Haskell/Liquid/Cabal.hs +21/−0
- src/Language/Haskell/Liquid/Constraint/Constraint.hs +60/−0
- src/Language/Haskell/Liquid/Constraint/Env.hs +288/−0
- src/Language/Haskell/Liquid/Constraint/Fresh.hs +154/−0
- src/Language/Haskell/Liquid/Constraint/Generate.hs +1143/−0
- src/Language/Haskell/Liquid/Constraint/Init.hs +303/−0
- src/Language/Haskell/Liquid/Constraint/Monad.hs +125/−0
- src/Language/Haskell/Liquid/Constraint/Qualifier.hs +241/−0
- src/Language/Haskell/Liquid/Constraint/Relational.hs +787/−0
- src/Language/Haskell/Liquid/Constraint/Split.hs +451/−0
- src/Language/Haskell/Liquid/Constraint/Template.hs +109/−0
- src/Language/Haskell/Liquid/Constraint/Termination.hs +233/−0
- src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +318/−0
- src/Language/Haskell/Liquid/Constraint/Types.hs +469/−0
- src/Language/Haskell/Liquid/GHC/Interface.hs +423/−0
- src/Language/Haskell/Liquid/GHC/Logging.hs +49/−0
- src/Language/Haskell/Liquid/GHC/Misc.hs +1072/−0
- src/Language/Haskell/Liquid/GHC/Play.hs +256/−0
- src/Language/Haskell/Liquid/GHC/Plugin.hs +607/−0
- src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs +180/−0
- src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs +233/−0
- src/Language/Haskell/Liquid/GHC/Plugin/Types.hs +140/−0
- src/Language/Haskell/Liquid/GHC/Plugin/Util.hs +77/−0
- src/Language/Haskell/Liquid/GHC/Resugar.hs +162/−0
- src/Language/Haskell/Liquid/GHC/SpanStack.hs +80/−0
- src/Language/Haskell/Liquid/GHC/TypeRep.hs +164/−0
- src/Language/Haskell/Liquid/GHC/Types.hs +82/−0
- src/Language/Haskell/Liquid/LawInstances.hs +101/−0
- src/Language/Haskell/Liquid/Liquid.hs +197/−0
- src/Language/Haskell/Liquid/Measure.hs +249/−0
- src/Language/Haskell/Liquid/Misc.hs +432/−0
- src/Language/Haskell/Liquid/Parse.hs +1742/−0
- src/Language/Haskell/Liquid/Termination/Structural.hs +350/−0
- src/Language/Haskell/Liquid/Transforms/ANF.hs +419/−0
- src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs +661/−0
- src/Language/Haskell/Liquid/Transforms/InlineAux.hs +102/−0
- src/Language/Haskell/Liquid/Transforms/Rec.hs +291/−0
- src/Language/Haskell/Liquid/Transforms/RefSplit.hs +114/−0
- src/Language/Haskell/Liquid/Transforms/Rewrite.hs +504/−0
- src/Language/Haskell/Liquid/Transforms/Simplify.hs +43/−0
- src/Language/Haskell/Liquid/Types.hs +17/−0
- src/Language/Haskell/Liquid/Types/Bounds.hs +162/−0
- src/Language/Haskell/Liquid/Types/Dictionaries.hs +95/−0
- src/Language/Haskell/Liquid/Types/Equality.hs +81/−0
- src/Language/Haskell/Liquid/Types/Errors.hs +1089/−0
- src/Language/Haskell/Liquid/Types/Fresh.hs +277/−0
- src/Language/Haskell/Liquid/Types/Generics.hs +62/−0
- src/Language/Haskell/Liquid/Types/Literals.hs +49/−0
- src/Language/Haskell/Liquid/Types/Meet.hs +36/−0
- src/Language/Haskell/Liquid/Types/Names.hs +20/−0
- src/Language/Haskell/Liquid/Types/PredType.hs +568/−0
- src/Language/Haskell/Liquid/Types/PrettyPrint.hs +560/−0
- src/Language/Haskell/Liquid/Types/RefType.hs +1933/−0
- src/Language/Haskell/Liquid/Types/Specs.hs +873/−0
- src/Language/Haskell/Liquid/Types/Types.hs +2515/−0
- src/Language/Haskell/Liquid/Types/Variance.hs +122/−0
- src/Language/Haskell/Liquid/Types/Visitors.hs +195/−0
- src/Language/Haskell/Liquid/UX/ACSS.hs +299/−0
- src/Language/Haskell/Liquid/UX/Annotate.hs +526/−0
- src/Language/Haskell/Liquid/UX/CTags.hs +76/−0
- src/Language/Haskell/Liquid/UX/CmdLine.hs +869/−0
- src/Language/Haskell/Liquid/UX/Config.hs +165/−0
- src/Language/Haskell/Liquid/UX/DiffCheck.hs +618/−0
- src/Language/Haskell/Liquid/UX/Errors.hs +177/−0
- src/Language/Haskell/Liquid/UX/QuasiQuoter.hs +209/−0
- src/Language/Haskell/Liquid/UX/SimpleVersion.hs +31/−0
- src/Language/Haskell/Liquid/UX/Tidy.hs +247/−0
- src/Language/Haskell/Liquid/WiredIn.hs +221/−0
- src/LiquidHaskellBoot.hs +9/−0
- syntax/liquid.css +105/−0
- tests/Parser.hs +615/−0
+ ghc-api-tests/GhcApiTests.hs view
@@ -0,0 +1,146 @@++import Control.Monad+import Data.List (find)+import Data.Time (getCurrentTime)+import Liquid.GHC.API+ ( ApiComment(ApiBlockComment)+ , Expr(..)+ , Alt(..)+ , AltCon(..)+ , apiCommentsParsedSource+ , occNameString+ , pAT_ERROR_ID+ , showPprQualified+ )+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Runners.AntXML++import qualified GHC as GHC+import qualified GHC.Core as GHC+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.Data.FastString as GHC+import qualified GHC.Data.StringBuffer as GHC+import qualified GHC.Parser as Parser+import qualified GHC.Parser.Lexer as GHC+import qualified GHC.Types.Name.Occurrence as GHC+import qualified GHC.Types.SrcLoc as GHC+import qualified GHC.Unit.Module.ModGuts as GHC++import GHC.Paths (libdir)+++main :: IO ()+main =+ defaultMainWithIngredients (antXMLRunner:defaultIngredients) testTree++testTree :: TestTree+testTree =+ testGroup "GHC API"+ [ testCase "apiComments" testApiComments+ , testCase "caseDesugaring" testCaseDesugaring+ ]++-- Tests that Liquid.GHC.API.Extra.apiComments can retrieve the comments in+-- the right order from an AST+testApiComments :: IO ()+testApiComments = do+ let str = unlines+ [ "{-@ LIQUID \"--ple\" @-}"+ , "module A where"+ , "import B"+ , ""+ , "{-@ i :: { v:Int | v>=0 } @-}"+ , "i :: Int"+ , "i = 4"+ , ""+ , "{-@ infixr ++ @-}"+ , ""+ , "{-@ abs :: Int -> { v:Int | v >= 0 } @-}"+ , "abs :: Int -> Int"+ , "abs x = z"+ , " where"+ , " {-@ { v: Int | z >= 0 } @-}"+ , " z = if x < 0 then -x else x"+ ]+ lhsMod <- parseMod str "A.hs"+ let comments = map GHC.unLoc (apiCommentsParsedSource lhsMod)+ expected = map ApiBlockComment+ [ "{-@ LIQUID \"--ple\" @-}"+ , "{-@ i :: { v:Int | v>=0 } @-}"+ , "{-@ infixr ++ @-}"+ , "{-@ abs :: Int -> { v:Int | v >= 0 } @-}"+ , "{-@ { v: Int | z >= 0 } @-}"+ ]+ when (expected /= comments) $+ fail $ unlines $ "Unexpected comments:" : map show comments+ where+ parseMod str filepath = do+ let location = GHC.mkRealSrcLoc (GHC.mkFastString filepath) 1 1+ buffer = GHC.stringToStringBuffer str+ popts = GHC.mkParserOpts EnumSet.empty EnumSet.empty False True True True+ parseState = GHC.initParserState popts buffer location+ case GHC.unP Parser.parseModule parseState of+ GHC.POk _ result -> return result+ _ -> fail "Unexpected parser error"+++-- | Tests that case expressions desugar as Liquid Haskell expects.+testCaseDesugaring :: IO ()+testCaseDesugaring = do+ let inputSource = unlines+ [ "module CaseDesugaring where"+ , "f :: Bool -> ()"+ , "f x = case x of"+ , " True -> ()"+ ]++ fBind (GHC.NonRec b _e) =+ occNameString (GHC.occName b) == "f"+ fBind _ = False++ -- Expected desugaring:+ --+ -- CaseDesugaring.f+ -- = \ (x :: GHC.Types.Bool) ->+ -- case x of {+ -- __DEFAULT ->+ -- case Control.Exception.Base.patError ...+ -- of {+ -- };+ -- GHC.Types.True -> GHC.Tuple.()+ -- }+ --+ isExpectedDesugaring p = case find fBind p of+ Just (GHC.NonRec _ e0)+ | Lam x (Case (Var x') _ _ [alt0, _alt1]) <- e0+ , x == x'+ , Alt DEFAULT [] e1 <- alt0+ , Case e2 _ _ [] <- e1+ , (Var e3,_) <- GHC.collectArgs e2+ -> e3 == pAT_ERROR_ID+ _ -> False++ coreProgram <- compileToCore inputSource+ unless (isExpectedDesugaring coreProgram) $+ fail $ unlines $+ "Unexpected desugaring:" : map showPprQualified coreProgram+ where+ compileToCore inputSource = do+ now <- getCurrentTime+ GHC.runGhc (Just libdir) $ do+ df1 <- GHC.getSessionDynFlags+ GHC.setSessionDynFlags df1+ let target = GHC.Target {+ GHC.targetId = GHC.TargetFile "CaseDesugaring.hs" Nothing+ , GHC.targetAllowObjCode = False+ , GHC.targetContents = Just (GHC.stringToStringBuffer inputSource, now)+ }+ GHC.setTargets [target]+ void $ GHC.load GHC.LoadAllTargets++ dsMod <- GHC.getModSummary (GHC.mkModuleName "CaseDesugaring")+ >>= GHC.parseModule+ >>= GHC.typecheckModule+ >>= GHC.desugarModule+ return $ GHC.mg_binds $ GHC.dm_core_module dsMod
+ include/CoreToLogic.lg view
@@ -0,0 +1,49 @@+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.Real.fromIntegral x = (x)++define GHC.Types.True = (true)+define GHC.Real.div x y = (x / y)+define GHC.Real.mod x y = (x mod y)+define GHC.Classes.not x = (~ x)+define GHC.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
+ liquidhaskell-boot.cabal view
@@ -0,0 +1,207 @@+cabal-version: 2.4+name: liquidhaskell-boot+version: 0.9.2.5.0+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)+ instead, which rexports this plugin together with necessary+ specifications for definitions in the boot libraries.+license: BSD-3-Clause+copyright: 2010-19 Ranjit Jhala & Niki Vazou & Eric L. Seidel, University of California, San Diego.+author: Ranjit Jhala, Niki Vazou, Eric Seidel+maintainer: Ranjit Jhala <jhala@cs.ucsd.edu>+category: Language+homepage: https://github.com/ucsd-progsys/liquidhaskell+build-type: Simple+tested-with: GHC == 9.2.5++data-files: include/CoreToLogic.lg+ syntax/liquid.css++source-repository head+ type: git+ location: https://github.com/ucsd-progsys/liquidhaskell/++flag devel+ default: False+ manual: True+ description: Enable more warnings and fail compilation when warnings occur.+ Turn this flag on in CI.++library+ autogen-modules: Paths_liquidhaskell_boot+ exposed-modules: Language.Haskell.Liquid.Cabal+ Language.Haskell.Liquid.Bare+ Language.Haskell.Liquid.Bare.Axiom+ Language.Haskell.Liquid.Bare.Check+ 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.Constraint.Constraint+ Language.Haskell.Liquid.Constraint.Env+ Language.Haskell.Liquid.Constraint.Fresh+ Language.Haskell.Liquid.Constraint.Generate+ Language.Haskell.Liquid.Constraint.Init+ Language.Haskell.Liquid.Constraint.Monad+ Language.Haskell.Liquid.Constraint.Qualifier+ Language.Haskell.Liquid.Constraint.Split+ Language.Haskell.Liquid.Constraint.ToFixpoint+ Language.Haskell.Liquid.Constraint.Template+ Language.Haskell.Liquid.Constraint.Termination+ Language.Haskell.Liquid.Constraint.Types+ Language.Haskell.Liquid.Constraint.Relational+ Liquid.GHC.API+ Liquid.GHC.API.Extra+ Liquid.GHC.API.StableModule+ Language.Haskell.Liquid.GHC.Interface+ Language.Haskell.Liquid.GHC.Logging+ Language.Haskell.Liquid.GHC.Misc+ Language.Haskell.Liquid.GHC.Play+ Language.Haskell.Liquid.GHC.Resugar+ Language.Haskell.Liquid.GHC.SpanStack+ Language.Haskell.Liquid.GHC.Types+ Language.Haskell.Liquid.GHC.TypeRep+ Language.Haskell.Liquid.GHC.Plugin+ Language.Haskell.Liquid.GHC.Plugin.Tutorial+ Language.Haskell.Liquid.LawInstances+ Language.Haskell.Liquid.Liquid+ Language.Haskell.Liquid.Measure+ Language.Haskell.Liquid.Misc+ 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.Dictionaries+ Language.Haskell.Liquid.Types.Equality+ Language.Haskell.Liquid.Types.Errors+ Language.Haskell.Liquid.Types.Fresh+ Language.Haskell.Liquid.Types.Generics+ Language.Haskell.Liquid.Types.Literals+ Language.Haskell.Liquid.Types.Meet+ Language.Haskell.Liquid.Types.Names+ Language.Haskell.Liquid.Types.PredType+ Language.Haskell.Liquid.Types.PrettyPrint+ Language.Haskell.Liquid.Types.RefType+ Language.Haskell.Liquid.Types.Specs+ Language.Haskell.Liquid.Types.Types+ Language.Haskell.Liquid.Types.Variance+ Language.Haskell.Liquid.Types.Visitors+ Language.Haskell.Liquid.UX.ACSS+ Language.Haskell.Liquid.UX.Annotate+ Language.Haskell.Liquid.UX.CTags+ Language.Haskell.Liquid.UX.CmdLine+ Language.Haskell.Liquid.UX.Config+ Language.Haskell.Liquid.UX.DiffCheck+ Language.Haskell.Liquid.UX.Errors+ Language.Haskell.Liquid.UX.QuasiQuoter+ Language.Haskell.Liquid.UX.SimpleVersion+ Language.Haskell.Liquid.UX.Tidy+ Language.Haskell.Liquid.WiredIn+ LiquidHaskellBoot+ Paths_liquidhaskell_boot+ other-modules: Language.Haskell.Liquid.GHC.Plugin.SpecFinder+ Language.Haskell.Liquid.GHC.Plugin.Types+ Language.Haskell.Liquid.GHC.Plugin.Util+ hs-source-dirs: src src-ghc++ build-depends: base >= 4.11.1.0 && < 5+ , Diff >= 0.3 && < 0.5+ , aeson+ , binary+ , bytestring >= 0.10+ , Cabal < 3.7+ , cereal+ , cmdargs >= 0.10+ , containers >= 0.5+ , data-default >= 0.5+ , deepseq >= 1.3+ , directory >= 1.2+ , filepath >= 1.3+ , fingertree >= 0.1+ , exceptions < 0.11+ , ghc ^>= 9.2+ , ghc-boot+ , ghc-paths >= 0.1+ , ghc-prim+ , gitrev+ , hashable >= 1.3 && < 1.5+ , hscolour >= 1.22+ , liquid-fixpoint == 0.9.2.5+ , mtl >= 2.1+ , optparse-applicative < 0.18+ , githash+ , megaparsec >= 8+ , pretty >= 1.1+ , split+ , syb >= 0.4.4+ , template-haskell >= 2.9+ , th-compat < 0.2+ , temporary >= 1.2+ , text >= 1.2+ , time >= 1.4+ , transformers >= 0.3+ , unordered-containers >= 0.2.11+ , vector >= 0.10+ , free+ , recursion-schemes < 5.3+ , data-fix+ , extra+ default-language: Haskell98+ default-extensions: PatternGuards, RecordWildCards, DoAndIfThenElse+ ghc-options: -W -fwarn-missing-signatures++ if flag(devel)+ ghc-options: -Wall -Werror++test-suite ghc-api-tests+ type: exitcode-stdio-1.0+ main-is: GhcApiTests.hs+ hs-source-dirs: ghc-api-tests+ build-depends: base+ , ghc+ , ghc-paths+ , liquidhaskell-boot+ , tasty+ , tasty-ant-xml+ , tasty-hunit+ , time+ default-language: Haskell2010+ ghc-options: -W++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+ , filepath+ , liquid-fixpoint+ , liquidhaskell-boot+ , megaparsec+ , syb+ , tasty >= 0.10+ , tasty-ant-xml+ , tasty-hunit >= 0.9+ default-language: Haskell2010+ ghc-options: -W++ if flag(devel)+ ghc-options: -Wall -Wno-name-shadowing -Werror
+ src-ghc/Liquid/GHC/API.hs view
@@ -0,0 +1,699 @@+{-| This module re-exports all identifiers that LH needs+ from the GHC API.++The intended use of this module is to provide a quick look of what+GHC API features LH depends upon.++The transitive dependencies of this module shouldn't contain modules+from Language.Haskell.Liquid.* or other non-boot libraries. This makes+it easy to discover breaking changes in the GHC API.++-}++{-# LANGUAGE PatternSynonyms #-}++module Liquid.GHC.API (+ module Ghc+ ) where++import Liquid.GHC.API.Extra as Ghc++import GHC as Ghc+ ( Backend(Interpreter)+ , Class+ , DataCon+ , DesugaredModule(DesugaredModule, dm_typechecked_module, dm_core_module)+ , DynFlags(backend, debugLevel, ghcLink, ghcMode)+ , FixityDirection(InfixN, InfixR)+ , FixitySig(FixitySig)+ , GenLocated(L)+ , GeneralFlag+ ( Opt_DeferTypedHoles+ , Opt_Haddock+ , Opt_ImplicitImportQualified+ , Opt_KeepRawTokenStream+ , Opt_PIC+ )+ , Ghc+ , GhcException(CmdLineError, ProgramError)+ , GhcLink(LinkInMemory)+ , GhcMode(CompManager)+ , GhcPs+ , GhcRn+ , HsDecl(SigD)+ , HsExpr(ExprWithTySig, HsOverLit, HsVar)+ , HsModule(hsmodDecls)+ , HsOuterTyVarBndrs(HsOuterImplicit)+ , HsSigType(HsSig)+ , HsTyVarBndr(UserTyVar)+ , HsType(HsAppTy, HsForAllTy, HsQualTy, HsTyVar, HsWildCardTy)+ , HsArg(HsValArg)+ , HsWildCardBndrs(HsWC)+ , Id+ , IdP+ , Kind+ , LHsDecl+ , LHsExpr+ , LHsType+ , LImportDecl+ , LexicalFixity(Prefix)+ , Located+ , LocatedN+ , Logger+ , ModIface_(mi_anns, mi_exports, mi_globals, mi_module)+ , ModLocation(ml_hs_file)+ , ModSummary(ms_hspp_file, ms_hspp_opts, ms_location, ms_mod)+ , Module+ , ModuleName+ , Name+ , NamedThing+ , ParsedModule (pm_mod_summary, pm_parsed_source)+ , PredType+ , RealSrcLoc+ , RealSrcSpan+ , RdrName+ , Severity(SevWarning)+ , Sig(InlineSig, FixSig, TypeSig)+ , SrcLoc+ , StrictnessMark+ , TyCon+ , TyThing(AConLike, ATyCon, AnId)+ , TyVar+ , TypecheckedModule(tm_checked_module_info, tm_internals_, tm_parsed_module)+ , classMethods+ , classSCTheta+ , dataConTyCon+ , dataConFieldLabels+ , dataConWrapperType+ , getLocA+ , getLogger+ , getName+ , getOccName+ , getSession+ , gopt+ , hsTypeToHsSigType+ , hsTypeToHsSigWcType+ , idDataCon+ , idType+ , ideclAs+ , ideclName+ , instanceDFunId+ , isClassOpId_maybe+ , isClassTyCon+ , isDictonaryId+ , isExternalName+ , isFamilyTyCon+ , isFunTyCon+ , isGoodSrcSpan+ , isLocalId+ , isNewTyCon+ , isPrimTyCon+ , isRecordSelector+ , isTypeSynonymTyCon+ , isVanillaDataCon+ , mkHsApp+ , mkHsDictLet+ , mkHsForAllInvisTele+ , mkHsFractional+ , mkHsIntegral+ , mkHsLam+ , mkModuleName+ , mkSrcLoc+ , mkSrcSpan+ , modInfoTopLevelScope+ , moduleName+ , moduleNameString+ , moduleUnit+ , ms_mod_name+ , nameModule+ , nameSrcSpan+ , nlHsAppTy+ , nlHsFunTy+ , nlHsIf+ , nlHsTyConApp+ , nlHsTyVar+ , nlHsVar+ , nlList+ , nlVarPat+ , noAnn+ , noAnnSrcSpan+ , noExtField+ , noLocA+ , noSrcSpan+ , splitForAllTyCoVars+ , srcLocFile+ , srcLocCol+ , srcLocLine+ , srcSpanEndCol+ , srcSpanEndLine+ , srcSpanFile+ , srcSpanStartCol+ , srcSpanStartLine+ , synTyConDefn_maybe+ , synTyConRhs_maybe+ , tyConArity+ , tyConClass_maybe+ , tyConDataCons+ , tyConKind+ , tyConTyVars+ , unLoc+ )++import GHC.Builtin.Names as Ghc+ ( Uniquable+ , Unique+ , and_RDR+ , bindMName+ , dATA_FOLDABLE+ , dollarIdKey+ , eqClassKey+ , eqClassName+ , ge_RDR+ , gt_RDR+ , fractionalClassKey+ , fractionalClassKeys+ , gHC_REAL+ , getUnique+ , hasKey+ , isStringClassName+ , itName+ , le_RDR+ , lt_RDR+ , minus_RDR+ , negateName+ , not_RDR+ , numericClassKeys+ , ordClassKey+ , ordClassName+ , plus_RDR+ , times_RDR+ , varQual_RDR+ )+import GHC.Builtin.Types as Ghc+ ( anyTy+ , boolTy+ , boolTyCon+ , boolTyConName+ , charDataCon+ , charTyCon+ , consDataCon+ , falseDataCon+ , falseDataConId+ , intDataCon+ , intTy+ , intTyCon+ , intTyConName+ , liftedTypeKind+ , listTyCon+ , listTyConName+ , naturalTy+ , nilDataCon+ , stringTy+ , true_RDR+ , trueDataCon+ , trueDataConId+ , tupleDataCon+ , tupleTyCon+ , typeSymbolKind+ )+import GHC.Builtin.Types.Prim as Ghc+ ( eqPrimTyCon+ , eqReprPrimTyCon+ , primTyCons+ )+import GHC.Builtin.Utils as Ghc+ ( isNumericClass )+import GHC.Core as Ghc+ ( Alt(Alt)+ , AltCon(DEFAULT, DataAlt, LitAlt)+ , Arg+ , Bind(NonRec, Rec)+ , CoreAlt+ , CoreArg+ , CoreBind+ , CoreBndr+ , CoreExpr+ , CoreProgram+ , Expr(App, Case, Cast, Coercion, Lam, Let, Lit, Tick, Type, Var)+ , Unfolding(CoreUnfolding, DFunUnfolding, uf_tmpl)+ , bindersOf+ , cmpAlt+ , collectArgs+ , collectBinders+ , collectTyAndValBinders+ , collectTyBinders+ , flattenBinds+ , isId+ , isTypeArg+ , maybeUnfoldingTemplate+ , mkApps+ , mkLams+ , mkTyApps+ , mkTyArg+ )+import GHC.Core.Class as Ghc+ ( classAllSelIds+ , classBigSig+ , classSCSelIds+ , Class+ ( classKey+ , className+ , classTyCon+ , classTyVars+ )+ )+import GHC.Core.Coercion as Ghc+ ( Role+ , Var+ , coercionKind+ , isCoVar+ , mkRepReflCo+ )+import GHC.Core.Coercion.Axiom as Ghc+ ( Branched+ , CoAxiom+ , CoAxiomRule(CoAxiomRule)+ , coAxiomTyCon+ )+import GHC.Core.ConLike as Ghc+ ( ConLike(RealDataCon) )+import GHC.Core.DataCon as Ghc+ ( FieldLabel(flSelector)+ , classDataCon+ , dataConExTyCoVars+ , dataConFullSig+ , dataConImplicitTyThings+ , dataConInstArgTys+ , dataConName+ , dataConOrigArgTys+ , dataConRepArgTys+ , dataConRepType+ , dataConRepStrictness+ , dataConTheta+ , dataConUnivTyVars+ , dataConWorkId+ , dataConWrapId+ , dataConWrapId_maybe+ , isTupleDataCon+ )+import GHC.Core.FamInstEnv as Ghc+ ( FamFlavor(DataFamilyInst)+ , FamInst(FamInst, fi_flavor)+ , FamInstEnv+ , FamInstEnvs+ , emptyFamInstEnv+ , famInstEnvElts+ , topNormaliseType_maybe+ )+import GHC.Core.InstEnv as Ghc+ ( ClsInst(is_cls, is_dfun, is_dfun_name, is_tys)+ , DFunId+ , instEnvElts+ , instanceSig+ )+import GHC.Core.Make as Ghc+ ( mkCoreApps+ , mkCoreConApps+ , mkCoreLams+ , mkCoreLets+ , pAT_ERROR_ID+ )+import GHC.Core.Predicate as Ghc (getClassPredTys_maybe, getClassPredTys, isEvVarType, isEqPrimPred, isEqPred, isClassPred, isDictId, mkClassPred)+import GHC.Core.Subst as Ghc (deShadowBinds, emptySubst, extendCvSubst)+import GHC.Core.TyCo.Rep as Ghc+ ( AnonArgFlag(VisArg)+ , ArgFlag(Required)+ , Coercion+ ( AppCo+ , AxiomRuleCo+ , AxiomInstCo+ , CoVarCo+ , ForAllCo+ , FunCo+ , InstCo+ , KindCo+ , LRCo+ , NthCo+ , SubCo+ , SymCo+ , TransCo+ , TyConAppCo+ , UnivCo+ )+ , TyLit(CharTyLit, NumTyLit, StrTyLit)+ , Type+ ( AppTy+ , CastTy+ , CoercionTy+ , ForAllTy+ , FunTy+ , LitTy+ , TyConApp+ , TyVarTy+ , ft_arg+ , ft_res+ )+ , UnivCoProvenance(PhantomProv, ProofIrrelProv)+ , binderVar+ , mkForAllTys+ , mkFunTy+ , mkTyVarTy+ , mkTyVarTys+ )+import GHC.Core.TyCon as Ghc+ ( TyConBinder+ , TyConBndrVis(AnonTCB)+ , isAlgTyCon+ , isBoxedTupleTyCon+ , isFamInstTyCon+ , isGadtSyntaxTyCon+ , isPromotedDataCon+ , isTupleTyCon+ , isVanillaAlgTyCon+ , mkKindTyCon+ , newTyConRhs+ , tyConBinders+ , tyConDataCons_maybe+ , tyConFamInst_maybe+ , tyConName+ , tyConSingleDataCon_maybe+ )+import GHC.Core.Type as Ghc+ ( Specificity(SpecifiedSpec)+ , TyVarBinder+ , pattern Many+ , classifiesTypeWithValues+ , dropForAlls+ , emptyTvSubstEnv+ , eqType+ , expandTypeSynonyms+ , irrelevantMult+ , isFunTy+ , isTyVar+ , isTyVarTy+ , mkTvSubstPrs+ , mkTyConApp+ , newTyConInstRhs+ , nonDetCmpType+ , piResultTys+ , splitAppTys+ , splitFunTy_maybe+ , splitFunTys+ , splitTyConApp+ , splitTyConApp_maybe+ , substTy+ , substTyWith+ , tyConAppArgs_maybe+ , tyConAppTyCon_maybe+ , tyVarKind+ , varType+ )+import GHC.Core.Unify as Ghc+ ( ruleMatchTyKiX, tcUnifyTy )+import GHC.Core.Utils as Ghc (exprType)+import GHC.Data.Bag as Ghc+ ( Bag, bagToList )+import GHC.Data.FastString as Ghc+ ( FastString+ , bytesFS+ , concatFS+ , fsLit+ , mkFastString+ , mkFastStringByteString+ , sLit+ , uniq+ , unpackFS+ )+import GHC.Data.Pair as Ghc+ ( Pair(Pair) )+import GHC.Driver.Main as Ghc+ ( hscDesugar+ , hscTcRcLookupName+ )+import GHC.Driver.Phases as Ghc (Phase(StopLn))+import GHC.Driver.Pipeline as Ghc (compileFile)+import GHC.Driver.Session as Ghc+ ( WarnReason(NoReason)+ , getDynFlags+ , gopt_set+ , updOptLevel+ , xopt_set+ )+import GHC.Driver.Monad as Ghc (withSession)+import GHC.HsToCore.Monad as Ghc+ ( DsM, initDsTc, initDsWithModGuts, newUnique )+import GHC.Iface.Syntax as Ghc+ ( IfaceAnnotation(ifAnnotatedValue) )+import GHC.Plugins as Ghc ( deserializeWithData+ , fromSerialized+ , toSerialized+ , defaultPlugin+ , Plugin(..)+ , CommandLineOption+ , purePlugin+ , extendIdSubst+ , substExpr+ )+import GHC.Core.FVs as Ghc (exprFreeVarsList)+import GHC.Core.Opt.OccurAnal as Ghc+ ( occurAnalysePgm )+import GHC.Driver.Env as Ghc+ ( HscEnv(hsc_EPS, hsc_HPT, hsc_dflags, hsc_plugins, hsc_static_plugins) )+import GHC.Driver.Ppr as Ghc+ ( showPpr+ , showSDoc+ , showSDocDump+ )+import GHC.HsToCore.Expr as Ghc+ ( dsLExpr )+import GHC.Iface.Load as Ghc+ ( cannotFindModule+ , loadInterface+ )+import GHC.Rename.Expr as Ghc (rnLExpr)+import GHC.Tc.Gen.App as Ghc (tcInferSigma)+import GHC.Tc.Gen.Bind as Ghc (tcValBinds)+import GHC.Tc.Gen.Expr as Ghc (tcInferRho)+import GHC.Tc.Module as Ghc+ ( getModuleInterface+ , tcRnLookupRdrName+ )+import GHC.Tc.Solver as Ghc+ ( InferMode(NoRestrictions)+ , captureTopConstraints+ , simplifyInfer+ , simplifyInteractive+ )+import GHC.Tc.Types as Ghc+ ( Env(env_top)+ , TcGblEnv(tcg_anns, tcg_exports, tcg_insts, tcg_mod, tcg_rdr_env, tcg_rn_imports)+ , TcM+ , TcRn+ , WhereFrom(ImportBySystem)+ )+import GHC.Tc.Types.Evidence as Ghc+ ( TcEvBinds(EvBinds) )+import GHC.Tc.Types.Origin as Ghc (lexprCtOrigin)+import GHC.Tc.Utils.Monad as Ghc+ ( captureConstraints+ , discardConstraints+ , getEnv+ , failIfErrsM+ , failM+ , failWithTc+ , initIfaceTcRn+ , liftIO+ , mkLongErrAt+ , pushTcLevelM+ , reportError+ , reportErrors+ )+import GHC.Tc.Utils.TcType as Ghc (tcSplitDFunTy, tcSplitMethodTy)+import GHC.Tc.Utils.Zonk as Ghc+ ( zonkTopLExpr )+import GHC.Types.Annotations as Ghc+ ( AnnPayload+ , AnnTarget(ModuleTarget)+ , Annotation(Annotation, ann_target, ann_value)+ , findAnns+ )+import GHC.Types.Avail as Ghc+ ( AvailInfo(Avail, AvailTC)+ , availNames+ , greNameMangledName+ )+import GHC.Types.Basic as Ghc+ ( Arity+ , Boxity(Boxed)+ , PprPrec+ , PromotionFlag(NotPromoted)+ , TopLevelFlag(NotTopLevel)+ , funPrec+ , InlinePragma(inl_act, inl_inline, inl_rule, inl_sat, inl_src)+ , isDeadOcc+ , isStrongLoopBreaker+ , noOccInfo+ , topPrec+ )+import GHC.Types.CostCentre as Ghc+ ( CostCentre(cc_loc)+ )+import GHC.Types.Error as Ghc+ ( Messages+ , DecoratedSDoc+ , MsgEnvelope(errMsgSpan)+ )+import GHC.Types.Fixity as Ghc+ ( Fixity(Fixity) )+import GHC.Types.Id as Ghc+ ( idDetails+ , isDFunId+ , idInfo+ , idOccInfo+ , isConLikeId+ , modifyIdInfo+ , mkExportedLocalId+ , mkUserLocal+ , realIdUnfolding+ , setIdInfo+ )+import GHC.Types.Id.Info as Ghc+ ( CafInfo(NoCafRefs)+ , IdDetails(DataConWorkId, DataConWrapId, RecSelId, VanillaId)+ , IdInfo(occInfo, unfoldingInfo)+ , cafInfo+ , inlinePragInfo+ , mayHaveCafRefs+ , setCafInfo+ , setOccInfo+ , vanillaIdInfo+ )+import GHC.Types.Literal as Ghc+ ( LitNumType(LitNumInt)+ , Literal(LitChar, LitDouble, LitFloat, LitNumber, LitString)+ , literalType+ )+import GHC.Types.Name as Ghc+ ( OccName+ , getOccString+ , getSrcSpan+ , isInternalName+ , isSystemName+ , mkInternalName+ , mkSystemName+ , mkTcOcc+ , mkTyVarOcc+ , mkVarOcc+ , mkVarOccFS+ , nameModule_maybe+ , nameOccName+ , nameSrcLoc+ , nameStableString+ , occNameFS+ , occNameString+ , stableNameCmp+ )+import GHC.Types.Name.Reader as Ghc+ ( ImpDeclSpec(ImpDeclSpec, is_as, is_dloc, is_mod, is_qual)+ , ImportSpec(ImpSpec)+ , ImpItemSpec(ImpAll)+ , getRdrName+ , globalRdrEnvElts+ , gresFromAvails+ , greMangledName+ , lookupGRE_RdrName+ , mkGlobalRdrEnv+ , mkQual+ , mkVarUnqual+ , mkUnqual+ , nameRdrName+ )+import GHC.Types.SourceError as Ghc+ ( SourceError+ , srcErrorMessages+ )+import GHC.Types.SourceText as Ghc+ ( SourceText(SourceText,NoSourceText)+ , mkIntegralLit+ , mkTHFractionalLit+ )+import GHC.Types.SrcLoc as Ghc+ ( SrcSpan(RealSrcSpan, UnhelpfulSpan)+ , UnhelpfulSpanReason+ ( UnhelpfulGenerated+ , UnhelpfulInteractive+ , UnhelpfulNoLocationInfo+ , UnhelpfulOther+ , UnhelpfulWiredIn+ )+ , combineSrcSpans+ , mkGeneralSrcSpan+ , mkRealSrcLoc+ , mkRealSrcSpan+ , realSrcSpanStart+ , srcSpanFileName_maybe+ , srcSpanToRealSrcSpan+ )+import GHC.Types.Tickish as Ghc (CoreTickish, GenTickish(..))+import GHC.Types.Unique as Ghc+ ( getKey, mkUnique )+import GHC.Types.Unique.Set as Ghc (mkUniqSet)+import GHC.Types.Unique.Supply as Ghc+ ( MonadUnique, getUniqueM )+import GHC.Types.Var as Ghc+ ( VarBndr(Bndr)+ , mkLocalVar+ , mkTyVar+ , setVarName+ , setVarType+ , setVarUnique+ , varName+ , varUnique+ )+import GHC.Types.Var.Env as Ghc+ ( emptyInScopeSet, mkRnEnv2 )+import GHC.Types.Var.Set as Ghc+ ( VarSet+ , elemVarSet+ , emptyVarSet+ , extendVarSet+ , extendVarSetList+ , unitVarSet+ )+import GHC.Unit.External as Ghc+ ( ExternalPackageState (eps_ann_env)+ )+import GHC.Unit.Finder as Ghc+ ( FindResult(Found, NoPackage, FoundMultiple, NotFound)+ , findExposedPackageModule+ , findImportedModule+ )+import GHC.Unit.Home.ModInfo as Ghc+ ( HomePackageTable, HomeModInfo(hm_iface), lookupHpt )+import GHC.Unit.Module as Ghc+ ( GenWithIsBoot(gwib_isBoot, gwib_mod)+ , IsBootInterface(NotBoot, IsBoot)+ , ModuleNameWithIsBoot+ , UnitId+ , fsToUnit+ , mkModuleNameFS+ , moduleNameFS+ , moduleStableString+ , toUnitId+ , unitString+ )+import GHC.Unit.Module.ModGuts as Ghc+ ( ModGuts+ ( mg_binds+ , mg_exports+ , mg_fam_inst_env+ , mg_inst_env+ , mg_module+ , mg_tcs+ , mg_usages+ )+ )+import GHC.Utils.Error as Ghc (withTiming)+import GHC.Utils.Logger as Ghc (putLogMsg)+import GHC.Utils.Outputable as Ghc hiding ((<>))+import GHC.Utils.Panic as Ghc (panic, throwGhcException, throwGhcExceptionIO)
+ src-ghc/Liquid/GHC/API/Extra.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-}++module Liquid.GHC.API.Extra (+ module StableModule+ , ApiComment(..)+ , apiComments+ , apiCommentsParsedSource+ , dataConSig+ , desugarModuleIO+ , fsToUnitId+ , getDependenciesModuleNames+ , isPatErrorAlt+ , lookupModSummary+ , modInfoLookupNameIO+ , moduleInfoTc+ , moduleUnitId+ , parseModuleIO+ , qualifiedNameFS+ , relevantModules+ , renderWithStyle+ , showPprQualified+ , showSDocQualified+ , thisPackage+ , tyConRealArity+ , typecheckModuleIO+ ) 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 Data.Foldable (asum)+import Data.List (foldl', sortOn)+import qualified Data.Set as S+import GHC.Core as Ghc+import GHC.Core.Coercion as Ghc+import GHC.Core.DataCon as Ghc+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 GHC.Driver.Env+import GHC.Driver.Main+import GHC.Driver.Session as Ghc+import GHC.Tc.Types+import GHC.Types.Name (isSystemName, nameModule_maybe, occNameFS)+import GHC.Types.SrcLoc as Ghc+import GHC.Types.TypeEnv+import GHC.Types.Unique (getUnique)+import GHC.Types.Unique.FM++import GHC.Unit.Module.Deps as Ghc (Dependencies(dep_mods))+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+fsToUnitId = toUnitId . fsToUnit++moduleUnitId :: Module -> UnitId+moduleUnitId = toUnitId . moduleUnit++thisPackage :: DynFlags -> UnitId+thisPackage = homeUnitId_++-- See NOTE [tyConRealArity].+tyConRealArity :: TyCon -> Int+tyConRealArity tc = go 0 (tyConKind tc)+ where+ go :: Int -> Kind -> Int+ go !acc k =+ case asum [fmap (\(_, _, c) -> c) (splitFunTy_maybe k), fmap snd (splitForAllTyCoVar_maybe k)] of+ Nothing -> acc+ Just ks -> go (acc + 1) ks++getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]+getDependenciesModuleNames = dep_mods++renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String+renderWithStyle dynflags sdoc style = Ghc.renderWithContext (Ghc.initSDocContext dynflags style) sdoc++-- This function is gone in GHC 9.+dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)+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 :: ModGuts -> S.Set Module+relevantModules modGuts = used `S.union` dependencies+ where+ dependencies :: S.Set Module+ dependencies = S.fromList $ map (toModule . gwib_mod)+ . filter ((NotBoot ==) . gwib_isBoot)+ . getDependenciesModuleNames $ deps++ deps :: Dependencies+ deps = mg_deps modGuts++ thisModule :: Module+ thisModule = mg_module modGuts++ toModule :: ModuleName -> Module+ toModule = unStableModule . mkStableModule (moduleUnitId thisModule)++ 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')++-- | Abstraction of 'EpaComment'.+data ApiComment+ = ApiLineComment String+ | ApiBlockComment String+ deriving (Eq, Show)++-- | Extract top-level comments from a module.+apiComments :: ParsedModule -> [Ghc.Located ApiComment]+apiComments pm = apiCommentsParsedSource (pm_parsed_source pm)++apiCommentsParsedSource :: Located HsModule -> [Ghc.Located ApiComment]+apiCommentsParsedSource ps =+ let hs = unLoc ps+ go :: forall a. Data a => a -> [LEpaComment]+ go = gmapQr (++) [] go `extQ` (id @[LEpaComment])+ in Data.List.sortOn (spanToLineColumn . getLoc) $+ mapMaybe (tokComment . toRealSrc) $ go hs+ where+ tokComment (L sp (EpaComment (EpaLineComment s) _)) = Just (L sp (ApiLineComment s))+ tokComment (L sp (EpaComment (EpaBlockComment s) _)) = Just (L sp (ApiBlockComment s))+ tokComment _ = Nothing++ -- TODO: take into account anchor_op, which only matters if the source was+ -- pre-processed by an exact-print-aware tool.+ toRealSrc (L a e) = L (RealSrcSpan (anchor a) Nothing) e++ 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++-- | 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 }++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++moduleInfoTc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModuleInfoLH+moduleInfoTc hscEnv ms tcGblEnv = do+ let hsc_env_tmp = hscEnv { hsc_dflags = ms_hspp_opts ms }+ details <- md_types <$> liftIO (makeSimpleDetails hsc_env_tmp tcGblEnv)+ pure ModuleInfoLH { minflh_type_env = details }++-- | Tells if a case alternative calls to patError+isPatErrorAlt :: CoreAlt -> Bool+isPatErrorAlt (Alt _ _ exprCoreBndr) = hasPatErrorCall exprCoreBndr+ where+ 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+ -- 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 _ e) = hasPatErrorCall e+ -- otherwise+ hasPatErrorCall _ = False+++qualifiedNameFS :: Name -> FastString+qualifiedNameFS n = concatFS [modFS, occFS, uniqFS]+ where+ modFS = case nameModule_maybe n of+ Nothing -> fsLit ""+ Just m -> concatFS [moduleNameFS (moduleName m), fsLit "."]++ occFS = occNameFS (getOccName n)+ uniqFS+ | isSystemName n+ = concatFS [fsLit "_", fsLit (showPprQualified (getUnique n))]+ | otherwise+ = fsLit ""++-- Variants of Outputable functions which now require DynFlags!+showPprQualified :: Outputable a => a -> String+showPprQualified = showSDocQualified . ppr++showSDocQualified :: Ghc.SDoc -> String+showSDocQualified = Ghc.renderWithContext ctx+ where+ style = Ghc.mkUserStyle myQualify Ghc.AllTheWay+ ctx = Ghc.defaultSDocContext { sdocStyle = style }++myQualify :: Ghc.PrintUnqualified+myQualify = Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }+-- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }
+ src-ghc/Liquid/GHC/API/StableModule.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveGeneric #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Liquid.GHC.API.StableModule (+ StableModule+ -- * Constructing a 'StableModule'+ , mkStableModule+ -- * Converting a 'StableModule' into a standard 'Module'+ , unStableModule+ -- * Utility functions+ , toStableModule+ , renderModule+ ) where++import qualified GHC+import qualified GHC.Unit.Types as GHC+import qualified GHC.Unit.Module as GHC+import Data.Hashable+import GHC.Generics hiding (to, moduleName)+import Data.Binary++-- | A newtype wrapper around a 'Module' which:+--+-- * Allows a 'Module' to be serialised (i.e. it has a 'Binary' instance)+-- * It tries to use stable comparison and equality under the hood.+--+newtype StableModule =+ StableModule { unStableModule :: GHC.Module }+ deriving Generic++-- | Converts a 'Module' into a 'StableModule'.+toStableModule :: GHC.Module -> StableModule+toStableModule = StableModule++moduleUnitId :: GHC.Module -> GHC.UnitId+moduleUnitId = GHC.toUnitId . GHC.moduleUnit++renderModule :: GHC.Module -> String+renderModule m = "Module { unitId = " <> (GHC.unitIdString . moduleUnitId $ m)+ <> ", name = " <> GHC.moduleNameString (GHC.moduleName m)+ <> " }"++-- These two orphans originally lived inside module 'Language.Haskell.Liquid.Types.Types'.+instance Hashable GHC.ModuleName where+ hashWithSalt i = hashWithSalt i . GHC.moduleNameString++instance Hashable StableModule where+ hashWithSalt s (StableModule mdl) = hashWithSalt s (GHC.moduleStableString mdl)++instance Ord StableModule where+ (StableModule m1) `compare` (StableModule m2) = GHC.stableModuleCmp m1 m2++instance Eq StableModule where+ (StableModule m1) == (StableModule m2) = (m1 `GHC.stableModuleCmp` m2) == EQ++instance Show StableModule where+ show (StableModule mdl) = "Stable" ++ renderModule mdl++instance Binary StableModule where++ put (StableModule mdl) = do+ put (GHC.unitIdString . moduleUnitId $ mdl)+ put (GHC.moduleNameString . GHC.moduleName $ mdl)++ get = do+ uidStr <- get+ mkStableModule (GHC.stringToUnitId uidStr) . GHC.mkModuleName <$> get++--+-- Compat shim layer+--++-- | Creates a new 'StableModule' out of a 'ModuleName' and a 'UnitId'.+mkStableModule :: GHC.UnitId -> GHC.ModuleName -> StableModule+mkStableModule uid modName =+ let realUnit = GHC.RealUnit $ GHC.Definite uid+ in StableModule (GHC.Module realUnit modName)
+ src/Language/Haskell/Liquid/Bare.hs view
@@ -0,0 +1,1325 @@+{-# 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++--------------------------------------------------------------------------------+-- | 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.+ }+ })+ 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+ 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+ ]+ let sigVars = F.notracepp "SIGVARS" $ (fst3 <$> xtes) -- reflects+ ++ (fst <$> gsAsmSigs sig) -- assumes+ ++ (fst <$> gsRefSigs sig)+ return SpRefl+ { gsLogicMap = lmap+ , gsAutoInst = autoInst+ , gsImpAxioms = concatMap (Ms.axeqs . snd) (M.toList specs)+ , gsMyAxioms = F.notracepp "gsMyAxioms" myAxioms+ , gsReflects = F.notracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wRefls)+ , gsHAxioms = F.notracepp "gsHAxioms" xtes+ , 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++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, 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+ , 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 ]+ reflected = fst <$> (wreflSigs ++ reflSigs)+ 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+ , 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+ -- 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+ mbImp = takeUnique mkErr (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)++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++-- makeSpecRTAliases :: Bare.Env -> BareRTEnv -> [Located SpecRTAlias]+-- makeSpecRTAliases _env _rtEnv = [] -- TODO-REBARE+++--------------------------------------------------------------------------------+-- | @myRTEnv@ slices out the part of RTEnv that was generated by aliases defined+-- in the _target_ file, "cooks" the aliases (by conversion to SpecType), and+-- then saves them back as BareType.+--------------------------------------------------------------------------------+myRTEnv :: GhcSrc -> Bare.Env -> Bare.SigEnv -> BareRTEnv -> BareRTEnv+myRTEnv src env sigEnv rtEnv = mkRTE tAs' eAs+ where+ tAs' = normalizeBareAlias env sigEnv name <$> tAs+ tAs = myAliases typeAliases+ eAs = myAliases exprAliases+ myAliases fld = filter (isLocInFile srcF) . M.elems . fld $ rtEnv+ srcF = _giTarget src+ name = _giTargetMod src++mkRTE :: [Located (RTAlias x a)] -> [Located (RTAlias F.Symbol F.Expr)] -> RTEnv x a+mkRTE tAs eAs = RTE+ { typeAliases = M.fromList [ (aName a, a) | a <- tAs ]+ , exprAliases = M.fromList [ (aName a, a) | a <- eAs ]+ }+ where aName = rtName . F.val++normalizeBareAlias :: Bare.Env -> Bare.SigEnv -> ModName -> Located BareRTAlias+ -> Located BareRTAlias+normalizeBareAlias env sigEnv name lx = fixRTA <$> lx+ where+ fixRTA :: BareRTAlias -> BareRTAlias+ fixRTA = mapRTAVars fixArg . fmap fixBody++ fixArg :: Symbol -> Symbol+ fixArg = F.symbol . GM.symbolTyVar++ fixBody :: BareType -> BareType+ fixBody = Bare.specToBare+ . F.val+ . Bare.cookSpecType env sigEnv name Bare.RawTV+ . F.atLoc lx+++withDiagnostics :: (Monoid a) => Bare.Lookup a -> (Diagnostics, a)+withDiagnostics (Left es) = (mkDiagnostics [] es, mempty)+withDiagnostics (Right v) = (emptyDiagnostics, v)
+ src/Language/Haskell/Liquid/Bare/Axiom.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module contains the code that DOES reflection; i.e. converts Haskell+-- definitions into refinements.++module Language.Haskell.Liquid.Bare.Axiom ( makeHaskellAxioms, wiredReflects ) where++import Prelude hiding (error)+import Prelude hiding (mapM)+import qualified Control.Exception as Ex++-- import Control.Monad.Except hiding (forM, mapM)+-- import Control.Monad.State hiding (forM, mapM)+import qualified Text.PrettyPrint.HughesPJ as PJ -- (text)+import qualified Data.HashSet as S+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+import qualified Language.Haskell.Liquid.GHC.Misc as GM+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.Bare.Resolve as Bare+import Language.Haskell.Liquid.Bare.Types as Bare++-----------------------------------------------------------------------------------------------+makeHaskellAxioms :: Config -> GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> 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))++getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec+ -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]+getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs+ where+ sigs = gsTySigs sig+ xs = S.toList (Ms.reflects spec)+ cbs = _giCbs src++findVarDefType :: [Ghc.CoreBind] -> [(Ghc.Var, LocSpecType)] -> LocSymbol+ -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)+findVarDefType cbs sigs x = case findVarDefMethod (val x) 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 "Cannot lift haskell function"++--------------------------------------------------------------------------------+makeAxiom :: Bare.Env -> Bare.TycEnv -> ModName -> LogicMap+ -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)+ -> (Ghc.Var, LocSpecType, F.Equation)+--------------------------------------------------------------------------------+makeAxiom env tycEnv name 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+ embs = Bare.tcEmbs tycEnv+ dm = Bare.tcDataConMap tycEnv+ allowTC = typeclass (getConfig env)++mkError :: LocSymbol -> String -> Error+mkError x str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text str)++makeAssumeType+ :: Bool -- ^ typeclass enabled+ -> 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)+ where+ 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+ 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+ Right e -> e+ Left e -> panic Nothing (show 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+ (xs, def') = GM.notracePpr "grabBody" $ grabBody allowTC (Ghc.expandTypeSynonyms τ) $ normalize allowTC def+ su = F.mkSubst $ zip (F.symbol <$> xs) xArgs+ ++ zip (simplesymbol <$> xs) xArgs+ xts = [(F.symbol x, rTypeSortExp tce t) | (x, t) <- aargs at]++rTypeSortExp :: F.TCEmb Ghc.TyCon -> SpecType -> F.Sort+rTypeSortExp tce = typeSort tce . Ghc.expandTypeSynonyms . toType False++grabBody :: Bool -- ^ typeclass enabled+ -> Ghc.Type -> Ghc.CoreExpr -> ([Ghc.Var], Ghc.CoreExpr)+grabBody allowTC (Ghc.ForAllTy _ ty) e+ = grabBody allowTC ty e+grabBody allowTC@False Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} e | Ghc.isClassPred tx+ = grabBody allowTC t e+grabBody allowTC@True Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} e | isEmbeddedDictType tx+ = grabBody allowTC t e+grabBody allowTC torig@Ghc.FunTy {} (Ghc.Let (Ghc.NonRec x e) body)+ = grabBody allowTC torig (subst (x,e) body)+grabBody allowTC Ghc.FunTy{ Ghc.ft_res = t} (Ghc.Lam x e)+ = (x:xs, e') where (xs, e') = grabBody allowTC t e+grabBody allowTC t (Ghc.Tick _ e)+ = grabBody allowTC t e+grabBody allowTC ty@Ghc.FunTy{} e+ = (txs++xs, e')+ where (ts,tr) = splitFun ty+ (xs, e') = grabBody allowTC tr (foldl Ghc.App e (Ghc.Var <$> txs))+ txs = [ stringVar ("ls" ++ show i) t | (t,i) <- zip ts [(1::Int)..]]+grabBody _ _ e+ = ([], e)++splitFun :: Ghc.Type -> ([Ghc.Type], Ghc.Type)+splitFun = go []+ where go acc Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} = go (tx:acc) t+ go acc t = (reverse acc, t)+++isBoolBind :: Ghc.Var -> Bool+isBoolBind v = isBool (ty_res $ toRTypeRep ((ofType $ Ghc.varType v) :: RRType ()))++strengthenRes :: SpecType -> F.Reft -> SpecType+strengthenRes st rf = go st+ where+ 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++class Subable a where+ subst :: (Ghc.Var, Ghc.CoreExpr) -> a -> a++instance Subable Ghc.Var where+ subst (x, ex) z+ | x == z, Ghc.Var y <- ex = y+ | otherwise = z++instance Subable Ghc.CoreExpr where+ subst (x, ex) (Ghc.Var y)+ | x == y = ex+ | otherwise = Ghc.Var y+ subst su (Ghc.App f e)+ = Ghc.App (subst su f) (subst su e)+ subst su (Ghc.Lam x e)+ = Ghc.Lam x (subst su e)+ 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)+ 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)+ = Ghc.Cast (subst su e) t+ subst su (Ghc.Tick t e)+ = Ghc.Tick t (subst su e)+ subst _ e+ = e++instance Subable Ghc.CoreAlt where+ 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 }++-- | Specification for Haskell function+axiomType :: Bool -> LocSymbol -> SpecType -> AxiomType+axiomType 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+ go (RAllP p t) = RAllP p <$> go t+ go (RFun x i tx t r) | isErasable tx = (\t' -> RFun x i tx t' r) <$> go t+ go (RFun x ii tx t r) = do+ (i,bs,mres) <- get+ let x' = unDummy x i+ put (i+1, (x', tx):bs,mres)+ t' <- go t+ return $ RFun x' ii tx t' r+ go t = do+ (i,bs,_) <- get+ let ys = reverse $ map fst bs+ let t' = strengthen t (singletonApp s ys)+ put (i, bs, Just t')+ return t'+ isErasable = if allowTC then isEmbeddedClass else isClassType+unDummy :: F.Symbol -> Int -> F.Symbol+unDummy x i+ | x /= F.dummySymbol = x+ | otherwise = F.symbol ("lq" ++ show i)++singletonApp :: F.Symbolic a => LocSymbol -> [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"
+ src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -0,0 +1,758 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.Bare.Check+ ( checkTargetSpec+ , checkBareSpec+ , checkTargetSrc+ ) where+++import Language.Haskell.Liquid.Constraint.ToFixpoint++import Liquid.GHC.API as Ghc hiding ( Located+ , text+ , (<+>)+ , panic+ , ($+$)+ , empty+ )+import Control.Applicative ((<|>))+import Control.Arrow ((&&&))+import Data.Maybe+import Data.Function (on)+import Text.PrettyPrint.HughesPJ hiding ((<>))+import qualified Data.List as L+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.Hashable+import qualified Language.Fixpoint.Misc as Misc+import Language.Fixpoint.SortCheck (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.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+++----------------------------------------------------------------------------------------------+-- | Checking TargetSrc ------------------------------------------------------------------------+----------------------------------------------------------------------------------------------+checkTargetSrc :: Config -> TargetSrc -> Either Diagnostics ()+checkTargetSrc cfg spec+ | nopositivity cfg+ || nopositives == emptyDiagnostics+ = Right ()+ | otherwise+ = Left nopositives+ where nopositives = checkPositives (gsTcs spec)+++checkPositives :: [TyCon] -> Diagnostics+checkPositives tys = mkDiagnostics [] $ mkNonPosError (getNonPositivesTyCon tys)++mkNonPosError :: [(TyCon, [DataCon])] -> [Error]+mkNonPosError tcs = [ ErrPosTyCon (getSrcSpan tc) (pprint tc) (pprint dc <+> ":" <+> pprint (dataConRepType dc))+ | (tc, dc:_) <- tcs]++----------------------------------------------------------------------------------------------+-- | Checking BareSpec ------------------------------------------------------------------------+----------------------------------------------------------------------------------------------+checkBareSpec :: ModName -> Ms.BareSpec -> Either Diagnostics ()+checkBareSpec _ sp+ | allChecks == emptyDiagnostics = Right ()+ | otherwise = Left allChecks+ where+ allChecks = mconcat [ checkUnique "measure" measures+ , checkUnique "field" fields+ , checkDisjoints [ inlines+ , hmeasures+ , S.fromList measures+ , reflects+ , 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)++dataDeclFields :: DataDecl -> [F.LocSymbol]+dataDeclFields = filter (not . GM.isTmpSymbol . F.val)+ . Misc.hashNubWith val+ . concatMap dataCtorFields+ . fromMaybe []+ . tycDCons++dataCtorFields :: DataCtor -> [F.LocSymbol]+dataCtorFields c+ | isGadt c = []+ | otherwise = F.atLoc c <$> [ f | (f,_) <- dcFields c ]++isGadt :: DataCtor -> Bool+isGadt = isJust . dcResult++checkUnique :: String -> [F.LocSymbol] -> Diagnostics+checkUnique _ = mkDiagnostics mempty . checkUnique' F.val GM.fSrcSpan++checkUnique' :: (PPrint a, Eq a, Hashable a)+ => (t -> a) -> (t -> Ghc.SrcSpan) -> [t] -> [Error]+checkUnique' nameF locF ts = [ErrDupSpecs l (pprint n) ls | (n, ls@(l:_)) <- dups]+ where+ dups = [ z | z@(_, _:_:_) <- Misc.groupList nts ]+ nts = [ (n, l) | t <- ts, let n = nameF t, let l = locF t ]++checkDisjoints :: [S.HashSet F.LocSymbol] -> Diagnostics+checkDisjoints [] = emptyDiagnostics+checkDisjoints [_] = emptyDiagnostics+checkDisjoints (s:ss) = checkDisjoint s (S.unions ss) <> checkDisjoints ss++checkDisjoint :: S.HashSet F.LocSymbol -> S.HashSet F.LocSymbol -> Diagnostics+checkDisjoint s1 s2 = checkUnique "disjoint" (S.toList s1 ++ S.toList s2)++----------------------------------------------------------------------------------------------+-- | Checking TargetSpec+----------------------------------------------------------------------------------------------++checkTargetSpec :: [Ms.BareSpec]+ -> TargetSrc+ -> F.SEnv F.SortedReft+ -> [CoreBind]+ -> TargetSpec+ -> Either Diagnostics ()+checkTargetSpec specs src env cbs tsp+ | diagnostics == emptyDiagnostics = Right ()+ | otherwise = Left diagnostics+ where+ diagnostics :: Diagnostics+ diagnostics = foldMap (checkBind allowHO bsc "measure" emb tcEnv env) (gsMeas (gsData tsp))+ <> 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)+ -- ++ 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))+ <> 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)+ <> checkDuplicate (gsTySigs (gsSig tsp))+ -- TODO-REBARE ++ checkQualifiers env (gsQualifiers (gsQual sp))+ <> checkDuplicate (gsAsmSigs (gsSig tsp))+ <> checkDupIntersect (gsTySigs (gsSig tsp)) (gsAsmSigs (gsSig tsp))+ <> checkRTAliases "Type Alias" env tAliases+ <> checkRTAliases "Pred Alias" env eAliases+ -- ++ _checkDuplicateFieldNames (gsDconsP sp)+ -- 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))+ <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig tsp) ])+ <> checkLawInstances (gsLaws tsp)+ <> checkRewrites tsp++ _rClasses = concatMap Ms.classes specs+ _rInsts = concatMap Ms.rinstance specs+ tAliases = concat [Ms.aliases sp | sp <- specs]+ eAliases = concat [Ms.ealiases sp | sp <- specs]+ emb = gsTcEmbeds (gsName tsp)+ tcEnv = gsTyconEnv (gsName tsp)+ ms = gsMeasures (gsData tsp)+ clsSigs sp = [ (v, t) | (v, t) <- gsTySigs sp, isJust (isClassOpId_maybe v) ]+ sigs = gsTySigs (gsSig tsp) ++ gsAsmSigs (gsSig tsp) ++ gsCtors (gsData tsp)+ -- allowTC = typeclass (getConfig sp)+ allowHO = higherOrderFlag tsp+ bsc = bscope (getConfig tsp)+ noPrune = not (pruneFlag tsp)+ txCtors ts = [(v, fmap (fmap (fmap (F.filterUnMatched temps))) t) | (v, t) <- ts]+ temps = F.makeTemplates $ gsUnsorted $ gsData tsp+ -- env' = L.foldl' (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms++++++checkPlugged :: PPrint v => [(v, LocSpecType)] -> Diagnostics+checkPlugged xs = mkDiagnostics mempty (map mkError (filter (hasHoleTy . val . snd) xs))+ where+ mkError (x,t) = ErrBadData (GM.sourcePosSrcSpan $ loc t) (pprint x) msg+ msg = "Cannot resolve type hole `_`. Use explicit type instead."+++--------------------------------------------------------------------------------+checkTySigs :: Bool+ -> BScope+ -> [CoreBind]+ -> F.TCEmb TyCon+ -> Bare.TyConMap+ -> F.SEnv F.SortedReft+ -> GhcSpecSig+ -> Diagnostics+--------------------------------------------------------------------------------+checkTySigs allowHO bsc cbs emb tcEnv senv sig+ = mconcat (map (check senv) topTs)+ -- = 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 env [] cbs+ where+ check env = checkSigTExpr allowHO bsc emb tcEnv env+ 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+ { envF = \env v -> F.insertSEnv (F.symbol v) (vSort v) env+ , bindF = \env acc v -> errs env v <> acc+ , exprF = \_ acc _ -> acc+ }+ vSort = Bare.varSortedReft emb+ errs env v = case M.lookup v locTm of+ Nothing -> 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+ where+ mbErr1 = checkBind allowHO bsc empty emb tcEnv env (x, t)+ mbErr2 = maybe 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))+ where+ mkError ((f, tcp), msg) = ErrTyCon (GM.sourcePosSrcSpan $ tcpLoc tcp)+ (text "Size function" <+> pprint (f x)+ <+> text "should have type int, but it was "+ <+> pprint (tcpCon tcp)+ <+> text "."+ $+$ msg)+ (pprint (tcpCon tcp))+ go tcp = case tcpSizeFun tcp of+ Nothing -> Nothing+ Just f | isWiredInLenFn f -> Nothing -- Skip the check.+ Just f -> checkWFSize (szFun f) tcp++ checkWFSize f tcp = ((f, tcp),) <$> checkSortFull (F.srcSpan tcp) (F.insertSEnv x (mkTySort (tcpCon tcp)) env) F.intSort (f x)+ x = "x" :: F.Symbol+ mkTySort tc = rTypeSortedReft emb (ofType $ TyConApp tc (TyVarTy <$> tyConTyVars tc) :: RRType ())++ isWiredInLenFn :: SizeFun -> Bool+ 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+checkInv allowHO bsc emb tcEnv env (_, t) = checkTy allowHO bsc err emb tcEnv env t+ where+ err = ErrInvt (GM.sourcePosSrcSpan $ loc t) (val t)++checkIAl :: Bool+ -> BScope+ -> F.TCEmb TyCon+ -> Bare.TyConMap+ -> F.SEnv F.SortedReft+ -> [(LocSpecType, LocSpecType)]+ -> Diagnostics+checkIAl allowHO bsc emb tcEnv env = mconcat . map (checkIAlOne allowHO bsc emb tcEnv env)++checkIAlOne :: Bool+ -> BScope+ -> F.TCEmb TyCon+ -> Bare.TyConMap+ -> F.SEnv F.SortedReft+ -> (LocSpecType, LocSpecType)+ -> Diagnostics+checkIAlOne allowHO bsc emb tcEnv env (t1, t2) = mconcat $ checkEq : (tcheck <$> [t1, t2])+ 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+ t2' :: RSort+ t2' = toRSort $ val t2+ checkEq = if t1' == t2' then emptyDiagnostics else mkDiagnostics mempty [errmis]+ errmis = ErrIAlMis (GM.sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg+ emsg = pprint t1 <+> text "does not match with" <+> pprint t2+++-- FIXME: Should _ be removed if it isn't used?+checkRTAliases :: String -> t -> [Located (RTAlias s a)] -> Diagnostics+checkRTAliases msg _ as = err1s+ where+ err1s = checkDuplicateRTAlias msg as++checkBind :: (PPrint v)+ => Bool+ -> BScope+ -> Doc+ -> F.TCEmb TyCon+ -> Bare.TyConMap+ -> F.SEnv F.SortedReft+ -> (v, LocSpecType)+ -> 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)+++checkTerminationExpr :: (Eq v, PPrint v)+ => 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)+ where+ -- es = val <$> les+ mkError :: Doc -> Maybe (F.Expr, Doc) -> Diagnostics+ mkError _ Nothing = emptyDiagnostics+ mkError k (Just expr') =+ mkDiagnostics mempty [(\ (e, d) -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e st d) expr']+ -- 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' :: [F.Located F.Expr] -> Maybe (F.Expr, Doc)+ go' = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (cmpZero e)) 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)+ trep = toRTypeRep st++ mkClss (_, RApp c ts _ _) | isClass c = classBinds emb (rRCls c ts)+ mkClss (x, t) = [(x, rSort t)]++ rSort = rTypeSortedReft emb+ cmpZero e = F.PAtom F.Le (F.expr (0 :: Int)) (val e)++checkTy :: Bool+ -> BScope+ -> (Doc -> Error)+ -> F.TCEmb TyCon+ -> Bare.TyConMap+ -> F.SEnv F.SortedReft+ -> LocSpecType+ -> 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]+ where+ _msg = "CHECKTY: " ++ showpp (val t)++checkDupIntersect :: [(Var, LocSpecType)] -> [(Var, LocSpecType)] -> Diagnostics+checkDupIntersect xts asmSigs =+ mkDiagnostics (map mkWrn {- trace msg -} dups) mempty+ where+ mkWrn (x, t) = mkWarning (GM.sourcePosSrcSpan $ loc t) (pprWrn x)+ dups = L.intersectBy ((==) `on` fst) asmSigs xts+ pprWrn v = text $ "Assume Overwrites Specifications for " ++ show v+ -- msg = "CHECKDUPINTERSECT:" ++ msg1 ++ msg2+ -- msg1 = "\nCheckd-SIGS:\n" ++ showpp (M.fromList xts)+ -- msg2 = "\nAssume-SIGS:\n" ++ showpp (M.fromList asmSigs)+++checkDuplicate :: [(Var, LocSpecType)] -> Diagnostics+checkDuplicate = mkDiagnostics mempty . checkUnique' fst (GM.fSrcSpan . snd)++checkClassMethods :: Maybe [ClsInst] -> [Var] -> [(Var, LocSpecType)] -> Diagnostics+checkClassMethods Nothing _ _ = emptyDiagnostics+checkClassMethods (Just clsis) cms xts =+ mkDiagnostics mempty [ErrMClass (GM.sourcePosSrcSpan $ loc t) (pprint x)| (x,t) <- dups ]+ where+ dups = F.notracepp "DPS" $ filter ((`elem` ms) . fst) xts'+ ms = F.notracepp "MS" $ concatMap (classMethods . is_cls) clsis+ xts' = F.notracepp "XTS" $ filter (not . (`elem` cls) . fst) xts+ cls = F.notracepp "CLS" cms++checkDuplicateRTAlias :: String -> [Located (RTAlias s a)] -> Diagnostics+checkDuplicateRTAlias s tas = mkDiagnostics mempty (map mkError dups)+ where+ mkError xs@(x:_) = ErrDupAlias (GM.fSrcSpan x)+ (text s)+ (pprint . rtName . val $ x)+ (GM.fSrcSpan <$> xs)+ mkError [] = panic Nothing "mkError: called on empty list"+ dups = [z | z@(_:_:_) <- L.groupBy ((==) `on` (rtName . val)) tas]+++checkMismatch :: (Var, LocSpecType) -> Diagnostics+checkMismatch (x, t) = if ok then emptyDiagnostics else mkDiagnostics mempty [err]+ where+ ok = tyCompat x (val t)+ err = errTypeMismatch x t++tyCompat :: Var -> RType RTyCon RTyVar r -> Bool+tyCompat x t = lqT == hsT+ where+ lqT :: RSort = toRSort t+ hsT :: RSort = ofType (varType x)+ _msg = "TY-COMPAT: " ++ GM.showPpr x ++ ": hs = " ++ F.showpp hsT ++ " :lq = " ++ F.showpp lqT++errTypeMismatch :: Var -> Located SpecType -> Error+errTypeMismatch x t = ErrMismatch lqSp (pprint x) (text "Checked") d1 d2 Nothing hsSp+ where+ d1 = pprint $ varType x+ d2 = pprint $ toType False $ val t+ lqSp = GM.fSrcSpan t+ hsSp = getSrcSpan x++------------------------------------------------------------------------------------------------+-- | @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 allowHO bsc emb senv lt+ = 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)+ pbinds p = (pname p, pvarRType p :: RSort) : [(x, tx) | (tx, x, _) <- pargs p]++tyToBind :: F.TCEmb TyCon -> RTVar RTyVar RSort -> [(F.Symbol, F.SortedReft)]+tyToBind emb = go . ty_var_info+ where+ go RTVInfo{..} = [(rtv_name, rTypeSortedReft emb rtv_kind)]+ go RTVNoInfo{} = []++checkAppTys :: RType RTyCon t t1 -> Maybe Doc+checkAppTys = go+ where+ go (RAllT _ t _) = go t+ go (RAllP _ t) = go t+ go (RApp rtc ts _ _)+ = checkTcArity rtc (length ts) <|>+ L.foldl' (\merr t -> merr <|> go t) Nothing ts+ go (RFun _ _ t1 t2 _) = go t1 <|> go t2+ go (RVar _ _) = Nothing+ go (RAllE _ t1 t2) = go t1 <|> go t2+ go (REx _ t1 t2) = go t1 <|> go t2+ go (RAppTy t1 t2 _) = go t1 <|> go t2+ go (RRTy _ _ _ t) = go t+ go (RExprArg _) = Just $ text "Logical expressions cannot appear inside a Haskell type"+ go (RHole _) = Nothing++checkTcArity :: RTyCon -> Arity -> Maybe Doc+checkTcArity RTyCon{ rtc_tc = tc } givenArity+ | expectedArity < givenArity+ = Just $ text "Type constructor" <+> pprint tc+ <+> text "expects a maximum" <+> pprint expectedArity+ <+> text "arguments but was given" <+> pprint givenArity+ <+> text "arguments"+ | otherwise+ = Nothing+ where+ expectedArity = tyConRealArity tc+++checkAbstractRefs+ :: (PPrint t, F.Reftable t, SubsTy RTyVar RSort t, F.Reftable (RTProp RTyCon RTyVar (UReft t))) =>+ RType RTyCon RTyVar (UReft t) -> Maybe Doc+checkAbstractRefs rt = go rt+ where+ penv = mkPEnv rt++ go t@(RAllT _ t1 r) = check (toRSort t :: RSort) r <|> go t1+ go (RAllP _ t) = go t+ go t@(RApp c ts rs r) = check (toRSort t :: RSort) r <|> efold go ts <|> go' c rs+ go t@(RFun _ _ t1 t2 r) = check (toRSort t :: RSort) r <|> go t1 <|> go t2+ go t@(RVar _ r) = check (toRSort t :: RSort) r+ go (RAllE _ t1 t2) = go t1 <|> go t2+ go (REx _ t1 t2) = go t1 <|> go t2+ go t@(RAppTy t1 t2 r) = check (toRSort t :: RSort) r <|> go t1 <|> go t2+ go (RRTy xts _ _ t) = efold go (snd <$> xts) <|> go t+ go (RExprArg _) = Nothing+ go (RHole _) = Nothing++ go' c rs = L.foldl' (\acc (x, y) -> acc <|> checkOne' x y) Nothing (zip rs (rTyConPVs c))++ checkOne' (RProp xs (RHole _)) p+ | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]+ = Just $ text "Wrong Arguments in" <+> pprint p+ | length xs /= length (pargs p)+ = Just $ text "Wrong Number of Arguments in" <+> pprint p+ | otherwise+ = Nothing+ checkOne' (RProp xs t) p+ | pvType p /= toRSort t+ = Just $ text "Unexpected Sort in" <+> pprint p+ | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]+ = Just $ text "Wrong Arguments in" <+> pprint p+ | length xs /= length (pargs p)+ = Just $ text "Wrong Number of Arguments in" <+> pprint p+ | otherwise+ = go t+++ efold f = L.foldl' (\acc x -> acc <|> f x) Nothing++ check s (MkUReft _ (Pr ps)) = L.foldl' (\acc pp -> acc <|> checkOne s pp) Nothing ps++ checkOne s p | pvType' p /= s+ = Just $ text "Incorrect Sort:\n\t"+ <+> text "Abstract refinement with type"+ <+> pprint (pvType' p)+ <+> text "is applied to"+ <+> pprint s+ <+> text "\n\t In" <+> pprint p+ | otherwise+ = Nothing++ mkPEnv (RAllT _ t _) = mkPEnv t+ mkPEnv (RAllP p t) = p:mkPEnv t+ mkPEnv _ = []+ 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+ where+ r = rTypeSortedReft emb t+ dr = text "Sort Error in Refinement:" <+> pprint r++-- DONT DELETE the below till we've added pred-checking as well+-- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t)+-- where xs = fromMaybe [] $ params <$> stripRTypeBase t++-- checkSig env (x, t)+-- = case filter (not . (`S.member` env)) (freeSymbols t) of+-- [] -> TrueNGUAGE ScopedTypeVariables #-}+-- ys -> errorstar (msg ys)+-- where+-- msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t)++---------------------------------------------------------------------------------------------------+-- | @checkMeasures@ determines if a measure definition is wellformed -----------------------------+---------------------------------------------------------------------------------------------------+checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> Diagnostics+---------------------------------------------------------------------------------------------------+checkMeasures emb env = foldMap (checkMeasure emb env)++checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> Diagnostics+checkMeasure emb γ (M name@(Loc src _ n) sort body _ _)+ = mkDiagnostics mempty [ txerror e | Just e <- checkMBody γ emb name sort <$> body ]+ where+ txerror = ErrMeas (GM.sourcePosSrcSpan src) (pprint n)++checkMBody :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+ => F.SEnv F.SortedReft+ -> F.TCEmb TyCon+ -> t+ -> SpecType+ -> Def (RRType r) DataCon+ -> Maybe Doc+checkMBody senv emb _ sort (Def m c _ bs body) = checkMBody' emb sort γ' sp body+ where+ sp = F.srcSpan m+ γ' = L.foldl' (\γ (x, t) -> F.insertSEnv x t γ) senv xts+ xts = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVarsMeet su <$>+ filter keep (ty_args trep)+ keep | allowTC = not . isEmbeddedClass+ | otherwise = not . isClassType+ -- YL: extract permitTC information from sort+ allowTC = or $ fmap (fromMaybe False . permitTC) (ty_info $ toRTypeRep sort)+ trep = toRTypeRep ct+ su = checkMBodyUnify (ty_res trep) (last txs)+ txs = thd5 $ bkArrowDeep sort+ ct = ofType $ dataConWrapperType c :: SpecType++checkMBodyUnify+ :: RType t t2 t1 -> RType c tv r -> [(t2,RType c tv (),RType c tv r)]+checkMBodyUnify = go+ where+ go (RVar tv _) t = [(tv, toRSort t, t)]+ go t@RApp{} t'@RApp{} = concat $ zipWith go (rt_args t) (rt_args t')+ go _ _ = []++checkMBody' :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.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+ 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+ where+ sty = rTypeSortedReft emb sort'+ sort' = dropNArgs 1 sort++dropNArgs :: Int -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r+dropNArgs i t = fromRTypeRep $ trep {ty_binds = xs, ty_info = is, ty_args = ts, ty_refts = rs}+ where+ xs = drop i $ ty_binds trep+ ts = drop i $ ty_args trep+ rs = drop i $ ty_refts trep+ is = drop i $ ty_info trep+ trep = toRTypeRep t+++getRewriteErrors :: (Var, Located SpecType) -> [TError t]+getRewriteErrors (rw, t)+ | null $ refinementEQs t+ = [ErrRewrite (GM.fSrcSpan t) $ text $+ "Unable to use "+ ++ show rw+ ++ " as a rewrite because it does not prove an equality, or the equality it proves is trivial." ]+ | otherwise+ = refErrs +++ [ ErrRewrite (GM.fSrcSpan t) $+ text $ "Could not generate any rewrites from equality. Likely causes: "+ ++ "\n - There are free (uninstantiatable) variables on both sides of the "+ ++ "equality\n - The rewrite would diverge"+ | cannotInstantiate]+ where+ refErrs = map getInnerRefErr (filter (hasInnerRefinement . fst) (zip tyArgs syms))+ allowedRWs = [ (lhs, rhs) | (lhs , rhs) <- refinementEQs t+ , canRewrite (S.fromList syms) lhs rhs ||+ canRewrite (S.fromList syms) rhs lhs+ ]+ cannotInstantiate = null allowedRWs+ tyArgs = ty_args tRep+ syms = ty_binds tRep+ tRep = toRTypeRep $ val t+ getInnerRefErr (_, sym) =+ ErrRewrite (GM.fSrcSpan t) $ text $+ "Unable to use "+ ++ show rw+ ++ " as a rewrite. Functions whose parameters have inner refinements cannot be used as rewrites, but parameter "+ ++ show sym+ ++ " contains an inner refinement."+++isRefined :: F.Reftable r => RType c tv r -> Bool+isRefined ty+ | Just r <- stripRTypeBase ty = not $ F.isTauto r+ | otherwise = False++hasInnerRefinement :: F.Reftable r => RType c tv r -> Bool+hasInnerRefinement (RFun _ _ rIn rOut _) =+ isRefined rIn || isRefined rOut+hasInnerRefinement (RAllT _ ty _) =+ isRefined ty+hasInnerRefinement (RAllP _ ty) =+ isRefined ty+hasInnerRefinement (RApp _ args _ _) =+ any isRefined args+hasInnerRefinement (RAllE _ allarg ty) =+ isRefined allarg || isRefined ty+hasInnerRefinement (REx _ allarg ty) =+ isRefined allarg || isRefined ty+hasInnerRefinement (RAppTy arg res _) =+ isRefined arg || isRefined res+hasInnerRefinement (RRTy env _ _ ty) =+ isRefined ty || any (isRefined . snd) env+hasInnerRefinement _ = False++checkRewrites :: TargetSpec -> Diagnostics+checkRewrites targetSpec = mkDiagnostics mempty (concatMap getRewriteErrors rwSigs)+ where+ rwSigs = filter ((`S.member` rws) . fst) sigs+ refl = gsRefl targetSpec+ sig = gsSig targetSpec+ sigs = gsTySigs sig ++ gsAsmSigs sig+ rws = S.union (S.map val $ gsRewrites refl)+ (S.fromList $ concat $ M.elems (gsRewritesWith refl))+++checkClassMeasures :: [Measure SpecType DataCon] -> Diagnostics+checkClassMeasures measures = mkDiagnostics mempty (mapMaybe checkOne byTyCon)+ where+ byName = L.groupBy ((==) `on` (val . msName)) measures++ byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . msEqns)))+ byName++ checkOne [] = impossible Nothing "checkClassMeasures.checkOne on empty measure group"+ checkOne [_] = Nothing+ checkOne (m:ms) = Just (ErrDupIMeas (GM.fSrcSpan (msName m))+ (pprint (val (msName m)))+ (pprint ((dataConTyCon . ctor . head . msEqns) m))+ (GM.fSrcSpan <$> (m:ms)))+++
+ src/Language/Haskell/Liquid/Bare/Class.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.Bare.Class+ ( makeClasses+ , makeCLaws+ , makeSpecDictionaries+ , makeDefaultMethods+ , makeMethodTypes+ )+ where++import Data.Bifunctor+import qualified Data.Maybe as Mb+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++import Language.Haskell.Liquid.Types.Dictionaries+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.RefType+import Language.Haskell.Liquid.Types hiding (freeTyVars)++import qualified Language.Haskell.Liquid.Measure as Ms+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.Bare.Misc as Bare++import Text.PrettyPrint.HughesPJ (text)+import qualified Control.Exception as Ex+import Control.Monad (forM)++++-------------------------------------------------------------------------------+makeMethodTypes :: Bool -> DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)]+-------------------------------------------------------------------------------+makeMethodTypes allowTC (DEnv hm) cls cbs+ = [(x, MT (addCC allowTC x . fromRISig <$> methodType d x hm) (addCC allowTC x <$> classType (splitDictionary e) x)) | (d,e) <- ds, x <- grepMethods e]+ where+ grepMethods = filter GM.isMethod . freeVars mempty+ ds = filter (GM.isDictionary . fst) (concatMap unRec cbs)+ unRec (Ghc.Rec xes) = xes+ unRec (Ghc.NonRec x e) = [(x,e)]++ 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)+ _ -> Nothing++ methodType d x m = ihastype (M.lookup d m) x++ ihastype Nothing _ = Nothing+ ihastype (Just xts) x = M.lookup (mkSymbol x) xts++ mkSymbol x = F.dropSym 2 $ GM.simplesymbol x++ subst [] t = t+ subst ((a,ta):su) t = subsTyVarMeet' (a,ofType ta) (subst su t)++addCC :: Bool -> Ghc.Var -> LocSpecType -> LocSpecType+addCC allowTC var zz@(Loc l l' st0)+ = Loc l l'+ . addForall hst+ . mkArrow [] ps' []+ . makeCls cs'+ . mapExprReft (\_ -> F.applyCoSub coSub)+ . subts su+ $ st+ where+ hst = ofType (Ghc.expandTypeSynonyms t0) :: SpecType+ t0 = Ghc.varType var+ tyvsmap = case Bare.runMapTyVars allowTC t0 st err of+ Left e -> Ex.throw e+ Right s -> Bare.vmap s+ su = [(y, rTyVar x) | (x, y) <- tyvsmap]+ su' = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]+ coSub = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]+ ps' = fmap (subts su') <$> ps+ cs' = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs ]+ (_,_,cs,_) = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)+ (_,ps,_ ,st) = bkUnivClass (F.notracepp "lq-spec" st0)++ makeCls c t = foldr (uncurry rFun) t c+ err hsT lqT = ErrMismatch (GM.fSrcSpan zz) (pprint var)+ (text "makeMethodTypes")+ (pprint $ Ghc.expandTypeSynonyms t0)+ (pprint $ toRSort st0)+ (Just (hsT, lqT))+ (Ghc.getSrcSpan var)++ addForall (RAllT v t r) tt@(RAllT v' _ _)+ | v == v'+ = tt+ | otherwise+ = RAllT (updateRTVar v) (addForall t tt) r+ addForall (RAllT v t r) t'+ = RAllT (updateRTVar v) (addForall t t') r+ addForall (RAllP _ t) t'+ = addForall t t'+ addForall _ (RAllP p t')+ = RAllP (fmap (subts su') p) t'+ addForall (RFun _ _ t1 t2 _) (RFun x i t1' t2' r)+ = RFun x i (addForall t1 t1') (addForall t2 t2') r+ addForall _ t+ = t+++splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var])+splitDictionary = go [] []+ where+ go ts xs (Ghc.App e (Ghc.Tick _ a)) = go ts xs (Ghc.App e a)+ go ts xs (Ghc.App e (Ghc.Type t)) = go (t:ts) xs e+ go ts xs (Ghc.App e (Ghc.Var x)) = go ts (x:xs) e+ go ts xs (Ghc.Tick _ t) = go ts xs t+ go ts xs (Ghc.Var x) = Just (x, reverse ts, reverse xs)+ go _ _ _ = Nothing+++-------------------------------------------------------------------------------+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)])+-------------------------------------------------------------------------------+makeClasses env sigEnv myName specs = do+ mbZs <- forM classTcs $ \(name, cls, tc) ->+ mkClass env sigEnv myName name cls tc+ return . second mconcat . unzip . Mb.catMaybes $ mbZs+ where+ 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++mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon+ -> Bare.Lookup (Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)]))+mkClass env sigEnv _myName name (RClass cc ss as ms)+ = Bare.failMaybe env name+ . mkClassE env sigEnv _myName name (RClass cc ss as ms)++mkClassE :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon+ -> Bare.Lookup (DataConP, [(ModName, Ghc.Var, LocSpecType)])+mkClassE env sigEnv _myName name (RClass cc ss as ms) tc = do+ ss' <- mapM (mkConstr env sigEnv name) ss+ meths <- mapM (makeMethod env sigEnv name) ms'+ let vts = [ (m, v, t) | (m, kv, t) <- meths, v <- Mb.maybeToList (plugSrc kv) ]+ let sts = [(val s, unClass $ val t) | (s, _) <- ms | (_, _, t) <- meths]+ let dcp = DataConP l dc αs [] (val <$> ss') (reverse sts) rt False (F.symbol name) l'+ return $ F.notracepp msg (dcp, vts)+ where+ c = btc_tc cc+ l = loc c+ l' = locE c+ msg = "MKCLASS: " ++ F.showpp (cc, as, αs)+ (dc:_) = Ghc.tyConDataCons tc+ αs = bareRTyVar <$> as+ as' = [rVar $ GM.symbolTyVar $ F.symbol a | a <- as ]+ ms' = [ (s, rFun "" (RApp cc (flip RVar mempty <$> as) [] mempty) <$> t) | (s, t) <- ms]+ rt = rCls tc as'++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)+ -> 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)++-------------------------------------------------------------------------------+makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType+-------------------------------------------------------------------------------+makeSpecDictionaries env sigEnv specs+ = dfromList+ . concatMap (makeSpecDictionary env sigEnv)+ $ M.toList 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++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 ]+ where+ ts = mkTy' <$> lbt+ rts = concatMap (univs . val) ts+ univs t = (\(RTVar tv _, _) -> tv) <$> as where (as, _, _) = bkUniv t++ mkTy' :: LocBareType -> LocSpecType+ mkTy' = Bare.cookSpecType env sigEnv name Bare.GenTV+ mkTy :: LocBareType -> LocSpecType+ mkTy = fmap (mapUnis tidy) . Bare.cookSpecType env sigEnv name+ Bare.GenTV -- (Bare.HsTV (Bare.lookupGhcVar env name "rawDictionaries" x))+ mapUnis f t = mkUnivs (f as) ps t0 where (as, ps, t0) = bkUniv t++ tidy vs = l ++ r+ where (l,r) = L.partition (\(RTVar tv _,_) -> tv `elem` rts) vs++ 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+ where+ lookupVar (x, inst) = (, inst) <$> Bare.maybeResolveSym env name "resolveDict" (F.dummyLoc x)++-- 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++----------------------------------------------------------------------------------+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 ]++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)
+ src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -0,0 +1,819 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.DataType+ ( dataConMap++ -- * Names for accessing Data Constuctors+ , makeDataConChecker+ , makeDataConSelector+ , addClassEmbeds++ -- * Constructors+ , makeDataDecls+ , makeConTypes+ , makeRecordSelectorSigs+ , meetDataConSpec+ -- , makeTyConEmbeds++ , dataDeclSize+ ) where++import qualified Control.Exception as Ex+import Control.Monad.Reader+import qualified Data.List as L+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.Maybe as Mb++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.PredType (dataConPSpecType)+import qualified Language.Haskell.Liquid.Types.RefType as RT+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 Text.Printf (printf)+import Text.PrettyPrint ((<+>))++--------------------------------------------------------------------------------+-- | 'DataConMap' stores the names of those ctor-fields that have been declared+-- as SMT ADTs so we don't make up new names for them.+--------------------------------------------------------------------------------+dataConMap :: [F.DataDecl] -> Bare.DataConMap+dataConMap ds = M.fromList $ do+ d <- ds+ c <- F.ddCtors d+ let fs = F.symbol <$> F.dcFields c+ zip ((F.symbol c,) <$> [1..]) fs+++--------------------------------------------------------------------------------+-- | 'makeDataConChecker d' creates the measure for `is$d` which tests whether+-- a given value was created by 'd'. e.g. is$Nil or is$Cons.+--------------------------------------------------------------------------------+makeDataConChecker :: Ghc.DataCon -> F.Symbol+--------------------------------------------------------------------------------+makeDataConChecker = F.testSymbol . F.symbol++--------------------------------------------------------------------------------+-- | 'makeDataConSelector d' creates the selector `select$d$i`+-- which projects the i-th field of a constructed value.+-- e.g. `select$Cons$1` and `select$Cons$2` are respectively+-- equivalent to `head` and `tail`.+--------------------------------------------------------------------------------+makeDataConSelector :: Maybe Bare.DataConMap -> Ghc.DataCon -> Int -> F.Symbol+makeDataConSelector dmMb d i = M.lookupDefault def (F.symbol d, i) dm+ where+ dm = Mb.fromMaybe M.empty dmMb+ def = makeDataConSelector' d i+++makeDataConSelector' :: Ghc.DataCon -> Int -> F.Symbol+makeDataConSelector' d i+ = symbolMeasure "$select" (dcSymbol d) (Just i)++dcSymbol :: Ghc.DataCon -> F.Symbol+dcSymbol = {- simpleSymbolVar -} F.symbol . Ghc.dataConWorkId++symbolMeasure :: String -> F.Symbol -> Maybe Int -> F.Symbol+symbolMeasure f d iMb = foldr1 F.suffixSymbol (dcPrefix : F.symbol f : d : rest)+ where+ rest = maybe [] (Misc.single . F.symbol . show) iMb+++--------------------------------------------------------------------------------+-- | makeClassEmbeds: sort-embeddings for numeric, and family-instance tycons+--------------------------------------------------------------------------------+addClassEmbeds :: Maybe [Ghc.ClsInst] -> [Ghc.TyCon] -> F.TCEmb Ghc.TyCon+ -> F.TCEmb Ghc.TyCon+addClassEmbeds instenv fiTcs = makeFamInstEmbeds fiTcs . makeNumEmbeds instenv++--------------------------------------------------------------------------------+-- | makeFamInstEmbeds : embed family instance tycons, see [NOTE:FamInstEmbeds]+--------------------------------------------------------------------------------+-- Query.R$58$EntityFieldBlobdog+-- with the actual family instance types that have numeric instances as int [Check!]+--------------------------------------------------------------------------------+makeFamInstEmbeds :: [Ghc.TyCon] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon+makeFamInstEmbeds cs0 embeds = L.foldl' embed embeds famInstSorts+ where+ famInstSorts = F.notracepp "famInstTcs"+ [ (c, RT.typeSort embeds ty)+ | c <- cs+ , ty <- Mb.maybeToList (RT.famInstTyConType c) ]+ embed embs (c, t) = F.tceInsert c t F.NoArgs embs+ cs = F.notracepp "famInstTcs-all" cs0++{-+famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type+famInstTyConType c = case Ghc.tyConFamInst_maybe c of+ Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts))+ $ Just (famInstType (Ghc.tyConArity c) c' ts)+ Nothing -> Nothing++famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type+famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)+-}++{- | [NOTE:FamInstEmbeds] GHC represents family instances in two ways:++ (1) As an applied type,+ (2) As a special tycon.++ For example, consider `tests/pos/ExactGADT4.hs`:++ class PersistEntity record where+ data EntityField record :: * -> *++ data Blob = B { xVal :: Int, yVal :: Int }++ instance PersistEntity Blob where+ data EntityField Blob dog where+ BlobXVal :: EntityField Blob Int+ BlobYVal :: EntityField Blob Int++ here, the type of the constructor `BlobXVal` can be represented as:++ (1) EntityField Blob Int,++ or++ (2) R$58$EntityFieldBlobdog Int++ PROBLEM: For various reasons, GHC will use _both_ representations interchangeably,+ which messes up our sort-checker.++ SOLUTION: To address the above, we create an "embedding"++ R$58$EntityFieldBlobdog :-> EntityField Blob++ So that all occurrences of the (2) are treated as (1) by the sort checker.++ -}++--------------------------------------------------------------------------------+-- | makeNumEmbeds: embed types that have numeric instances as int [Check!]+--------------------------------------------------------------------------------+makeNumEmbeds :: Maybe [Ghc.ClsInst] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon+makeNumEmbeds Nothing x = x+makeNumEmbeds (Just is) x = L.foldl' makeNumericInfoOne x is++makeNumericInfoOne :: F.TCEmb Ghc.TyCon -> Ghc.ClsInst -> F.TCEmb Ghc.TyCon+makeNumericInfoOne m is+ | isFracCls cls, Just tc <- instanceTyCon is+ = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True True) F.NoArgs m+ | isNumCls cls, Just tc <- instanceTyCon is+ = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True False) F.NoArgs m+ | otherwise+ = m+ where+ cls = Ghc.classTyCon (Ghc.is_cls is)+ ftc c f1 f2 = F.FTC (F.symbolNumInfoFTyCon (dummyLoc $ RT.tyConName c) f1 f2)++mappendSortFTC :: F.Sort -> F.Sort -> F.Sort+mappendSortFTC (F.FTC x) (F.FTC y) = F.FTC (F.mappendFTC x y)+mappendSortFTC s (F.FTC _) = s+mappendSortFTC (F.FTC _) s = s+mappendSortFTC s1 s2 = panic Nothing ("mappendSortFTC: s1 = " ++ showpp s1 ++ " s2 = " ++ showpp s2)++instanceTyCon :: Ghc.ClsInst -> Maybe Ghc.TyCon+instanceTyCon = go . Ghc.is_tys+ where+ go [Ghc.TyConApp c _] = Just c+ go _ = Nothing++--------------------------------------------------------------------------------+-- | Create Fixpoint DataDecl from LH DataDecls --------------------------------+--------------------------------------------------------------------------------++-- | A 'DataPropDecl' is associated with a (`TyCon` and) `DataDecl`, and defines the+-- sort of relation that is established by terms of the given `TyCon`.+-- A 'DataPropDecl' say, 'pd' is associated with a 'dd' of type 'DataDecl' when+-- 'pd' is the `SpecType` version of the `BareType` given by `tycPropTy dd`.++type DataPropDecl = (DataDecl, Maybe SpecType)++makeDataDecls :: Config -> F.TCEmb Ghc.TyCon -> ModName+ -> [(ModName, Ghc.TyCon, DataPropDecl)]+ -> [Located DataConP]+ -> (Diagnostics, [F.DataDecl])+makeDataDecls cfg tce name tds ds+ | makeDecls = (mkDiagnostics warns [], okDecs)+ | otherwise = (mempty, [])+ where+ makeDecls = exactDCFlag cfg && not (noADT cfg)+ warns = (mkWarnDecl . fst . fst . snd <$> badTcs) ++ (mkWarnDecl <$> badDecs)+ tds' = resolveTyCons name tds+ tcDds = filter ((/= Ghc.listTyCon) . fst)+ $ groupDataCons tds' ds+ (okTcs, badTcs) = L.partition isVanillaTc tcDds+ decs = [ makeFDataDecls tce tc dd ctors | (tc, (dd, ctors)) <- okTcs]+ (okDecs,badDecs) = checkRegularData decs++isVanillaTc :: (a, (b, [(Ghc.DataCon, c)])) -> Bool+isVanillaTc (_, (_, ctors)) = all (Ghc.isVanillaDataCon . fst) ctors++checkRegularData :: [F.DataDecl] -> ([F.DataDecl], [F.DataDecl])+checkRegularData ds = (oks, badDs)+ where+ badDs = F.checkRegular ds+ 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))+++-- [NOTE:Orphan-TyCons]++{- | 'resolveTyCons' will prune duplicate 'TyCon' definitions, as follows:++ Let the "home" of a 'TyCon' be the module where it is defined.+ There are three kinds of 'DataDecl' definitions:++ 1. A "home"-definition is one that belongs to its home module,+ 2. An "orphan"-definition is one that belongs to some non-home module.++ A 'DataUser' definition SHOULD be a "home" definition+ - otherwise you can avoid importing the definition+ and hence, unsafely pass its invariants!++ So, 'resolveTyConDecls' implements the following protocol:++ (a) If there is a "Home" definition,+ then use it, and IGNORE others.++ (b) If there are ONLY "orphan" definitions,+ then pick the one from an _LHAssumptions module.++ (c) If there are ONLY "orphan" definitions,+ and none in _LHAssumptions modules,+ then pick the one from the module being analyzed.++-}+resolveTyCons :: ModName -> [(ModName, Ghc.TyCon, DataPropDecl)]+ -> [(Ghc.TyCon, (ModName, DataPropDecl))]+resolveTyCons mn mtds = [(tc, (m, d)) | (tc, mds) <- M.toList tcDecls+ , (m, d) <- Mb.maybeToList $ resolveDecls mn tc mds ]+ where+ tcDecls = Misc.group [ (tc, (m, d)) | (m, tc, d) <- mtds ]++-- | See [NOTE:Orphan-TyCons], the below function tells us which of (possibly many)+-- DataDecls to use.+resolveDecls :: ModName -> Ghc.TyCon -> Misc.ListNE (ModName, DataPropDecl)+ -> Maybe (ModName, DataPropDecl)+resolveDecls mName tc mds = F.notracepp msg $+ case filter isHomeDef mds of+ x:_ -> Just x+ _ -> case filter isLHAssumptionsDef mds of+ [x] -> Just x+ xs@(_:_) -> error $+ "Multiple spec declarations of " ++ show (F.symbol tc) +++ " found in _LHAssumption modules: " ++ show (map fst xs) +++ ". Please, remove some of them."+ [] -> L.find isMyDef mds+ where+ msg = "resolveDecls" ++ F.showpp (mName, tc)+ isMyDef = (mName ==) . fst+ isHomeDef = (tcHome ==) . F.symbol . fst+ tcHome = GM.takeModuleNames (F.symbol tc)+ isLHAssumptionsDef = L.isSuffixOf "_LHAssumptions" . Ghc.moduleNameString . getModName . fst++groupDataCons :: [(Ghc.TyCon, (ModName, DataPropDecl))]+ -> [Located DataConP]+ -> [(Ghc.TyCon, (DataPropDecl, [(Ghc.DataCon, DataConP)]))]+groupDataCons tds ds = [ (tc, (d, dds')) | (tc, ((m, d), dds)) <- tcDataCons+ , let dds' = filter (isResolvedDataConP m . snd) dds+ ]+ where+ tcDataCons = M.toList $ M.intersectionWith (,) declM ctorM+ declM = M.fromList tds+ ctorM = Misc.group [(Ghc.dataConTyCon d, (d, dcp)) | Loc _ _ dcp <- ds, let d = dcpCon dcp]++isResolvedDataConP :: ModName -> DataConP -> Bool+isResolvedDataConP m dp = F.symbol m == dcpModule dp++makeFDataDecls :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataPropDecl -> [(Ghc.DataCon, DataConP)]+ -> F.DataDecl+makeFDataDecls tce tc dd ctors = makeDataDecl tce tc (fst dd) ctors++makeDataDecl :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataDecl -> [(Ghc.DataCon, DataConP)]+ -> F.DataDecl+makeDataDecl tce tc dd ctors+ = F.DDecl+ { F.ddTyCon = ftc+ , F.ddVars = length $ GM.tyConTyVarsDef tc+ , F.ddCtors = makeDataCtor tce ftc <$> ctors+ }+ where+ ftc = F.symbolFTycon (tyConLocSymbol tc dd)++tyConLocSymbol :: Ghc.TyCon -> DataDecl -> LocSymbol+tyConLocSymbol tc dd = F.atLoc (tycName dd) (F.symbol tc)++-- [NOTE:ADT] We need to POST-PROCESS the 'Sort' so that:+-- 1. The poly tyvars are replaced with debruijn+-- versions e.g. 'List a_a1m' becomes 'List @(1)'+-- 2. The "self" type is replaced with just itself+-- (i.e. without any type applications.)++makeDataCtor :: F.TCEmb Ghc.TyCon -> F.FTycon -> (Ghc.DataCon, DataConP) -> F.DataCtor+makeDataCtor tce c (d, dp) = F.DCtor+ { F.dcName = GM.namedLocSymbol d+ , F.dcFields = makeDataFields tce c as xts+ }+ where+ as = dcpFreeTyVars dp+ xts = [ (fld x, t) | (x, t) <- reverse (dcpTyArgs dp) ]+ fld = F.atLoc dp . fieldName d dp++fieldName :: Ghc.DataCon -> DataConP -> F.Symbol -> F.Symbol+fieldName d dp x+ | dcpIsGadt dp = F.suffixSymbol (F.symbol d) x+ | otherwise = x++makeDataFields :: F.TCEmb Ghc.TyCon -> F.FTycon -> [RTyVar] -> [(F.LocSymbol, SpecType)]+ -> [F.DataField]+makeDataFields tce _c as xts = [ F.DField x (fSort t) | (x, t) <- xts]+ where+ su = zip (F.symbol <$> as) [0..]+ fSort = F.substVars su . F.mapFVar (+ length as) . RT.rTypeSort tce++{-+muSort :: F.FTycon -> Int -> F.Sort -> F.Sort+muSort c n = V.mapSort tx+ where+ ct = F.fTyconSort c+ me = F.fTyconSelfSort c n+ tx t = if t == me then ct else t+-}++--------------------------------------------------------------------------------+meetDataConSpec :: Bool -> F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP]+ -> [(Ghc.Var, SpecType)]+--------------------------------------------------------------------------------+meetDataConSpec allowTC emb xts dcs = M.toList $ snd <$> L.foldl' upd dcm0 xts+ where+ dcm0 = M.fromListWith meetM (dataConSpec' allowTC dcs)+ 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')+ 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')++dataConSpec' :: Bool -> [DataConP] -> [(Ghc.Var, (Ghc.SrcSpan, SpecType))]+dataConSpec' allowTC = concatMap tx+ where+ tx dcp = [ (x, res) | (x, t0) <- dataConPSpecType allowTC dcp+ , let t = RT.expandProductType x t0+ , let res = (GM.fSrcSpan dcp, t)+ ]+--------------------------------------------------------------------------------+-- | Bare Predicate: DataCon Definitions ---------------------------------------+--------------------------------------------------------------------------------+makeConTypes :: ModName -> Bare.Env -> [(ModName, Ms.BareSpec)]+ -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])+makeConTypes myName env specs =+ Misc.concatUnzip <$> mapM (makeConTypes' myName env) specs+++makeConTypes' :: ModName -> Bare.Env -> (ModName, Ms.BareSpec)+ -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])+makeConTypes' _myName env (name, spec) = 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+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]+ getTc (RAllT _ t _) = getTc t+ getTc (RApp c _ _ _) = Just (val $ btc_tc c)+ getTc _ = Nothing++dataDeclSize :: Ms.BareSpec -> [DataDecl] -> [DataDecl]+dataDeclSize spec dcs = makeSize smap <$> dcs+ where smap = normalizeDSize $ Ms.dsize spec+++makeSize :: DSizeMap -> DataDecl -> DataDecl+makeSize smap d+ | Just p <- M.lookup (F.symbol $ 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}+ where+ go (RApp c ts rs r) | F.symbol c `elem` xs+ = RApp c ts rs (r `F.meet` rsz)+ go t = t+ rsz = MkUReft (F.Reft (F.vv_, F.PAtom F.Lt+ (F.EApp (F.EVar s) (F.EVar F.vv_))+ (F.EApp (F.EVar s) (F.EVar selfSymbol))+ ))+ mempty+++catLookups :: [Bare.Lookup a] -> Bare.Lookup [a]+catLookups = sequence . Mb.mapMaybe skipResolve++skipResolve :: Bare.Lookup a -> Maybe (Bare.Lookup a)+skipResolve (Left es) = left' (filter (not . isErrResolve) es)+skipResolve (Right v) = Just (Right v)++isErrResolve :: TError t -> Bool+isErrResolve ErrResolve {} = True+isErrResolve _ = False++left' :: [e] -> Maybe (Either [e] a)+left' [] = Nothing+left' es = Just (Left es)+++-- | 'canonizeDecls ds' returns a subset of 'ds' with duplicates, e.g. arising+-- due to automatic lifting (via 'makeHaskellDataDecls'). We require that the+-- lifted versions appear LATER in the input list, and always use those+-- instead of the unlifted versions.++canonizeDecls :: Bare.Env -> ModName -> [DataDecl] -> Bare.Lookup [DataDecl]+canonizeDecls env name dataDecls = do+ kds <- forM dataDecls $ \d -> do+ k <- dataDeclKey env name d+ return (fmap (, d) k)+ case Misc.uniqueByKey' selectDD (Mb.catMaybes kds) of+ Left decls -> Left [err decls]+ Right decls -> return decls+ -- [ (k, d) | d <- ds, k <- rights [dataDeclKey env name d] ]+ -- case Misc.uniqueByKey' selectDD kds of+ -- Left decls -> err decls+ -- Right decls -> decls+ where+ -- kds = F.tracepp "canonizeDecls" [ (k, d) | d <- ds, k <- rights [dataDeclKey env name d] ]+ err ds@(d:_) = {- uError $ -} errDupSpecs (pprint (tycName d)) (GM.fSrcSpan <$> ds)+ err _ = impossible Nothing "canonizeDecls"++dataDeclKey :: Bare.Env -> ModName -> DataDecl -> Bare.Lookup (Maybe F.Symbol)+dataDeclKey env name d = do+ tcMb <- Bare.lookupGhcDnTyCon env name "canonizeDecls" (tycName d)+ case tcMb of+ Nothing ->+ return Nothing+ Just tc -> do+ _ <- checkDataCtors env name tc d (tycDCons d)+ return $ Just (F.symbol tc)++-- | Perform sanity check on the data constructors of a LH datatype declaration.+--+-- In the special situation where the LH datatype declaration is only used to+-- attach a termination measure, we pass 'Nothing', and our check always succeeds.+--+-- Otherwise, we check that the constructors match the constructors for the+-- Haskell datatype. This replaces an older check that only verified that any+-- constructor we list in a datatype is indeed a constructor of that corresponding+-- Haskell datatype.+--+-- We also check that constructors do not have duplicate fields.+--+checkDataCtors :: Bare.Env -> ModName -> Ghc.TyCon -> DataDecl -> Maybe [DataCtor] -> Bare.Lookup [DataCtor]+checkDataCtors _env _name _c _dd Nothing = return []+checkDataCtors env name c dd (Just cons) = do+ -- The GHC data constructors (these are qualified)+ let dcs :: S.HashSet F.Symbol+ 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+ 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]++-- | Checks whether the given data constructor has duplicate fields.+--+checkDataCtorDupField :: DataCtor -> Bare.Lookup DataCtor+checkDataCtorDupField d+ | x : _ <- dups = Left [err sym x]+ | otherwise = return d+ where+ sym = dcName d+ xts = dcFields d+ dups = [ x | (x, ts) <- Misc.groupList xts, 2 <= length ts ]+ err lc x = ErrDupField (GM.sourcePosSrcSpan $ loc lc) (pprint $ val lc) (pprint x)++selectDD :: (a, [DataDecl]) -> Either [DataDecl] DataDecl+selectDD (_,[d]) = Right d+selectDD (_, ds) = case [ d | d <- ds, tycKind d == DataReflected ] of+ [d] -> Right d+ _ -> Left ds++groupVariances :: [DataDecl]+ -> [(LocSymbol, [Variance])]+ -> [(Maybe DataDecl, Maybe (LocSymbol, [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)+ | otherwise = (Nothing, Just v) : merge (d:ds) vs+ merge [] vs = (Nothing,) . Just <$> vs+ merge ds [] = (,Nothing) . Just <$> ds+ sym = val . fst+++-- | 'checkDataDecl' checks that the supplied DataDecl is indeed a refinement+-- of the GHC TyCon. We just check that the right tyvars are supplied+-- as errors in the names and types of the constructors will be caught+-- elsewhere. [e.g. tests/errors/BadDataDecl.hs]++checkDataDecl :: Ghc.TyCon -> DataDecl -> Bool+checkDataDecl c d = F.notracepp _msg (isGADT || cN == dN || null (tycDCons d))+ where+ _msg = printf "checkDataDecl: D = %s, c = %s, cN = %d, dN = %d" (show d) (show c) cN dN+ cN = length (GM.tyConTyVarsDef c)+ dN = length (tycTyVars d)+ isGADT = Ghc.isGadtSyntaxTyCon c++getDnTyCon :: Bare.Env -> ModName -> DataName -> Bare.Lookup Ghc.TyCon+getDnTyCon env name dn = do+ tcMb <- Bare.lookupGhcDnTyCon env name "ofBDataDecl-1" dn+ case tcMb of+ Just tc -> return tc+ Nothing -> Left [ ErrBadData (GM.fSrcSpan dn) (pprint dn) "Unknown Type Constructor" ]+ -- ugh = impossible Nothing "getDnTyCon"+++-- FIXME: ES: why the maybes?+ofBDataDecl :: Bare.Env -> ModName -> Maybe DataDecl -> Maybe (LocSymbol, [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 = 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 tys = [t | dcp <- cts', (_, t) <- dcpTyArgs dcp]+ let varInfo = L.nub $ concatMap (getPsSig initmap True) tys+ let defPs = varSignToVariance varInfo <$> [0 .. (length πs - 1)]+ let (tvi, pvi) = case maybe_invariance_info of+ Nothing -> ([], defPs)+ Just (_,is) -> let is_n = drop n is in+ (take n is, if null is_n then defPs else is_n)+ let tcp = TyConP lc tc' αs πs tvi pvi sfun+ return ((name, tcp, Just (dd { tycDCons = cts }, pd)), Loc lc lc' <$> cts')+ where+ 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+ Left e -> Left e+ Right tc' -> Right ((name, TyConP srcpos tc' [] [] tcov tcontr Nothing, Nothing), [])+ where+ (tcov, tcontr) = (is, [])+ srcpos = F.dummyPos "LH.DataType.Variance"++ofBDataDecl _ _ Nothing Nothing+ = panic Nothing "Bare.DataType.ofBDataDecl called on invalid inputs"++-- TODO:EFFECTS:ofBDataCon+ofBDataCtor :: Bare.Env+ -> ModName+ -> F.SourcePos+ -> F.SourcePos+ -> Ghc.TyCon+ -> [RTyVar]+ -> [PVar BSort]+ -> [PVar RSort]+ -> DataCtor+ -> Bare.Lookup DataConP+ofBDataCtor env name l l' tc αs ps πs dc = do+ c' <- Bare.lookupGhcDataCon env name "ofBDataCtor" (dcName dc)+ return (ofBDataCtorTc env name l l' tc αs ps πs dc c')++ofBDataCtorTc :: Bare.Env -> ModName -> F.SourcePos -> F.SourcePos ->+ Ghc.TyCon -> [RTyVar] -> [PVar BSort] -> [PVar RSort] -> DataCtor -> Ghc.DataCon ->+ DataConP+ofBDataCtorTc env name l l' tc αs ps πs _ctor@(DataCtor _c as _ xts res) c' =+ DataConP+ { dcpLoc = l+ , dcpCon = c'+ , dcpFreeTyVars = RT.symbolRTyVar <$> as+ , dcpFreePred = πs+ , dcpTyConstrs = cs+ , dcpTyArgs = zts+ , dcpTyRes = ot+ , dcpIsGadt = isGadt+ , dcpModule = F.symbol name+ , dcpLocE = l'+ }+ where+ ts' = Bare.ofBareType env name l (Just ps) <$> ts+ res' = Bare.ofBareType env name l (Just ps) <$> res+ t0' = dataConResultTy c' αs t0 res'+ _cfg = getConfig env+ (yts, ot) = qualifyDataCtor (not isGadt) name dLoc (zip xs ts', 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 ]+ (xs, ts) = unzip xts+ t0 = case RT.famInstTyConType tc of+ 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)+ where+ v = pprint (val d)+ sp = GM.sourcePosSrcSpan (loc d)++varSignToVariance :: Eq a => [(a, Bool)] -> a -> Variance+varSignToVariance varsigns i = case filter (\p -> fst p == i) varsigns of+ [] -> Invariant+ [(_, b)] -> if b then Covariant else Contravariant+ _ -> Bivariant++getPsSig :: [(UsedPVar, a)] -> Bool -> SpecType -> [(a, Bool)]+getPsSig m pos (RAllT _ t r)+ = addps m pos r ++ getPsSig m pos t+getPsSig m pos (RApp _ ts rs r)+ = addps m pos r ++ concatMap (getPsSig m pos) ts+ ++ concatMap (getPsSigPs m pos) rs+getPsSig m pos (RVar _ r)+ = addps m pos r+getPsSig m pos (RAppTy t1 t2 r)+ = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2+getPsSig m pos (RFun _ _ t1 t2 r)+ = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1+getPsSig m pos (RHole r)+ = addps m pos r+getPsSig _ _ z+ = panic Nothing $ "getPsSig" ++ show z++getPsSigPs :: [(UsedPVar, a)] -> Bool -> SpecProp -> [(a, Bool)]+getPsSigPs m pos (RProp _ (RHole r)) = addps m pos r+getPsSigPs m pos (RProp _ t) = getPsSig m pos t++addps :: [(UsedPVar, a)] -> b -> UReft t -> [(a, b)]+addps m pos (MkUReft _ ps) = (, pos) . f <$> pvars ps+ where+ f = Mb.fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . RT.uPVar++keepPredType :: S.HashSet RTyVar -> SpecType -> Bool+keepPredType tvs p+ | Just (tv, _) <- eqSubst p = S.member tv tvs+ | otherwise = True+++-- | This computes the result of a `DataCon` application.+-- For 'isVanillaDataCon' we can just use the `TyCon`+-- applied to the relevant tyvars.+dataConResultTy :: Ghc.DataCon+ -> [RTyVar] -- ^ DataConP ty-vars+ -> SpecType -- ^ vanilla result type+ -> Maybe SpecType -- ^ user-provided result type+ -> SpecType+dataConResultTy c _ _ (Just t) = F.notracepp ("dataConResultTy-3 : vanilla = " ++ show (Ghc.isVanillaDataCon c) ++ " : ") t+dataConResultTy c _ t _+ | Ghc.isVanillaDataCon c = F.notracepp ("dataConResultTy-1 : " ++ F.showpp c) t+ | otherwise = F.notracepp ("dataConResultTy-2 : " ++ F.showpp c) $ RT.ofType ct+ where+ (_,_,_,_,_,ct) = Ghc.dataConFullSig c++eqSubst :: SpecType -> Maybe (RTyVar, SpecType)+eqSubst (RApp c [_, _, RVar a _, t] _ _)+ | rtc_tc c == Ghc.eqPrimTyCon = Just (a, t)+eqSubst _ = Nothing++normalizeField :: Ghc.DataCon -> Int -> (F.Symbol, a) -> (F.Symbol, 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)++checkRecordSelectorSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]+checkRecordSelectorSigs vts = [ (v, take1 v lspecTys) | (v, lspecTys) <- Misc.groupList vts ]+ where+ take1 v lsts = case Misc.nubHashOn (showpp . val) lsts of+ [t] -> t+ (t:ts) -> Ex.throw (ErrDupSpecs (GM.fSrcSpan t) (pprint v) (GM.fSrcSpan <$> ts) :: Error)+ _ -> impossible Nothing "checkRecordSelectorSigs"+++strengthenClassSel :: Ghc.Var -> LocSpecType -> LocSpecType+strengthenClassSel v lt = lt { val = st }+ where+ st = runReader (go (F.val lt)) (1, [])+ s = GM.namedLocSymbol v+ extend :: F.Symbol -> (Int, [F.Symbol]) -> (Int, [F.Symbol])+ extend x (i, xs) = (i + 1, x : xs)+ go :: SpecType -> Reader (Int, [F.Symbol]) SpecType+ go (RAllT a t r) = RAllT a <$> go t <*> pure r+ go (RAllP p t ) = RAllP p <$> go t+ go (RFun x i tx t r) | isEmbeddedClass tx =+ RFun x i tx <$> go t <*> pure r+ 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')+ go t = RT.strengthen t . singletonApp s . L.reverse <$> reader snd++singletonApp :: F.Symbolic a => F.LocSymbol -> [a] -> UReft F.Reft+singletonApp s ys = MkUReft r mempty+ where r = F.exprReft (F.mkEApp s (F.eVar <$> ys))+++unDummy :: F.Symbol -> Int -> F.Symbol+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+ where+ makeOne (Loc l l' dcp)+ | Just cls <- maybe_cls+ = let cfs = Ghc.classAllSelIds cls in+ fmap ((,) <$> fst <*> uncurry strengthenClassSel)+ [(v, Loc l l' t)| (v,t) <- zip cfs (reverse $ fmap snd args)]+ | null fls -- no field labels+ || any (isFunTy . snd) args && not (higherOrderFlag env) -- OR function-valued fields+ || dcpIsGadt dcp -- OR GADT style datcon+ = []+ | otherwise+ = [ (v, t) | (Just v, t) <- zip fs ts ]+ where+ maybe_cls = Ghc.tyConClass_maybe (Ghc.dataConTyCon dc)+ dc = dcpCon dcp+ fls = Ghc.dataConFieldLabels dc+ fs = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls+ ts :: [ LocSpecType ]+ ts = [ Loc l l' (mkArrow (map (, mempty) (makeRTVar <$> dcpFreeTyVars dcp)) []+ [(z, classRFInfo True, res, mempty)]+ (dropPreds (F.subst su t `RT.strengthen` mt)))+ | (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)))+ ]++ su = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ]+ args = dcpTyArgs dcp+ z = "lq$recSel"+ res = dropPreds (dcpTyRes dcp)++ -- FIXME: this is clearly imprecise, but the preds in the DataConP seem+ -- to be malformed. If we leave them in, tests/pos/kmp.hs fails with+ -- a malformed predicate application. Niki, help!!+ dropPreds = fmap (\(MkUReft r _ps) -> MkUReft r mempty)
+ src/Language/Haskell/Liquid/Bare/Elaborate.hs view
@@ -0,0 +1,717 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-orphans #-}++{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- TODO(#1913): Fix import of Data.Functor.Foldable.Fix+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- TODO(#1914): Is RTypeF even used?++-- | This module uses GHC API to elaborate the resolves expressions++-- TODO: Genearlize to BareType and replace the existing resolution mechanisms++module Language.Haskell.Liquid.Bare.Elaborate+ ( fixExprToHsExpr+ , elaborateSpecType+ -- , buildSimplifier+ )+where++import qualified Language.Fixpoint.Types as F+-- import Control.Arrow+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.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)+import Data.Functor.Foldable hiding (Fix)+#else+import Data.Functor.Foldable+#endif++import Data.Char ( isUpper )+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+-- that is generated in advance. This can greatly simplify the implementation+-- of elaboration++-- the substitution code is meant to inline dictionary functions+-- but does not seem to work+-- lookupIdSubstAll :: O.SDoc -> M.HashMap Id CoreExpr -> Id -> CoreExpr+-- lookupIdSubstAll doc env v | Just e <- M.lookup v env = e+-- | otherwise = Var v+-- -- Vital! See Note [Extending the Subst]+-- -- | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v+-- -- $$ ppr in_scope)++-- substExprAll :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr+-- substExprAll doc subst orig_expr = subst_expr_all doc subst orig_expr+++-- subst_expr_all :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr+-- subst_expr_all doc subst expr = go expr+-- where+-- go (Var v) = lookupIdSubstAll (doc O.$$ O.text "subst_expr_all") subst v+-- go (Type ty ) = Type ty+-- go (Coercion co ) = Coercion co+-- go (Lit lit ) = Lit lit+-- go (App fun arg ) = App (go fun) (go arg)+-- go (Tick tickish e ) = Tick tickish (go e)+-- go (Cast e co ) = Cast (go e) co+-- -- Do not optimise even identity coercions+-- -- Reason: substitution applies to the LHS of RULES, and+-- -- if you "optimise" an identity coercion, you may+-- -- lose a binder. We optimise the LHS of rules at+-- -- construction time++-- go (Lam bndr body) = Lam bndr (subst_expr_all doc subst body)++-- go (Let bind body) = Let (mapBnd go bind) (subst_expr_all doc subst body)++-- go (Case scrut bndr ty alts) =+-- Case (go scrut) bndr ty (map (go_alt subst) alts)++-- go_alt subst (con, bndrs, rhs) = (con, bndrs, subst_expr_all doc subst rhs)+++-- mapBnd :: (Expr b -> Expr b) -> Bind b -> Bind b+-- mapBnd f (NonRec b e) = NonRec b (f e)+-- mapBnd f (Rec bs ) = Rec (map (second f) bs)++-- -- substLet :: CoreExpr -> CoreExpr+-- -- substLet (Lam b body) = Lam b (substLet body)+-- -- substLet (Let b body)+-- -- | NonRec x e <- b = substLet+-- -- (substExprAll O.empty (extendIdSubst emptySubst x e) body)+-- -- | otherwise = Let b (substLet body)+-- -- substLet e = e+++-- buildDictSubst :: CoreProgram -> M.HashMap Id CoreExpr+-- buildDictSubst = cata f+-- where+-- f Nil = M.empty+-- f (Cons b s) | NonRec x e <- b, isDFunId x -- || isDictonaryId x+-- = M.insert x e s+-- | otherwise = s++-- buildSimplifier :: CoreProgram -> CoreExpr -> TcRn CoreExpr+-- buildSimplifier cbs e = pure e-- do+ -- df <- getDynFlags+ -- liftIO $ simplifyExpr (df `gopt_set` Opt_SuppressUnfoldings) e'+ -- where+ -- -- fvs = fmap (\x -> (x, getUnique x, isLocalId x)) (freeVars mempty e)+ -- dictSubst = buildDictSubst cbs+ -- e' = substExprAll O.empty dictSubst e+++-- | Base functor of RType+data RTypeF c tv r f+ = RVarF {+ rtf_var :: !tv+ , rtf_reft :: !r+ }++ | RFunF {+ rtf_bind :: !F.Symbol+ , rtf_rinfo :: !RFInfo+ , rtf_in :: !f+ , rtf_out :: !f+ , rtf_reft :: !r+ }+ | RAllTF {+ rtf_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ()))+ , rtf_ty :: !f+ , rtf_ref :: !r+ }++ -- | "forall x y <z :: Nat, w :: Int> . TYPE"+ -- ^^^^^^^^^^^^^^^^^^^ (rtf_pvbind)+ | RAllPF {+ rtf_pvbind :: !(PVU c tv) -- ar (RType c tv ()))+ , rtf_ty :: !f+ }++ -- | For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)+ -- * the `RProp` denoted by `{\h -> v > h}` to+ -- * the `RTyCon` denoted by `[]`.+ | RAppF {+ rtf_tycon :: !c+ , rtf_args :: ![f]+ , rtf_pargs :: ![RTPropF c tv f]+ , rtf_reft :: !r+ }++ | RAllEF {+ rtf_bind :: !F.Symbol+ , rtf_allarg :: !f+ , rtf_ty :: !f+ }++ | RExF {+ rtf_bind :: !F.Symbol+ , rtf_exarg :: !f+ , rtf_ty :: !f+ }++ | RExprArgF (F.Located F.Expr)++ | RAppTyF{+ rtf_arg :: !f+ , rtf_res :: !f+ , rtf_reft :: !r+ }++ | RRTyF {+ rtf_env :: ![(F.Symbol, f)]+ , rtf_ref :: !r+ , rtf_obl :: !Oblig+ , rtf_ty :: !f+ }++ | RHoleF r+ deriving (Functor)++-- It's probably ok to treat (RType c tv ()) as a leaf..+type RTPropF c tv f = Ref (RType c tv ()) f+++-- | SpecType with Holes.+-- It provides us a context to construct the ghc queries.+-- I don't think we can reuse RHole since it is not intended+-- for this use case++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++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+++-- specTypeToLHsType :: SpecType -> LHsType GhcPs+-- specTypeToLHsType = typeToLHsType . toType++-- -- Given types like x:a -> y:a -> _, this function returns x:a -> y:a -> Bool+-- -- Free monad takes care of substitution++-- A one-way function. Kind of like injecting something into Maybe+specTypeToPartial :: forall a . SpecType -> SpecTypeF (Free SpecTypeF a)+specTypeToPartial = hylo (fmap wrap) project++-- probably should return spectype instead..+plugType :: SpecType -> PartialSpecType -> SpecType+plugType t = refix . f+ where+ f = hylo Fix $ \case+ Pure _ -> specTypeToPartial t+ Free res -> res++-- build the expression we send to ghc for elaboration+-- YL: tweak this function to see if ghc accepts explicit dictionary binders+-- returning both expressions and binders since ghc adds unique id to the expressions++-- | 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')+ _ -> ([], [])++-- 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++++canonicalizeDictBinder+ :: F.Subable a => [F.Symbol] -> (a, [F.Symbol]) -> (a, [F.Symbol])+canonicalizeDictBinder [] (e', bs') = (e', bs')+canonicalizeDictBinder bs (e', [] ) = (e', bs)+canonicalizeDictBinder bs (e', bs') = (renameDictBinder bs bs' e', bs)+ where+ renameDictBinder :: (F.Subable a) => [F.Symbol] -> [F.Symbol] -> a -> a+ renameDictBinder [] _ = id+ renameDictBinder _ [] = id+ renameDictBinder canonicalDs ds = F.substa $ \x -> M.lookupDefault x x tbl+ where tbl = F.notracepp "TBL" $ M.fromList (zip ds canonicalDs)++elaborateSpecType+ :: (CoreExpr -> F.Expr)+ -> (CoreExpr -> TcRn CoreExpr)+ -> SpecType+ -> TcRn SpecType+elaborateSpecType coreToLogic simplifier t = GM.withWiredIn $ do+ (t', xs) <- elaborateSpecType' (pure ()) coreToLogic simplifier t+ case xs of+ _ : _ -> panic+ Nothing+ "elaborateSpecType: invariant broken. substitution list for dictionary is not completely consumed"+ _ -> pure t'++elaborateSpecType'+ :: PartialSpecType+ -> (CoreExpr -> F.Expr) -- core to logic+ -> (CoreExpr -> TcRn CoreExpr)+ -> SpecType+ -> TcRn (SpecType, [F.Symbol]) -- binders for dictionaries+ -- should have returned Maybe [F.Symbol]+elaborateSpecType' partialTp coreToLogic simplify t =+ case F.notracepp "elaborateSpecType'" t of+ RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do+ elaborateReft+ (reft, t)+ (pure (t, []))+ (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv, ee)) p), bs'))+ -- YL : Fix+ RFun bind i tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do+ -- the reft is never actually used by the child+ -- maybe i should enforce this information at the type level+ let partialFunTp =+ Free (RFunF bind i (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType+ partialTp' = partialTp >> partialFunTp :: PartialSpecType+ (eTin , bs ) <- elaborateSpecType' partialTp coreToLogic simplify tin+ (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic simplify tout+ let buildRFunContTrivial+ | isClassType tin, dictBinder : bs0' <- bs' = do+ let (eToutRenamed, canonicalBinders) =+ canonicalizeDictBinder bs (eTout, bs0')+ pure+ ( F.notracepp "RFunTrivial0"+ $ RFun dictBinder i eTin eToutRenamed ureft+ , canonicalBinders+ )+ | otherwise = do+ let (eToutRenamed, canonicalBinders) =+ canonicalizeDictBinder bs (eTout, bs')+ pure+ ( F.notracepp "RFunTrivial1" $ RFun bind i eTin eToutRenamed ureft+ , canonicalBinders+ )+ buildRFunCont bs'' ee+ | isClassType tin, dictBinder : bs0' <- bs' = do+ let (eToutRenamed, canonicalBinders) =+ canonicalizeDictBinder bs (eTout, bs0')+ (eeRenamed, canonicalBinders') =+ canonicalizeDictBinder canonicalBinders (ee, bs'')+ pure+ ( RFun dictBinder i+ eTin+ eToutRenamed+ (MkUReft (F.Reft (vv, eeRenamed)) p)+ , canonicalBinders'+ )+ | otherwise = do+ let (eToutRenamed, canonicalBinders) =+ canonicalizeDictBinder bs (eTout, bs')+ (eeRenamed, canonicalBinders') =+ canonicalizeDictBinder canonicalBinders (ee, bs'')+ pure+ ( RFun bind i+ eTin+ eToutRenamed+ (MkUReft (F.Reft (vv, eeRenamed)) p)+ , canonicalBinders'+ )+ elaborateReft (reft, t) buildRFunContTrivial buildRFunCont++ -- (\bs' ee | isClassType tin -> do+ -- let eeRenamed = renameDictBinder canonicalBinders bs' ee+ -- pure (RFun bind eTin eToutRenamed (MkUReft (F.Reft (vv, eeRenamed)) p), bs')+ -- )++ -- support for RankNTypes/ref+ RAllT (RTVar tv ty) tout ureft@(MkUReft ref@(F.Reft (vv, _oldE)) p) -> do+ (eTout, bs) <- elaborateSpecType'+ (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ureft))+ coreToLogic+ simplify+ tout+ elaborateReft+ (ref, RVar tv mempty)+ (pure (RAllT (RTVar tv ty) eTout ureft, bs))+ (\bs' ee ->+ let (eeRenamed, canonicalBinders) =+ canonicalizeDictBinder bs (ee, bs')+ in pure+ ( RAllT (RTVar tv ty) eTout (MkUReft (F.Reft (vv, eeRenamed)) p)+ , canonicalBinders+ )+ )+ -- pure (RAllT (RTVar tv ty) eTout ref, bts')+ -- todo: might as well print an error message?+ RAllP pvbind tout -> do+ (eTout, bts') <- elaborateSpecType'+ (partialTp >> Free (RAllPF pvbind (pure ())))+ coreToLogic+ simplify+ tout+ pure (RAllP pvbind eTout, bts')+ -- pargs not handled for now+ -- RApp tycon args pargs reft+ RApp tycon args pargs ureft@(MkUReft reft@(F.Reft (vv, _)) p)+ | isClass tycon -> pure (t, [])+ | otherwise -> do+ args' <- mapM+ (fmap fst . elaborateSpecType' partialTp coreToLogic simplify)+ args+ elaborateReft+ (reft, t)+ (pure (RApp tycon args' pargs ureft, []))+ (\bs' ee ->+ pure (RApp tycon args' pargs (MkUReft (F.Reft (vv, ee)) p), bs')+ )+ RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do+ (eArg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify arg+ (eRes, bs') <- elaborateSpecType' partialTp coreToLogic simplify res+ let (eResRenamed, canonicalBinders) =+ canonicalizeDictBinder bs (eRes, bs')+ elaborateReft+ (reft, t)+ (pure (RAppTy eArg eResRenamed ureft, canonicalBinders))+ (\bs'' ee ->+ let (eeRenamed, canonicalBinders') =+ canonicalizeDictBinder canonicalBinders (ee, bs'')+ in pure+ ( RAppTy eArg eResRenamed (MkUReft (F.Reft (vv, eeRenamed)) p)+ , canonicalBinders'+ )+ )+ -- todo: Existential support+ RAllE bind allarg ty -> do+ (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify allarg+ (eTy , bs') <- elaborateSpecType' partialTp coreToLogic simplify ty+ let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs')+ pure (RAllE bind eAllarg eTyRenamed, canonicalBinders)+ REx bind allarg ty -> do+ (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify allarg+ (eTy , bs') <- elaborateSpecType' partialTp coreToLogic simplify ty+ let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs')+ pure (REx bind eAllarg eTyRenamed, canonicalBinders)+ -- YL: might need to filter RExprArg out and replace RHole with ghc wildcard+ -- in the future+ RExprArg _ -> impossible Nothing "RExprArg should not appear here"+ 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+ elaborateReft+ :: (F.PPrint a)+ => (F.Reft, SpecType)+ -> TcRn a+ -> ([F.Symbol] -> F.Expr -> TcRn a)+ -> TcRn a+ elaborateReft (reft@(F.Reft (vv, e)), vvTy) trivial nonTrivialCont =+ if isTrivial' reft+ then trivial+ else do+ let+ querySpecType =+ plugType (rFun' (classRFInfo True) vv vvTy boolType) partialTp :: SpecType++ (origBinders, origTyBinders) = F.notracepp "collectSpecTypeBinders"+ $ collectSpecTypeBinders querySpecType++++ hsExpr =+ buildHsExpr (fixExprToHsExpr (S.fromList origBinders) e)+ querySpecType :: LHsExpr GhcPs+ exprWithTySigs = noLocA $ ExprWithTySig+ noAnn+ hsExpr+ (hsTypeToHsSigWcType (specTypeToLHsType querySpecType))+ eeWithLamsCore <- GM.elabRnExpr exprWithTySigs+ eeWithLamsCore' <- simplify eeWithLamsCore+ let+ (_, tyBinders) =+ collectSpecTypeBinders+ . ofType+ . exprType+ $ eeWithLamsCore'+ substTy' = zip tyBinders origTyBinders+ eeWithLams =+ coreToLogic (GM.notracePpr "eeWithLamsCore" eeWithLamsCore')+ (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams)+ (dictbs, nondictbs) =+ L.partition (F.isPrefixOfSym "$d") bs'+ -- invariant: length nondictbs == length origBinders+ subst = if length nondictbs == length origBinders+ then F.notracepp "SUBST" $ zip (L.reverse nondictbs) origBinders+ else panic+ Nothing+ "Oops, Ghc gave back more/less binders than I expected"+ ret <- nonTrivialCont+ dictbs+ ( renameBinderCoerc (\x -> Mb.fromMaybe x (L.lookup x substTy'))+ . F.substa (\x -> Mb.fromMaybe x (L.lookup x subst))+ $ F.notracepp+ ( "elaborated: subst "+ ++ F.showpp substTy'+ ++ " "+ ++ F.showpp+ (ofType $ exprType eeWithLamsCore' :: SpecType)+ )+ ee+ ) -- (GM.dropModuleUnique <$> bs')+ pure (F.notracepp "result" ret)+ -- (F.substa )+ isTrivial' :: F.Reft -> Bool+ isTrivial' (F.Reft (_, F.PTrue)) = True+ isTrivial' _ = False++ grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr)+ grabLams (bs, F.ELam (b, _) e) = grabLams (b : bs, e)+ grabLams bse = bse+ -- dropBinderUnique :: [F.Symbol] -> F.Expr -> F.Expr+ -- dropBinderUnique binders = F.notracepp "ElaboratedExpr"+ -- . F.substa (\x -> if L.elem x binders then GM.dropModuleUnique x else x)++renameBinderCoerc :: (F.Symbol -> F.Symbol) -> F.Expr -> F.Expr+renameBinderCoerc f = rename+ where+ renameSort = renameBinderSort f+ rename e'@(F.ESym _ ) = e'+ rename e'@(F.ECon _ ) = e'+ rename e'@(F.EVar _ ) = e'+ rename ( F.EApp e0 e1 ) = F.EApp (rename e0) (rename e1)+ rename ( F.ENeg e0 ) = F.ENeg (rename e0)+ rename ( F.EBin bop e0 e1 ) = F.EBin bop (rename e0) (rename e1)+ rename ( F.EIte e0 e1 e2 ) = F.EIte (rename e0) (rename e1) (rename e2)+ rename ( F.ECst e' t ) = F.ECst (rename e') (renameSort t)+ -- rename (F.ELam (x, t) e') = F.ELam (x, renameSort t) (rename e')+ rename ( F.PAnd es ) = F.PAnd (rename <$> es)+ rename ( F.POr es ) = F.POr (rename <$> es)+ rename ( F.PNot e' ) = F.PNot (rename e')+ rename ( F.PImp e0 e1 ) = F.PImp (rename e0) (rename e1)+ rename ( F.PIff e0 e1 ) = F.PIff (rename e0) (rename e1)+ rename ( F.PAtom brel e0 e1) = F.PAtom brel (rename e0) (rename e1)+ rename (F.ECoerc _ _ e') = rename e'++ rename e = panic+ Nothing+ ("renameBinderCoerc: Not sure how to handle the expression " ++ F.showpp e)++++renameBinderSort :: (F.Symbol -> F.Symbol) -> F.Sort -> F.Sort+renameBinderSort f = rename+ where+ rename F.FInt = F.FInt+ rename F.FReal = F.FReal+ rename F.FNum = F.FNum+ rename F.FFrac = F.FFrac+ rename ( F.FObj s ) = F.FObj (f s)+ rename t'@(F.FVar _ ) = t'+ rename ( F.FFunc t0 t1) = F.FFunc (rename t0) (rename t1)+ rename ( F.FAbs x t') = F.FAbs x (rename t')+ rename t'@(F.FTC _ ) = t'+ rename ( F.FApp t0 t1 ) = F.FApp (rename t0) (rename t1)+++mkHsTyConApp :: IdP GhcPs -> [LHsType GhcPs] -> LHsType GhcPs+mkHsTyConApp tyconId tyargs = nlHsTyConApp Prefix tyconId (map HsValArg 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)+fixExprToHsExpr :: S.HashSet F.Symbol -> F.Expr -> LHsExpr GhcPs+fixExprToHsExpr _ (F.ECon c) = constantToHsExpr c+fixExprToHsExpr env (F.EVar x)+ | x == "GHC.Types.[]" = GM.notracePpr "Empty" $ nlHsVar (mkVarUnqual (mkFastString "[]"))+ | x == "GHC.Types.:" = GM.notracePpr "Cons" $ nlHsVar (mkVarUnqual (mkFastString ":"))+ | otherwise = GM.notracePpr "Var" $ nlHsVar (symbolToRdrName env x)+fixExprToHsExpr env (F.EApp e0 e1) =+ mkHsApp (fixExprToHsExpr env e0) (fixExprToHsExpr env e1)+fixExprToHsExpr env (F.ENeg e) =+ mkHsApp (nlHsVar (nameRdrName negateName)) (fixExprToHsExpr env e)++fixExprToHsExpr env (F.EBin bop e0 e1) = mkHsApp+ (mkHsApp (bopToHsExpr bop) (fixExprToHsExpr env e0))+ (fixExprToHsExpr env e1)+fixExprToHsExpr env (F.EIte p e0 e1) = nlHsIf (fixExprToHsExpr env p)+ (fixExprToHsExpr env e0)+ (fixExprToHsExpr env e1)++-- FIXME: convert sort to HsType+-- This is currently not doable because how do we know if FInt corresponds to+-- Int or Integer?+fixExprToHsExpr env (F.ECst e0 _ ) = fixExprToHsExpr env e0+-- fixExprToHsExpr env (F.PAnd [] ) = nlHsVar true_RDR+fixExprToHsExpr _ (F.PAnd [] ) = nlHsVar true_RDR+fixExprToHsExpr env (F.PAnd (e : es)) = L.foldr f (fixExprToHsExpr env e) es+ where+ f x acc = mkHsApp (mkHsApp (nlHsVar and_RDR) (fixExprToHsExpr env x)) acc++-- This would work in the latest commit+-- fixExprToHsExpr env (F.PAnd es ) = mkHsApp+-- (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "and")))+-- (nlList $ fixExprToHsExpr env <$> es)+fixExprToHsExpr env (F.POr es) = mkHsApp+ (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "or")))+ (nlList $ fixExprToHsExpr env <$> es)+fixExprToHsExpr env (F.PIff e0 e1) = mkHsApp+ (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "<=>"))) (fixExprToHsExpr env e0)+ )+ (fixExprToHsExpr env e1)+fixExprToHsExpr env (F.PNot e) =+ mkHsApp (nlHsVar not_RDR) (fixExprToHsExpr env e)+fixExprToHsExpr env (F.PAtom brel e0 e1) = mkHsApp+ (mkHsApp (brelToHsExpr brel) (fixExprToHsExpr env e0))+ (fixExprToHsExpr env e1)+fixExprToHsExpr env (F.PImp e0 e1) = mkHsApp+ (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "==>"))) (fixExprToHsExpr env e0)+ )+ (fixExprToHsExpr env e1)++fixExprToHsExpr _ e =+ todo Nothing ("toGhcExpr: Don't know how to handle " ++ show e)++constantToHsExpr :: F.Constant -> LHsExpr GhcPs+-- constantToHsExpr (F.I c) = noLoc (HsLit NoExt (HsInt NoExt (mkIntegralLit c)))+constantToHsExpr (F.I i) =+ noLocA (HsOverLit noAnn (mkHsIntegral (mkIntegralLit i)))+constantToHsExpr (F.R d) =+ noLocA (HsOverLit noAnn (mkHsFractional (mkTHFractionalLit (toRational d))))+constantToHsExpr _ =+ todo Nothing "constantToHsExpr: Not sure how to handle constructor L"++-- This probably won't work because of the qualifiers+bopToHsExpr :: F.Bop -> LHsExpr GhcPs+bopToHsExpr bop = noLocA (HsVar Ghc.noExtField (noLocA (f bop)))+ where+ f F.Plus = plus_RDR+ f F.Minus = minus_RDR+ f F.Times = times_RDR+ f F.Div = mkVarUnqual (fsLit "/")+ f F.Mod = GM.prependGHCRealQual (fsLit "mod")+ f F.RTimes = times_RDR+ f F.RDiv = GM.prependGHCRealQual (fsLit "/")++brelToHsExpr :: F.Brel -> LHsExpr GhcPs+brelToHsExpr brel = noLocA (HsVar Ghc.noExtField (noLocA (f brel)))+ where+ f F.Eq = mkVarUnqual (mkFastString "==")+ f F.Gt = gt_RDR+ f F.Lt = lt_RDR+ f F.Ge = ge_RDR+ f F.Le = le_RDR+ f F.Ne = mkVarUnqual (mkFastString "/=")+ f _ = impossible Nothing "brelToExpr: Unsupported operation"++symbolToRdrNameNs :: NameSpace -> F.Symbol -> RdrName+symbolToRdrNameNs ns x+ | F.isNonSymbol modName = mkUnqual ns (mkFastString (F.symbolString s))+ | otherwise = mkQual+ ns+ (mkFastString (F.symbolString modName), mkFastString (F.symbolString s))+ where (modName, s) = GM.splitModuleName x+++varSymbolToRdrName :: F.Symbol -> RdrName+varSymbolToRdrName = symbolToRdrNameNs varName+++-- don't use this function...+symbolToRdrName :: S.HashSet F.Symbol -> F.Symbol -> RdrName+symbolToRdrName env x+ | F.isNonSymbol modName = mkUnqual ns (mkFastString (F.symbolString s))+ | otherwise = mkQual+ ns+ (mkFastString (F.symbolString modName), mkFastString (F.symbolString s))+ where+ (modName, s) = GM.splitModuleName x+ ns | not (S.member x env), Just (c, _) <- F.unconsSym s, isUpper c = dataName+ | otherwise = varName+++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+ -- (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 (Just (noLocA [tin'])) tout+ | otherwise -> nlHsFunTy tin' tout+ RAllTF (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+ (getRdrName tc)+ [ hst | (t, hst) <- ts, notExprArg t ]+ where+ notExprArg (RExprArg _) = False+ notExprArg _ = True+ RAllEF _ (_, tin) (_, tout) -> nlHsFunTy tin tout+ RExF _ (_, tin) (_, tout) -> nlHsFunTy tin tout+ -- impossible+ RAppTyF _ (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 _ ->+ todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg"
+ src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -0,0 +1,842 @@+-- | This module has the code for applying refinement (and) type aliases+-- and the pipeline for "cooking" a @BareType@ into a @SpecType@.+-- TODO: _only_ export `makeRTEnv`, `cookSpecType` and maybe `qualifyExpand`...++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.Bare.Expand+ ( -- * Create alias expansion environment+ makeRTEnv++ -- * Expand and Qualify+ , qualifyExpand++ -- * Converting BareType to SpecType+ , cookSpecType+ , cookSpecTypeE+ , specExpandType++ -- * Re-exported for data-constructors+ , plugHoles+ ) where++import Prelude hiding (error)+import Data.Graph hiding (Graph)+import Data.Maybe++import Control.Monad+import Control.Monad.State+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 qualified Language.Haskell.Liquid.GHC.Misc as GM+import qualified Liquid.GHC.API as Ghc+import qualified Language.Haskell.Liquid.Types.RefType as RT+import Language.Haskell.Liquid.Types hiding (fresh)+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++--------------------------------------------------------------------------------+-- | `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 env modName mySpec iSpecs 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 ]+ ++ 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)+ , let e = lmapEAlias xl ]+ specs = (modName, mySpec) : M.toList iSpecs++-- | We apply @renameRTArgs@ *after* expanding each alias-definition, to+-- ensure that the substitutions work properly (i.e. don't miss expressions+-- hidden inside @RExprArg@ or as strange type parameters.+renameRTArgs :: BareRTEnv -> BareRTEnv+renameRTArgs rte = RTE+ { typeAliases = M.map (fmap (renameTys . renameVV . renameRTVArgs)) (typeAliases rte)+ , exprAliases = M.map (fmap renameRTVArgs) (exprAliases rte)+ }++makeREAliases :: [Located (RTAlias F.Symbol F.Expr)] -> BareRTEnv+makeREAliases = graphExpand buildExprEdges f mempty+ where+ f rtEnv xt = setREAlias rtEnv (expandLoc rtEnv xt)+++-- | @renameTys@ ensures that @RTAlias@ type parameters have distinct names+-- to avoid variable capture e.g. as in T1556.hs+renameTys :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType+renameTys rt = rt { rtTArgs = ys, rtBody = sbts (rtBody rt) (zip xs ys) }+ where+ xs = rtTArgs rt+ ys = (`F.suffixSymbol` rtName rt) <$> xs+ sbts = foldl (flip subt)+++renameVV :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType+renameVV rt = rt { rtBody = RT.shiftVV (rtBody rt) (F.vv (Just 0)) }++-- | @renameRTVArgs@ ensures that @RTAlias@ value parameters have distinct names+-- to avoid variable capture e.g. as in tests-names-pos-Capture01.hs+renameRTVArgs :: (F.PPrint a, F.Subable a) => RTAlias x a -> RTAlias x a+renameRTVArgs rt = rt { rtVArgs = newArgs+ , rtBody = F.notracepp msg $ F.subst su (rtBody rt)+ }+ where+ msg = "renameRTVArgs: " ++ F.showpp su+ su = F.mkSubst (zip oldArgs (F.eVar <$> newArgs))+ newArgs = zipWith rtArg (rtVArgs rt) [(0::Int)..]+ oldArgs = rtVArgs rt+ rtArg x i = F.suffixSymbol x (F.intSymbol "rta" i)++makeRTAliases :: [Located (RTAlias F.Symbol BareType)] -> BareRTEnv -> BareRTEnv+makeRTAliases lxts rte = graphExpand buildTypeEdges f rte lxts+ 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)+ => (AliasTable x t -> t -> [F.Symbol]) -- ^ dependencies+ -> (thing -> Located (RTAlias x t) -> thing) -- ^ update+ -> thing -- ^ initial+ -> [Located (RTAlias x t)] -- ^ vertices+ -> thing -- ^ final+graphExpand buildEdges expBody env lxts+ = L.foldl' expBody env (genExpandOrder table' graph)+ where+ -- xts = val <$> lxts+ table = buildAliasTable lxts+ graph = buildAliasGraph (buildEdges table) lxts+ table' = checkCyclicAliases table graph++setRTAlias :: RTEnv x t -> Located (RTAlias x t) -> RTEnv x t+setRTAlias env a = env { typeAliases = M.insert n a (typeAliases env) }+ where+ n = rtName (val a)++setREAlias :: RTEnv x t -> Located (RTAlias F.Symbol F.Expr) -> RTEnv x t+setREAlias env a = env { exprAliases = M.insert n a (exprAliases env) }+ where+ n = rtName (val a)++++--------------------------------------------------------------------------------+type AliasTable x t = M.HashMap F.Symbol (Located (RTAlias x t))++buildAliasTable :: [Located (RTAlias x t)] -> AliasTable x t+buildAliasTable = M.fromList . map (\rta -> (rtName (val rta), rta))++fromAliasSymbol :: AliasTable x t -> F.Symbol -> Located (RTAlias x t)+fromAliasSymbol table sym+ = fromMaybe err (M.lookup sym table)+ where+ err = panic Nothing ("fromAliasSymbol: Dangling alias symbol: " ++ show sym)++type Graph t = [Node t]+type Node t = (t, t, [t])++buildAliasGraph :: (PPrint t) => (t -> [F.Symbol]) -> [Located (RTAlias x t)]+ -> Graph F.Symbol+buildAliasGraph buildEdges = map (buildAliasNode buildEdges)++buildAliasNode :: (PPrint t) => (t -> [F.Symbol]) -> Located (RTAlias x t)+ -> Node F.Symbol+buildAliasNode f la = (rtName a, rtName a, f (rtBody a))+ where+ a = val la++checkCyclicAliases :: AliasTable x t -> Graph F.Symbol -> AliasTable x t+checkCyclicAliases table graph+ = case mapMaybe go (stronglyConnComp graph) of+ [] -> table+ sccs -> Ex.throw (cycleAliasErr table <$> sccs)+ where+ go (CyclicSCC vs) = Just vs+ go (AcyclicSCC _) = Nothing++cycleAliasErr :: AliasTable x t -> [F.Symbol] -> Error+cycleAliasErr _ [] = panic Nothing "checkCyclicAliases: No type aliases in reported cycle"+cycleAliasErr t symList@(rta:_) = ErrAliasCycle { pos = fst (locate rta)+ , acycle = map locate symList }+ where+ locate sym = ( GM.fSrcSpan $ fromAliasSymbol t sym+ , pprint sym )+++genExpandOrder :: AliasTable x t -> Graph F.Symbol -> [Located (RTAlias x t)]+genExpandOrder table graph+ = map (fromAliasSymbol table) symOrder+ where+ (digraph, lookupVertex, _)+ = graphFromEdges graph+ symOrder+ = map (Misc.fst3 . lookupVertex) $ reverse $ topSort digraph++--------------------------------------------------------------------------------++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 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 (RFun _ _ t1 t2 _) = go t1 ++ go t2+ go (RAppTy t1 t2 _) = go t1 ++ go t2+ go (RAllE _ t1 t2) = go t1 ++ go t2+ go (REx _ t1 t2) = go t1 ++ go t2+ go (RAllT _ t _) = go t+ go (RAllP _ t) = go t+ go (RVar _ _) = []+ go (RExprArg _) = []+ go (RHole _) = []+ go (RRTy env _ _ t) = concatMap (go . snd) env ++ go t+ go_alias c = [c | M.member c table]+ go_ref (RProp _ (RHole _)) = Nothing+ go_ref (RProp _ t) = Just t++buildExprEdges :: M.HashMap F.Symbol a -> F.Expr -> [F.Symbol]+buildExprEdges table = ordNub . go+ where+ go :: F.Expr -> [F.Symbol]+ go (EApp e1 e2) = go e1 ++ go e2+ go (ENeg e) = go e+ go (EBin _ e1 e2) = go e1 ++ go e2+ go (EIte _ e1 e2) = go e1 ++ go e2+ go (ECst e _) = go e+ go (ESym _) = []+ go (ECon _) = []+ go (EVar v) = go_alias v+ go (PAnd ps) = concatMap go ps+ go (POr ps) = concatMap go ps+ go (PNot p) = go p+ go (PImp p q) = go p ++ go q+ go (PIff p q) = go p ++ go q+ go (PAll _ p) = go p+ go (ELam _ e) = go e+ go (ECoerc _ _ e) = go e+ go (PAtom _ e1 e2) = go e1 ++ go e2+ go (ETApp e _) = go e+ go (ETAbs e _) = go e+ go (PKVar _ _) = []+ go (PExist _ e) = go e+ go (PGrad _ _ _ e) = go e+ go_alias f = [f | M.member f table ]+++----------------------------------------------------------------------------------+-- | Using the `BareRTEnv` to do alias-expansion+----------------------------------------------------------------------------------+class Expand a where+ 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++instance Expand Expr where+ expand = expandExpr++instance Expand F.Reft where+ expand rtEnv l (F.Reft (v, ra)) = F.Reft (v, expand rtEnv l ra)++instance Expand RReft where+ expand rtEnv l = fmap (expand rtEnv l)++expandReft :: (Expand r) => BareRTEnv -> F.SourcePos -> RType c tv r -> RType c tv r+expandReft rtEnv l = fmap (expand rtEnv l)+-- expandReft rtEnv l = emapReft (expand rtEnv l)+++-- | @expand@ on a SpecType simply expands the refinements,+-- i.e. *does not* apply the type aliases, but just the+-- 1. predicate aliases,+-- 2. inlines,+-- 3. stuff from @LogicMap@++instance Expand SpecType where+ expand = expandReft++-- | @expand@ on a BareType actually applies the type- and expression- aliases.+instance Expand BareType where+ expand rtEnv l+ = expandReft rtEnv l -- apply expression aliases+ . expandBareType rtEnv l -- apply type aliases++instance Expand (RTAlias F.Symbol Expr) where+ expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) }++instance Expand BareRTAlias where+ expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) }++instance Expand Body where+ expand rtEnv l (P p) = P (expand rtEnv l p)+ expand rtEnv l (E e) = E (expand rtEnv l e)+ expand rtEnv l (R x p) = R x (expand rtEnv l p)++instance Expand DataCtor where+ expand rtEnv l c = c+ { dcTheta = expand rtEnv l (dcTheta c)+ , dcFields = [(x, expand rtEnv l t) | (x, t) <- dcFields c ]+ , dcResult = expand rtEnv l (dcResult c)+ }++instance Expand DataDecl where+ expand rtEnv l d = d+ { tycDCons = expand rtEnv l (tycDCons d)+ , tycPropTy = expand rtEnv l (tycPropTy d)+ }++instance Expand BareMeasure where+ expand rtEnv l m = m+ { msSort = expand rtEnv l (msSort m)+ , msEqns = expand rtEnv l (msEqns m)+ }++instance Expand BareDef where+ expand rtEnv l d = d+ { dsort = expand rtEnv l (dsort d)+ , binds = [ (x, expand rtEnv l t) | (x, t) <- binds d]+ , body = expand rtEnv l (body d)+ }++instance Expand Ms.BareSpec where+ expand = expandBareSpec++instance Expand a => Expand (F.Located a) where+ expand rtEnv _ = expandLoc rtEnv++instance Expand a => Expand (F.LocSymbol, a) where+ expand rtEnv l (x, y) = (x, expand rtEnv l y)++instance Expand a => Expand (Maybe a) where+ expand rtEnv l = fmap (expand rtEnv l)++instance Expand a => Expand [a] where+ expand rtEnv l = fmap (expand rtEnv l)++instance Expand a => Expand (M.HashMap k a) where+ expand rtEnv l = fmap (expand rtEnv l)++-- | Expands a 'BareSpec'.+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)+ , ialiases = [ (f x, f y) | (x, y) <- ialiases sp ]+ , dataDecls = expand rtEnv l (dataDecls sp)+ , newtyDecls = expand rtEnv l (newtyDecls sp)+ }+ where f = expand rtEnv l++expandBareType :: BareRTEnv -> F.SourcePos -> BareType -> BareType+expandBareType rtEnv _ = go+ where+ go (RApp c ts rs r) = case lookupRTEnv c rtEnv of+ Just rta -> expandRTAliasApp (GM.fSourcePos c) rta (go <$> ts) r+ Nothing -> RApp c (go <$> ts) (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)++lookupRTEnv :: BTyCon -> BareRTEnv -> Maybe (Located BareRTAlias)+lookupRTEnv c rtEnv = M.lookup (F.symbol c) (typeAliases rtEnv)++expandRTAliasApp :: F.SourcePos -> Located BareRTAlias -> [BareType] -> RReft -> BareType+expandRTAliasApp l (Loc la _ rta) args r = case isOK of+ Just e -> Ex.throw e+ Nothing -> F.subst esu . (`RT.strengthen` r) . RT.subsTyVarsMeet tsu $ rtBody rta+ where+ tsu = zipWith (\α t -> (α, toRSort t, t)) αs ts+ esu = F.mkSubst $ zip (F.symbol <$> εs) es+ es = exprArg l msg <$> es0+ (ts, es0) = splitAt nαs args+ (αs, εs) = (BTV <$> rtTArgs rta, rtVArgs rta)+ targs = takeWhile (not . isRExprArg) args+ eargs = dropWhile (not . isRExprArg) args++ -- ERROR Checking Code+ msg = "EXPAND-RTALIAS-APP: " ++ F.showpp (rtName rta)+ nαs = length αs+ nεs = length εs+ nargs = length args+ ntargs = length targs+ neargs = length eargs+ err = errRTAliasApp l la rta+ isOK :: Maybe Error+ isOK+ | nargs /= ntargs + neargs+ = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and then", pprint nεs, "expression arguments, but is given", pprint nargs]+ | nargs /= nαs + nεs+ = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and" , pprint nεs, "expression arguments, but is given", pprint nargs]+ | nαs /= ntargs, not (null eargs)+ = err $ PJ.hsep ["Expects", pprint nαs, "type arguments before expression arguments"]+ | otherwise+ = Nothing++isRExprArg :: RType c tv r -> Bool+isRExprArg (RExprArg _) = True+isRExprArg _ = False++errRTAliasApp :: F.SourcePos -> F.SourcePos -> BareRTAlias -> PJ.Doc -> Maybe Error+errRTAliasApp l la rta = Just . ErrAliasApp sp name sp'+ where+ name = pprint (rtName rta)+ sp = GM.sourcePosSrcSpan l+ 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+-- details of each of the individual steps.+----------------------------------------------------------------------------------------+cookSpecType :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType+ -> LocSpecType+cookSpecType env sigEnv name x bt+ = either Ex.throw id (cookSpecTypeE env sigEnv name x bt)+ where+ _msg = "cookSpecType: " ++ GM.showPpr (z, Ghc.varType <$> z)+ z = Bare.plugSrc x+++-----------------------------------------------------------------------------------------+cookSpecTypeE :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType+ -> Bare.Lookup LocSpecType+-----------------------------------------------------------------------------------------+cookSpecTypeE env sigEnv name@(ModName _ _) x bt+ = fmap f . bareSpecType env name $ bareExpandType rtEnv bt+ where+ f = (if doplug || not allowTC then plugHoles allowTC sigEnv name x else id)+ . fmap (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+ doplug+ | Bare.LqTV v <- x+ , GM.isMethod v || GM.isSCSel v+ , not (isTarget name)+ = False+ | otherwise+ = True+ _msg i = "cook-" ++ show i ++ " : " ++ F.showpp x+ 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++generalizeWith :: Bare.PlugTV Ghc.Var -> SpecType -> SpecType+generalizeWith (Bare.HsTV v) t = generalizeVar v t+generalizeWith Bare.RawTV t = t+generalizeWith _ t = RT.generalize t++generalizeVar :: Ghc.Var -> SpecType -> SpecType+generalizeVar v t = mkUnivs (zip as (repeat mempty)) [] t+ where+ as = filter isGen (freeTyVars t)+ (vas,_) = Ghc.splitForAllTyCoVars (GM.expandVarType v)+ isGen (RTVar (RTV a) _) = a `elem` vas++-- splitForAllTyCoVars :: Type -> ([TyVar], Type)+--+-- generalize :: (Eq tv) => RType c tv r -> RType c tv r+-- generalize t = mkUnivs (freeTyVars t) [] [] t+++bareExpandType :: BareRTEnv -> LocBareType -> LocBareType+bareExpandType = expandLoc++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+ Left e -> Left e+ Right t -> Right (F.atLoc bt t)++maybePlug :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType+maybePlug allowTC sigEnv name kx = case Bare.plugSrc kx of+ Nothing -> id+ Just _ -> plugHoles allowTC sigEnv name kx++plugHoles :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType+plugHoles allowTC sigEnv name = Bare.makePluggedSig allowTC name embs tyi exports+ where+ embs = Bare.sigEmbs sigEnv+ tyi = Bare.sigTyRTyMap sigEnv+ exports = Bare.sigExports sigEnv++{- [NOTE:Cooking-SpecType]+ A @SpecType@ is _raw_ when it is obtained directly from a @BareType@, i.e.+ just by replacing all the @BTyCon@ with @RTyCon@. Before it can be used+ for constraint generation, we need to _cook_ it via the following transforms:++ A @SigEnv@ should contain _all_ the information needed to do the below steps.++ - expand : resolving all type/refinement etc. aliases+ - ofType : convert BareType -> SpecType+ - plugged : filling in any remaining "holes"+ - txRefSort : filling in the abstract-refinement predicates etc. (YUCK)+ - resolve : renaming / qualifying symbols?+ - expand (again) : as the "resolve" step can rename variables to trigger more aliases (e.g. member -> Data.Set.Internal.Member -> Set_mem)+ - generalize : (universally) quantify free type variables+ - strengthen-measures : ?+ - strengthen-inline(?) : ?++-}++-----------------------------------------------------------------------------------------------+-- | From BareOLD.Expand+-----------------------------------------------------------------------------------------------+++{- TODO-REBARE+instance Expand ty => Expand (Def ty ctor) where+ expand z (Def f xts c t bxts b) =+ Def f <$> expand z xts+ <*> pure c+ <*> expand z t+ <*> expand z bxts+ <*> expand z b++instance Expand ty => Expand (Measure ty ctor) where+ expand z (M n t ds k) =+ M n <$> expand z t <*> expand z ds <*> pure k++instance Expand DataConP where+ expand z d = do+ tyRes' <- expand z (tyRes d)+ tyConsts' <- expand z (tyConstrs d)+ tyArgs' <- expand z (tyArgs d)+ return d { tyRes = tyRes', tyConstrs = tyConsts', tyArgs = tyArgs' }+-}++--------------------------------------------------------------------------------+-- | @expandExpr@ applies the aliases and inlines in @BareRTEnv@ to its argument+-- @Expr@. It must first @resolve@ the symbols in the refinement to see if+-- they correspond to alias definitions. However, we ensure that we do not+-- resolve bound variables (e.g. those bound in output refinements by input+-- parameters), and we use the @bs@ parameter to pass in the bound symbols.+--------------------------------------------------------------------------------+expandExpr :: BareRTEnv -> F.SourcePos -> Expr -> Expr+expandExpr rtEnv l = go+ where+ go e@(EApp _ _) = expandEApp rtEnv l (F.splitEApp e)+ go (EVar x) = expandSym rtEnv l x+ go (ENeg e) = ENeg (go e)+ go (ECst e s) = ECst (go e) s+ go (PAnd ps) = PAnd (go <$> ps)+ go (POr ps) = POr (go <$> ps)+ go (PNot p) = PNot (go p)+ go (PAll xs p) = PAll xs (go p)+ go (PExist xs p) = PExist xs (go p)+ go (ELam xt e) = ELam xt (go e)+ go (ECoerc a t e) = ECoerc a t (go e)+ go (ETApp e s) = ETApp (go e) s+ go (ETAbs e s) = ETAbs (go e) s+ go (EBin op e1 e2) = EBin op (go e1) (go e2)+ go (PImp e1 e2) = PImp (go e1) (go e2)+ go (PIff e1 e2) = PIff (go e1) (go e2)+ go (PAtom b e1 e2) = PAtom b (go e1) (go e2)+ go (EIte p e1 e2) = EIte (go p)(go e1) (go e2)+ go (PGrad k su i e) = PGrad k su i (go e)+ go e@(PKVar _ _) = e+ go e@(ESym _) = e+ go e@(ECon _) = e++expandSym :: BareRTEnv -> F.SourcePos -> F.Symbol -> Expr+expandSym rtEnv l s' = expandEApp rtEnv l (EVar s', [])++-- REBARE :: expandSym' :: Symbol -> BareM Symbol+-- REBARE :: expandSym' s = do+ -- REBARE :: axs <- gets axSyms+ -- REBARE :: let s' = dropModuleNamesAndUnique s+ -- REBARE :: return $ if M.member s' axs then s' else s++expandEApp :: BareRTEnv -> F.SourcePos -> (Expr, [Expr]) -> Expr+expandEApp rtEnv l (EVar f, es) = case mBody of+ Just re -> expandApp l re es'+ Nothing -> F.eApps (EVar f) es'+ where+ eAs = exprAliases rtEnv+ mBody = M.lookup f eAs `mplus` M.lookup (GM.dropModuleUnique f) eAs+ es' = expandExpr rtEnv l <$> es+ _f0 = GM.dropModuleNamesAndUnique f++expandEApp _ _ (f, es) = F.eApps f es++--------------------------------------------------------------------------------+-- | Expand Alias Application --------------------------------------------------+--------------------------------------------------------------------------------+expandApp :: F.Subable ty => F.SourcePos -> Located (RTAlias F.Symbol ty) -> [Expr] -> ty+expandApp l lre es+ | Just su <- args = F.subst su (rtBody re)+ | otherwise = Ex.throw err+ where+ re = F.val lre+ args = F.mkSubst <$> Misc.zipMaybe (rtVArgs re) es+ err :: UserError+ err = ErrAliasApp sp alias sp' msg+ sp = GM.sourcePosSrcSpan l+ alias = pprint (rtName re)+ sp' = GM.fSrcSpan lre -- sourcePosSrcSpan (rtPos re)+ msg = "expects" PJ.<+> pprint (length $ rtVArgs re)+ PJ.<+> "arguments but it is given"+ PJ.<+> pprint (length es)+++-------------------------------------------------------------------------------+-- | Replace Predicate Arguments With Existentials ----------------------------+-------------------------------------------------------------------------------+txExpToBind :: SpecType -> SpecType+-------------------------------------------------------------------------------+txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)+ where+ πs = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]++data ExSt = ExSt { fresh :: Int+ , emap :: M.HashMap F.Symbol (RSort, F.Expr)+ , pmap :: M.HashMap F.Symbol RPVar+ }++-- | TODO: Niki please write more documentation for this, maybe an example?+-- I can't really tell whats going on... (RJ)++expToBindT :: SpecType -> State ExSt SpecType+expToBindT (RVar v r)+ = expToBindRef r >>= addExists . RVar v+expToBindT (RFun x i t1 t2 r)+ = do t1' <- expToBindT t1+ t2' <- expToBindT t2+ expToBindRef r >>= addExists . RFun x i t1' t2'+expToBindT (RAllT a t r)+ = do t' <- expToBindT t+ expToBindRef r >>= addExists . RAllT a t'+expToBindT (RAllP p t)+ = fmap (RAllP p) (expToBindT t)+expToBindT (RApp c ts rs r)+ = do ts' <- mapM expToBindT ts+ rs' <- mapM expToBindReft rs+ expToBindRef r >>= addExists . RApp c ts' rs'+expToBindT (RAppTy t1 t2 r)+ = do t1' <- expToBindT t1+ t2' <- expToBindT t2+ expToBindRef r >>= addExists . RAppTy t1' t2'+expToBindT (RRTy xts r o t)+ = do xts' <- zip xs <$> mapM expToBindT ts+ r' <- expToBindRef r+ t' <- expToBindT t+ return $ RRTy xts' r' o t'+ where+ (xs, ts) = unzip xts+expToBindT t+ = return t++expToBindReft :: SpecProp -> State ExSt SpecProp+expToBindReft (RProp s (RHole r)) = rPropP s <$> expToBindRef r+expToBindReft (RProp s t) = RProp s <$> expToBindT t+++getBinds :: State ExSt (M.HashMap F.Symbol (RSort, F.Expr))+getBinds+ = do bds <- gets emap+ modify $ \st -> st{emap = M.empty}+ return bds++addExists :: SpecType -> State ExSt SpecType+addExists t = fmap (M.foldlWithKey' addExist t) getBinds++addExist :: SpecType -> F.Symbol -> (RSort, F.Expr) -> SpecType+addExist t x (tx, e) = REx x t' t+ where+ t' = ofRSort tx `strengthen` uTop r+ r = F.exprReft e++expToBindRef :: UReft r -> State ExSt (UReft r)+expToBindRef (MkUReft r (Pr p))+ = mapM expToBind p <&> (MkUReft r . Pr)++expToBind :: UsedPVar -> State ExSt UsedPVar+expToBind p = do+ res <- gets (M.lookup (pname p) . pmap)+ case res of+ Nothing ->+ panic Nothing ("expToBind: " ++ show p)+ Just π -> do+ let pargs0 = zip (pargs p) (Misc.fst3 <$> pargs π)+ pargs' <- mapM expToBindParg pargs0+ return $ p { pargs = pargs' }++expToBindParg :: (((), F.Symbol, F.Expr), RSort) -> State ExSt ((), F.Symbol, F.Expr)+expToBindParg ((t, s, e), s') = fmap ((,,) t s) (expToBindExpr e s')++expToBindExpr :: F.Expr -> RSort -> State ExSt F.Expr+expToBindExpr e@(EVar s) _+ | Char.isLower $ F.headSym $ F.symbol s+ = return e+expToBindExpr e t+ = do s <- freshSymbol+ modify $ \st -> st{emap = M.insert s (t, e) (emap st)}+ return $ EVar s++freshSymbol :: State ExSt F.Symbol+freshSymbol+ = do n <- gets fresh+ modify $ \s -> s {fresh = n+1}+ return $ F.symbol $ "ex#" ++ show n+++-- wiredInMods :: S.HashSet Ghc.ModuleName+-- wiredInMods = S.fromList $ Ghc.mkModuleName <$>+-- ["Language.Haskell.Liquid.String",+-- "Language.Haskell.Liquid.Prelude",+-- "Language.Haskell.Liquid.Foreign",+-- "Language.Haskell.Liquid.Bag",+-- "Prelude",+-- "System.IO",+-- "Data.Word",+-- "Data.Time.Calendar",+-- "Data.Set",+-- "Data.Either",+-- "Data.ByteString.Unsafe",+-- "Data.ByteString.Lazy",+-- "Data.ByteString.Short",+-- "Data.Foldable",+-- "Data.OldList",+-- "Data.Text",+-- "Data.Tuple",+-- "Data.Bits",+-- "Data.Chare",+-- "Data.String",+-- "Data.Vector",+-- "Data.Time",+-- "Data.Int",+-- "Data.Text.Fusion",+-- "Data.Map",+-- "Data.Text.Fusion.Common",+-- "KMeansHelper",+-- "Data.Text.Lazy.Fusion",+-- "Control.Exception",+-- "Control.Parallel.Strategies",+-- "Data.Traversable",+-- "GHC.Read",+-- "Data.ByteString",+-- "GHC.Classes",+-- "GHC.Ptr",+-- "GHC.Word",+-- "Language.Haskell.Liquid.Equational",+-- "GHC.Types",+-- "GHC.Num",+-- "GHC.CString",+-- "GHC.IO.Handle",+-- "GHC.Prim",+-- "GHC.Int",+-- "GHC.Base",+-- "Foreign.Ptr",+-- "GHC.ForeignPtr",+-- "GHC.List",+-- "Foreign.C.String",+-- "GHC.Exts",+-- "Foreign.Marshal.Alloc",+-- "Foreign.Marshal.Array",+-- "Foreign.C.Types",+-- "GHC.Real",+-- "Foreign.Storable",+-- "Foreign.ForeignPtr"]
+ src/Language/Haskell/Liquid/Bare/Laws.hs view
@@ -0,0 +1,54 @@+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
@@ -0,0 +1,502 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++-- | This module contains (most of) the code needed to lift Haskell entitites,+-- . code- (CoreBind), and data- (Tycon) definitions into the spec level.++module Language.Haskell.Liquid.Bare.Measure+ ( makeHaskellMeasures+ , makeHaskellInlines+ , makeHaskellDataDecls+ , makeMeasureSelectors+ , makeMeasureSpec+ , makeMeasureSpec'+ , varMeasures+ , makeClassMeasureSpec+ -- , makeHaskellBounds+ ) where++import Data.Default+import qualified Control.Exception as Ex+import Prelude hiding (mapM, error)+import Data.Bifunctor+import qualified Data.Maybe as Mb+import Text.PrettyPrint.HughesPJ (text)+-- import Text.Printf (printf)++import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S++import Language.Fixpoint.SortCheck (isFirstOrder)+import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.Transforms.CoreToLogic+import qualified Language.Fixpoint.Misc as Misc+import qualified Language.Haskell.Liquid.Misc as Misc+import Language.Haskell.Liquid.Misc ((.||.))+import qualified Liquid.GHC.API as Ghc+import qualified Language.Haskell.Liquid.GHC.Misc as GM+import qualified Language.Haskell.Liquid.Types.RefType as RT+import Language.Haskell.Liquid.Types+-- import Language.Haskell.Liquid.Types.Bounds+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.Expand as Bare+import qualified Language.Haskell.Liquid.Bare.DataType as Bare+import qualified Language.Haskell.Liquid.Bare.ToBare as Bare+import Control.Monad (mapM)++--------------------------------------------------------------------------------+makeHaskellMeasures :: Bool -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec+ -> [Measure (Located BareType) LocSymbol]+--------------------------------------------------------------------------------+makeHaskellMeasures allowTC src tycEnv lmap spec+ = Bare.measureToBare <$> ms+ where+ ms = makeMeasureDefinition allowTC tycEnv lmap cbs <$> mSyms+ cbs = nonRecCoreBinds (_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"+ 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+ vinfo = GM.varLocInfo (logicType allowTC) v++makeUnSorted :: Bool -> Ghc.Type -> [Def LocSpecType Ghc.DataCon] -> UnSortedExprs+makeUnSorted allowTC ty defs+ | isMeasureType ta+ = mempty+ | otherwise+ = map defToUnSortedExpr defs+ where+ ta = go $ Ghc.expandTypeSynonyms ty++ go (Ghc.ForAllTy _ t) = go t+ go Ghc.FunTy{ Ghc.ft_arg = p, Ghc.ft_res = t} | isErasable p = go t+ go Ghc.FunTy{ Ghc.ft_arg = t } = t+ go t = t -- this should never happen!++ 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))++ xx = F.vv $ Just 10000+ isErasable = if allowTC then GM.isEmbeddedDictType else Ghc.isClassPred++coreToDef' :: Bool -> Bare.TycEnv -> LogicMap -> LocSymbol -> 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+ Right l -> l+ Left e -> Ex.throw e+ where+ embs = Bare.tcEmbs tycEnv+ dm = Bare.tcDataConMap tycEnv++errHMeas :: LocSymbol -> 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+ -> [(LocSymbol, LMap)]+--------------------------------------------------------------------------------+makeHaskellInlines allowTC src embs lmap spec+ = makeMeasureInline allowTC embs lmap cbs <$> inls+ where+ cbs = nonRecCoreBinds (_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+ Nothing -> Ex.throw $ errHMeas x "Cannot inline haskell function"+ Just (v, defn) -> (vx, coreToFun' allowTC 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)++-- | @coreToFun'@ takes a @Maybe DataConMap@: we need a proper map when lifting+-- measures and reflects (which have case-of, and hence, need the projection symbols),+-- 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+ -> (([Ghc.Var], Either F.Expr F.Expr) -> a) -> a+coreToFun' allowTC 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+ 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]+ -> [DataDecl]+--------------------------------------------------------------------------------+makeHaskellDataDecls cfg name spec tcs+ | exactDCFlag cfg = Bare.dataDeclSize spec+ . Mb.mapMaybe tyConDataDecl+ -- . F.tracepp "makeHaskellDataDecls-3"+ . zipMap (hasDataDecl name spec . fst)+ -- . F.tracepp "makeHaskellDataDecls-2"+ . liftableTyCons+ -- . F.tracepp "makeHaskellDataDecls-1"+ . filter isReflectableTyCon+ $ tcs+ | otherwise = []+++isReflectableTyCon :: Ghc.TyCon -> Bool+isReflectableTyCon = Ghc.isFamInstTyCon .||. Ghc.isVanillaAlgTyCon++liftableTyCons :: [Ghc.TyCon] -> [(Ghc.TyCon, DataName)]+liftableTyCons+ = F.notracepp "LiftableTCs 3"+ . zipMapMaybe (tyConDataName True)+ . F.notracepp "LiftableTCs 2"+ . filter (not . Ghc.isBoxedTupleTyCon)+ . F.notracepp "LiftableTCs 1"+ -- . (`sortDiff` wiredInTyCons)+ -- . F.tracepp "LiftableTCs 0"++zipMap :: (a -> b) -> [a] -> [(a, b)]+zipMap f xs = zip xs (map f xs)++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+ where+ msg tc = "hasDataDecl " ++ show (tcName 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)++{-tyConDataDecl :: {tc:TyCon | isAlgTyCon tc} -> Maybe DataDecl @-}+tyConDataDecl :: ((Ghc.TyCon, DataName), HasDataDecl) -> Maybe DataDecl+tyConDataDecl (_, HasDecl)+ = Nothing+tyConDataDecl ((tc, dn), NoDecl szF)+ = Just $ DataDecl+ { tycName = dn+ , tycTyVars = F.symbol <$> GM.tyConTyVarsDef tc+ , tycPVars = []+ , tycDCons = Just (decls tc)+ , tycSrcPos = GM.getSourcePos tc+ , tycSFun = szF+ , tycPropTy = Nothing+ , tycKind = DataReflected+ }+ 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 ))+ | otherwise = Nothing+ where+ post = if full then id else GM.dropModuleNamesAndUnique+ vanillaTc = Ghc.isVanillaAlgTyCon tc+ dcs = Misc.sortOn F.symbol (Ghc.tyConDataCons tc)++dataConDecl :: Ghc.DataCon -> DataCtor+dataConDecl d = {- F.notracepp msg $ -} DataCtor dx (F.symbol <$> as) [] xts outT+ 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+ its = zip [1..] ts+ (as,_ps,ts,ty) = Ghc.dataConSig d+ outT = Just (RT.bareOfType ty :: BareType)+ _outT :: Maybe BareType+ _outT+ | isGadt = Just (RT.bareOfType ty)+ | otherwise = Nothing++++++--------------------------------------------------------------------------------+-- | 'makeMeasureSelectors' converts the 'DataCon's and creates the measures for+-- the selectors and checkers that then enable reflection.+--------------------------------------------------------------------------------++makeMeasureSelectors :: Config -> Bare.DataConMap -> Located DataConP -> [Measure SpecType Ghc.DataCon]+makeMeasureSelectors cfg dm (Loc l l' c)+ = Misc.condNull (exactDCFlag cfg) (checker : Mb.mapMaybe go' fields) -- internal measures, needed for reflection+ ++ Misc.condNull autofields (Mb.mapMaybe go fields) -- user-visible measures.+ where+ dc = dcpCon c+ isGadt = dcpIsGadt c+ xts = dcpTyArgs c+ autofields = not isGadt+ go ((x, t), i)+ -- do not make selectors for functional fields+ | isFunTy t && not (higherOrderFlag cfg)+ = Nothing+ | otherwise+ = Just $ makeMeasureSelector (Loc l l' x) (projT i) dc n i++ go' ((_,t), i)+ -- do not make selectors for functional fields+ | isFunTy t && not (higherOrderFlag cfg)+ = Nothing+ | otherwise+ = Just $ makeMeasureSelector (Loc l l' (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+ projT i = dataConSel permitTC dc n (Proj i)+ checkT = dataConSel permitTC dc n Check+ permitTC = typeclass cfg++dataConSel :: Bool -> Ghc.DataCon -> Int -> DataConSel -> SpecType+dataConSel permitTC dc n Check = mkArrow (map (, mempty) as) [] [xt] bareBool+ where+ (as, _, xt) = {- traceShow ("dataConSel: " ++ show dc) $ -} bkDataCon permitTC dc n++dataConSel permitTC dc n (Proj i) = mkArrow (map (, mempty) as) [] [xt] (mempty <$> ti)+ where+ ti = Mb.fromMaybe err $ Misc.getNth (i-1) ts+ (as, ts, xt) = {- F.tracepp ("bkDatacon dc = " ++ F.showpp (dc, n)) $ -} bkDataCon permitTC dc n+ 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 permitTC dcn nFlds = (as, ts, (F.dummySymbol, classRFInfo permitTC, t, mempty))+ where+ ts = RT.ofType <$> Misc.takeLast nFlds (map Ghc.irrelevantMult _ts)+ t = -- Misc.traceShow ("bkDataConResult" ++ GM.showPpr (dc, _t, _t0)) $+ RT.ofType $ Ghc.mkTyConApp tc tArgs'+ as = makeRTVar . RT.rTyVar <$> (αs ++ αs')+ ((αs,αs',_,_,_ts,_t), _t0) = hammer dcn+ tArgs' = take (nArgs - nVars) tArgs ++ (Ghc.mkTyVarTy <$> αs)+ nVars = length αs+ nArgs = length tArgs+ (tc, tArgs) = Mb.fromMaybe err (Ghc.splitTyConApp_maybe _t)+ err = GM.namedPanic dcn ("Cannot split result type of DataCon " ++ show dcn)+ hammer dc = (Ghc.dataConFullSig dc, Ghc.varType . Ghc.dataConWorkId $ dc)++data DataConSel = Check | Proj Int++bareBool :: SpecType+bareBool = RApp (RTyCon Ghc.boolTyCon [] def) [] [] mempty+++{- | NOTE:Use DataconWorkId++ dcWorkId :: forall a1 ... aN. (a1 ~ X1 ...) => T1 -> ... -> Tn -> T+ checkT :: forall as. T -> Bool+ projT t :: forall as. T -> t++-}++makeMeasureSelector :: (Show a1) => LocSymbol -> 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 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+ eqn = Def x dc Nothing ((, Nothing) . mkx <$> [1 .. n]) (P F.PTrue)+ eqns d = Def x d Nothing ((, Nothing) . mkx <$> [1 .. nArgs d]) (P F.PFalse)+ nArgs d = length (Ghc.dataConOrigArgTys d)+ mkx j = F.symbol ("xx" ++ show j)+ dcs = Ghc.tyConDataCons (Ghc.dataConTyCon dc)+++----------------------------------------------------------------------------------------------+makeMeasureSpec' :: Bool -> MSpec SpecType Ghc.DataCon -> ([(Ghc.Var, SpecType)], [(LocSymbol, RRType F.Reft)])+----------------------------------------------------------------------------------------------+makeMeasureSpec' allowTC mspec0 = (ctorTys, measTys)+ where+ ctorTys = Misc.mapSnd RT.uRType <$> ctorTys0+ (ctorTys0, measTys) = Ms.dataConTypes allowTC mspec+ mspec = first (mapReft ur_reft) mspec0++----------------------------------------------------------------------------------------------+makeMeasureSpec :: Bare.Env -> Bare.SigEnv -> ModName -> (ModName, Ms.BareSpec) ->+ Bare.Lookup (Ms.MSpec SpecType Ghc.DataCon)+----------------------------------------------------------------------------------------------+makeMeasureSpec env sigEnv myName (name, spec)+ = mkMeasureDCon env name+ . mkMeasureSort env name+ . 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+ 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+ 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++mkMeasureDCon :: Bare.Env -> ModName -> Ms.MSpec t LocSymbol -> Bare.Lookup (Ms.MSpec t Ghc.DataCon)+mkMeasureDCon env name m = do+ let ns = measureCtors m+ dcs <- mapM (Bare.lookupGhcDataCon env name "measure-datacon") 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'}+ 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 = 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) =+ 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++ 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++ txDef :: Def BareType ctor -> Def SpecType ctor+ txDef d = first (ofMeaSort l) d where l = GM.fSourcePos (measure d)++++--------------------------------------------------------------------------------+-- | Expand Measures -----------------------------------------------------------+--------------------------------------------------------------------------------+-- 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+ }++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) }+ where+ l = loc (measure d)+ bs = fst <$> binds d+ msg = "QUALIFY-EXPAND-BODY" ++ F.showpp (bs, body d)++------------------------------------------------------------------------------+varMeasures :: (Monoid r) => Bare.Env -> [(F.Symbol, Located (RRType r))]+------------------------------------------------------------------------------+varMeasures env =+ [ (F.symbol v, varSpecType v)+ | v <- knownVars 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+ ]++varSpecType :: (Monoid r) => Ghc.Var -> Located (RRType r)+varSpecType = fmap (RT.ofType . Ghc.varType) . GM.locNamedThing++isSimpleType :: Ghc.Type -> Bool+isSimpleType = isFirstOrder . RT.typeSort mempty++makeClassMeasureSpec :: MSpec (RType c tv (UReft r2)) t+ -> [(LocSymbol, CMeasure (RType c tv r2))]+makeClassMeasureSpec Ms.MSpec{..} = tx <$> M.elems cmeasMap+ where+ tx (M n s _ _ _) = (n, CM n (mapReft ur_reft s))+++{-+expandMeasureBody :: Bare.Env -> ModName -> BareRTEnv -> SourcePos -> Body -> Body+expandMeasureBody env name rtEnv l (P p) = P (Bare.expandQualify env name rtEnv l p)+expandMeasureBody env name rtEnv l (R x p) = R x (Bare.expandQualify env name rtEnv l p)+expandMeasureBody env name rtEnv l (E e) = E (Bare.expandQualify env name rtEnv l e)+++makeHaskellBounds :: F.TCEmb TyCon -> CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv -- TODO-REBARE+makeHaskellBounds embs cbs xs = do+ lmap <- gets logicEnv+ M.fromList <$> mapM (makeHaskellBound embs lmap cbs) (S.toList xs)++makeHaskellBound :: F.TCEmb TyCon+ -> LogicMap+ -> [Bind Var]+ -> (Var, Located Symbol)+ -> BareM (LocSymbol, RBound)+makeHaskellBound embs lmap cbs (v, x) =+ case filter ((v `elem`) . GM.binders) cbs of+ (NonRec v def:_) -> toBound v x <$> coreToFun' embs lmap x v def return+ (Rec [(v, def)]:_) -> toBound v x <$> coreToFun' embs lmap x v def return+ _ -> throwError $ errHMeas x "Cannot make bound of haskell function"++++toBound :: Var -> LocSymbol -> ([Var], Either F.Expr F.Expr) -> (LocSymbol, RBound)+toBound v x (vs, Left p) = (x', Bound x' fvs ps xs p)+ where+ x' = capitalizeBound x+ (ps', xs') = L.partition (hasBoolResult . varType) vs+ (ps , xs) = (txp <$> ps', txx <$> xs')+ txp v = (dummyLoc $ simpleSymbolVar v, RT.ofType $ varType v)+ txx v = (dummyLoc $ symbol v, RT.ofType $ varType v)+ fvs = (((`RVar` mempty) . RTV) <$> fst (splitForAllTyCoVars $ varType v)) :: [RSort]++toBound v x (vs, Right e) = toBound v x (vs, Left e)++capitalizeBound :: Located Symbol -> Located Symbol+capitalizeBound = fmap (symbol . toUpperHead . symbolString)+ where+ toUpperHead [] = []+ toUpperHead (x:xs) = toUpper x:xs++-}+
+ src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts #-}+++module Language.Haskell.Liquid.Bare.Misc+ ( joinVar+ , mkVarExpr+ , vmap+ , runMapTyVars+ , matchKindArgs+ , symbolRTyVar+ , simpleSymbolVar+ , hasBoolResult+ , isKind+ ) where++import Prelude hiding (error)++import Liquid.GHC.API as Ghc hiding (Located, showPpr)++import Control.Monad.Except (MonadError, throwError)+import Control.Monad.State+import qualified Data.Maybe as Mb --(fromMaybe, isNothing)++import qualified Text.PrettyPrint.HughesPJ as PJ+import qualified Data.List as L+import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Types.Types++-- import Language.Haskell.Liquid.Bare.Env++-- import Language.Haskell.Liquid.WiredIn (dcPrefix)+++-- TODO: This is where unsorted stuff is for now. Find proper places for what follows.++{-+-- WTF does this function do?+makeSymbols :: (Id -> Bool) -> [Id] -> [F.Symbol] -> BareM [(F.Symbol, Var)]+makeSymbols f vs xs+ = do svs <- M.toList <$> gets varEnv+ return $ L.nub ([ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)]+ ++ [ (F.symbol v, v) | v <- vs, f v, isDataConId v, hasBasicArgs $ varType v ])+ where+ -- arguments should be basic so that autogenerated singleton types are well formed+ hasBasicArgs (ForAllTy _ t) = hasBasicArgs t+ hasBasicArgs (FunTy _ tx t) = isBaseTy tx && hasBasicArgs t+ hasBasicArgs _ = True++-}++{-+HEAD+freeSymbols :: (F.Reftable r, F.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))]+ -> [Located (RType c tv r)]+ -> [LocSymbol]+freeSymbols xs' xts yts ivs = [ lx | lx <- Misc.sortNub $ zs ++ zs' ++ zs'' , not (M.member (val lx) knownM) ]+ where+ knownM = M.fromList [ (x, ()) | x <- xs' ]+ zs = concatMap freeSyms (snd <$> xts)+ zs' = concatMap freeSyms (snd <$> yts)+ zs'' = concatMap freeSyms ivs++++-------------------------------------------------------------------------------+freeSyms :: (F.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+ [ 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)+-- => [F.Symbol]+-- -> [(a1, Located (RType c2 tv2 r2))]+-- -> [(a, Located (RType c1 tv1 r1))]+-- -> [(Located (RType c tv r))]+-- -> [LocSymbol]+-- freeSymbols xs' xts yts ivs = [ lx | lx <- Misc.sortNub $ zs ++ zs' ++ zs'' , not (M.member (val lx) knownM) ]+-- where+-- knownM = M.fromList [ (x, ()) | x <- xs' ]+-- zs = concatMap freeSyms (snd <$> xts)+-- zs' = concatMap freeSyms (snd <$> yts)+-- zs'' = concatMap freeSyms ivs++++-- freeSyms :: (F.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+-- [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs++-}+-------------------------------------------------------------------------------+-- Renaming Type Variables in Haskell Signatures ------------------------------+-------------------------------------------------------------------------------+runMapTyVars :: Bool -> Type -> SpecType -> (PJ.Doc -> PJ.Doc -> Error) -> Either Error MapTyVarST+runMapTyVars allowTC τ t err = execStateT (mapTyVars allowTC τ t) (MTVST [] err)++data MapTyVarST = MTVST+ { vmap :: [(Var, RTyVar)]+ , errmsg :: PJ.Doc -> PJ.Doc -> Error+ }++mapTyVars :: Bool -> Type -> SpecType -> StateT MapTyVarST (Either Error) ()+mapTyVars allowTC (FunTy { ft_arg = τ, ft_res = τ'}) t+ | isErasable τ+ = mapTyVars allowTC τ' t+ where isErasable = if allowTC then isEmbeddedDictType else isClassPred+mapTyVars allowTC (FunTy { ft_arg = τ, ft_res = τ'}) (RFun _ _ t t' _)+ = mapTyVars allowTC τ t >> mapTyVars allowTC τ' t'+mapTyVars allowTC τ (RAllT _ t _)+ = mapTyVars allowTC τ t+mapTyVars allowTC (TyConApp _ τs) (RApp _ ts _ _)+ = zipWithM_ (mapTyVars allowTC) τs (matchKindArgs' τs ts)+mapTyVars _ (TyVarTy α) (RVar a _)+ = do s <- get+ s' <- mapTyRVar α a s+ put s'+mapTyVars allowTC τ (RAllP _ t)+ = mapTyVars allowTC τ t+mapTyVars allowTC τ (RAllE _ _ t)+ = mapTyVars allowTC τ t+mapTyVars allowTC τ (RRTy _ _ _ t)+ = mapTyVars allowTC τ t+mapTyVars allowTC τ (REx _ _ t)+ = mapTyVars allowTC τ t+mapTyVars _ _ (RExprArg _)+ = return ()+mapTyVars allowTC (AppTy τ τ') (RAppTy t t' _)+ = do mapTyVars allowTC τ t+ mapTyVars allowTC τ' t'+mapTyVars _ _ (RHole _)+ = return ()+mapTyVars _ k _ | isKind k+ = return ()+mapTyVars allowTC (ForAllTy _ τ) t+ = mapTyVars allowTC τ t+mapTyVars _ hsT lqT+ = do err <- gets errmsg+ throwError (err (F.pprint hsT) (F.pprint lqT))++isKind :: Kind -> Bool+isKind = classifiesTypeWithValues -- TODO:GHC-863 isStarKind k -- typeKind k+++mapTyRVar :: MonadError Error m+ => Var -> RTyVar -> MapTyVarST -> m MapTyVarST+mapTyRVar α a s@(MTVST αas err)+ = case lookup α αas of+ Just a' | a == a' -> return s+ | otherwise -> throwError (err (F.pprint a) (F.pprint a'))+ Nothing -> return $ MTVST ((α,a):αas) err++matchKindArgs' :: [Type] -> [SpecType] -> [SpecType]+matchKindArgs' ts1' = reverse . go (reverse ts1') . reverse+ where+ go (_:ts1) (t2:ts2) = t2:go ts1 ts2+ go ts [] | all isKind ts+ = (ofType <$> ts) :: [SpecType]+ go _ ts = ts+++matchKindArgs :: [SpecType] -> [SpecType] -> [SpecType]+matchKindArgs ts1' = reverse . go (reverse ts1') . reverse+ where+ go (_:ts1) (t2:ts2) = t2:go ts1 ts2+ go ts [] = ts+ go _ ts = ts++mkVarExpr :: Id -> F.Expr+mkVarExpr v+ | isFunVar v = F.mkEApp (varFunSymbol v) []+ | otherwise = F.eVar v -- EVar (symbol v)++varFunSymbol :: Id -> Located F.Symbol+varFunSymbol = dummyLoc . F.symbol . idDataCon++isFunVar :: Id -> Bool+isFunVar v = isDataConId v && not (null αs) && Mb.isNothing tf+ where+ (αs, t) = splitForAllTyCoVars $ varType v+ tf = splitFunTy_maybe t++-- the Vars we lookup in GHC don't always have the same tyvars as the Vars+-- we're given, so return the original var when possible.+-- see tests/pos/ResolvePred.hs for an example+joinVar :: [Var] -> (Var, s, t) -> (Var, s, t)+joinVar vs (v,s,t) = case L.find ((== showPpr v) . showPpr) vs of+ Just v' -> (v',s,t)+ Nothing -> (v,s,t)++simpleSymbolVar :: Var -> F.Symbol+simpleSymbolVar = dropModuleNames . F.symbol . showPpr . getName++hasBoolResult :: Type -> Bool+hasBoolResult (ForAllTy _ t) = hasBoolResult t+hasBoolResult (FunTy { ft_res = t} ) | eqType boolTy t = True+hasBoolResult (FunTy { ft_res = t} ) = hasBoolResult t+hasBoolResult _ = False
+ src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.Bare.Plugged+ ( makePluggedSig+ , makePluggedDataCon+ ) where++import Prelude hiding (error)+import Data.Generics.Aliases (mkT)+import Data.Generics.Schemes (everywhere)++import Text.PrettyPrint.HughesPJ+import qualified Control.Exception as Ex+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.Maybe as Mb+import qualified Data.List as L+import qualified Language.Fixpoint.Types as F+import qualified Language.Fixpoint.Types.Visitor as F+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 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++---------------------------------------------------------------------------------------+-- [NOTE: Plug-Holes-TyVars] We have _two_ versions of `plugHoles:+-- * `HsTyVars` ensures that the returned signature uses the GHC type variables;+-- We need this as these tyvars can appear in the SOURCE (as type annotations, or+-- as the types of lambdas) and renaming them will cause problems;+-- * `LqTyVars` ensures that the returned signatuer uses the LIQUID type variables;+-- We need this e.g. for class specifications where we cannot change the tyvars+-- used inside method signatures as that messes up the type for the data-constructor+-- for the dictionary (as we need to use the same tyvars as are "bound" in the class+-- definition).+-- In short, use `HsTyVars` when we also have to analyze the binder's SOURCE; and+-- otherwise, use `LqTyVars`.+---------------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- | NOTE: Be *very* careful with the use functions from RType -> GHC.Type,+-- e.g. toType, in this module as they cannot handle LH type holes. Since+-- this module is responsible for plugging the holes we obviously cannot+-- assume, as in e.g. L.H.L.Constraint.* that they do not appear.+--------------------------------------------------------------------------------+makePluggedSig :: Bool -> ModName -> F.TCEmb Ghc.TyCon -> TyConMap -> S.HashSet StableName+ -> Bare.PlugTV Ghc.Var -> LocSpecType+ -> LocSpecType++makePluggedSig allowTC name embs tyi exports kx t+ | Just x <- kxv = mkPlug x+ | otherwise = t+ where+ kxv = Bare.plugSrc kx+ mkPlug x = plugHoles allowTC kx embs tyi r τ t+ where+ τ = Ghc.expandTypeSynonyms (Ghc.varType x)+ r = maybeTrue x name exports+ -- x = case kx of { Bare.HsTV x -> x ; Bare.LqTV x -> x }+++-- makePluggedDataCon = makePluggedDataCon_old+-- plugHoles = plugHolesOld+-- makePluggedDataCon = makePluggedDataCon_new++-- plugHoles _ = plugHolesOld++plugHoles :: (Ghc.NamedThing a, PPrint a, Show a)+ => Bool+ -> Bare.PlugTV a+ -> F.TCEmb Ghc.TyCon+ -> Bare.TyConMap+ -> (SpecType -> RReft -> RReft)+ -> Ghc.Type+ -> LocSpecType+ -> LocSpecType+plugHoles allowTC (Bare.HsTV x) a b = plugHolesOld allowTC a b x+plugHoles allowTC (Bare.LqTV x) a b = plugHolesNew allowTC a b x+plugHoles _ _ _ _ = \_ _ t -> t+++makePluggedDataCon :: Bool -> F.TCEmb Ghc.TyCon -> Bare.TyConMap -> Located DataConP -> Located DataConP+makePluggedDataCon allowTC embs tyi ldcp+ | mismatchFlds = Ex.throw (err "fields") -- (err $ "fields:" <+> F.pprint (length dts) <+> " vs " <+> F.pprint ( dcArgs))+ | mismatchTyVars = Ex.throw (err "type variables")+ | otherwise = F.atLoc ldcp $ F.notracepp "makePluggedDataCon" $ dcp+ { dcpFreeTyVars = dcVars+ , dcpTyArgs = reverse tArgs+ , dcpTyRes = tRes+ }+ where+ (tArgs, tRes) = plugMany allowTC embs tyi ldcp (das, dts, dt) (dcVars, dcArgs, dcpTyRes dcp)+ (das, _, dts, dt) = {- F.notracepp ("makePluggedDC: " ++ F.showpp dc) $ -} Ghc.dataConSig dc+ dcArgs = reverse $ filter (not . (if allowTC then isEmbeddedClass else isClassType) . snd) (dcpTyArgs dcp)+ dcVars = if isGADT+ then padGADVars $ L.nub (dcpFreeTyVars dcp ++ concatMap (map ty_var_value . freeTyVars) (dcpTyRes dcp:(snd <$> dcArgs)))+ else dcpFreeTyVars dcp+ dc = dcpCon dcp+ dcp = val ldcp++ isGADT = Ghc.isGadtSyntaxTyCon $ Ghc.dataConTyCon dc++ -- hack to match LH and GHC GADT vars, since it is unclear how ghc generates free vars+ padGADVars vs = (RTV <$> take (length das - length vs) das) ++ vs++ mismatchFlds = length dts /= length dcArgs+ mismatchTyVars = length das /= length dcVars+ err things = ErrBadData (GM.fSrcSpan dcp) (pprint dc) ("GHC and Liquid specifications have different numbers of" <+> things) :: UserError+++-- | @plugMany@ is used to "simultaneously" plug several different types,+-- e.g. as arise in the fields of a data constructor. To do so we create+-- a single "function type" that is then passed into @plugHoles@.+-- We also pass in the type parameters as dummy arguments, because, e.g.+-- we want @plugMany@ on the two types+--+-- forall a. a -> a -> Bool+-- forall b. _ -> _ -> _+--+-- to return something like+--+-- forall b. b -> b -> Bool+--+-- and not, forall b. a -> a -> Bool.++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+plugMany allowTC embs tyi ldcp (hsAs, hsArgs, hsRes) (lqAs, lqArgs, lqRes)+ = F.notracepp msg (drop nTyVars (zip xs ts), t)+ where+ ((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.VisArg Ghc.Many) 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+ nTyVars = length hsAs -- == length lqAs+ dcName = Ghc.dataConName . dcpCon . val $ ldcp+ msg = "plugMany: " ++ F.showpp (dcName, hsT, lqT)++plugHolesOld, plugHolesNew+ :: (Ghc.NamedThing a, PPrint a, Show a)+ => Bool+ -> F.TCEmb Ghc.TyCon+ -> Bare.TyConMap+ -> a+ -> (SpecType -> RReft -> RReft)+ -> Ghc.Type+ -> LocSpecType+ -> LocSpecType++-- NOTE: this use of toType is safe as rt' is derived from t.+plugHolesOld allowTC tce tyi xx f t0 zz@(Loc l l' st0)+ = Loc l l'+ . mkArrow (zip (updateRTVar <$> αs') rs) ps' []+ . makeCls cs'+ . goPlug tce tyi err f (subts su rt)+ . mapExprReft (\_ -> F.applyCoSub coSub)+ . subts su+ $ st+ where+ tyvsmap = case Bare.runMapTyVars allowTC (toType False rt) st err of+ Left e -> Ex.throw e+ Right s -> Bare.vmap s+ su = [(y, rTyVar x) | (x, y) <- tyvsmap]+ su' = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]+ coSub = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]+ ps' = fmap (subts su') <$> ps+ cs' = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs2 ]+ (αs', rs) = unzip αs+ (αs,_,cs2,rt) = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)+ (_,ps,_ ,st) = bkUnivClass (F.notracepp "lq-spec" st0)++ makeCls cs t = foldr (uncurry (rFun' (classRFInfo allowTC))) t cs+ err hsT lqT = ErrMismatch (GM.fSrcSpan zz) (pprint xx)+ (text "Plugged Init types old")+ (pprint $ Ghc.expandTypeSynonyms t0)+ (pprint $ toRSort st0)+ (Just (hsT, lqT))+ (Ghc.getSrcSpan xx)++++plugHolesNew allowTC@False tce tyi xx f t0 zz@(Loc l l' st0)+ = Loc l l'+ . mkArrow (zip (updateRTVar <$> as'') rs) ps []+ . makeCls cs'+ . goPlug tce tyi err f rt'+ $ st+ where+ rt' = tx rt+ as'' = subRTVar su <$> as'+ (as',rs) = unzip as+ cs' = [ (F.dummySymbol, ct) | (c, t) <- tyCons, let ct = tx (RApp c t [] mempty) ]+ tx = subts su+ su = case Bare.runMapTyVars allowTC (toType False rt) st err of+ Left e -> Ex.throw e+ Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]+ (as,_,tyCons,rt) = bkUnivClass (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)+ (_,ps,_ ,st) = bkUnivClass st0++ makeCls cs t = foldr (uncurry (rFun' (classRFInfo allowTC))) t cs+ err hsT lqT = ErrMismatch (GM.fSrcSpan zz) (pprint xx)+ (text "Plugged Init types new - TC disallowed")+ (pprint $ Ghc.expandTypeSynonyms t0)+ (pprint $ toRSort st0)+ (Just (hsT, lqT))+ (Ghc.getSrcSpan xx)+++plugHolesNew allowTC@True tce tyi a f t0 zz@(Loc l l' st0)+ = Loc l l'+ . mkArrow (zip (updateRTVar <$> as'') rs) ps (if length cs > length cs' then cs else cs')+ -- . makeCls cs'+ . goPlug tce tyi err f rt'+ $ st+ where+ rt' = tx rt+ as'' = subRTVar su <$> as'+ (as',rs) = unzip as+ -- cs' = [ (F.dummySymbol, ct) | (c, t) <- cs, let ct = tx (RApp c t [] mempty) ]+ tx = subts su+ su = case Bare.runMapTyVars allowTC (toType False rt) st err of+ Left e -> Ex.throw e+ Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]+ (as,_,cs0,rt) = bkUnivClass' (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)+ (_,ps,cs0' ,st) = bkUnivClass' st0+ cs = [ (x, classRFInfo allowTC, t, r) | (x,t,r)<-cs0]+ cs' = [ (x, classRFInfo allowTC, t, r) | (x,t,r)<-cs0']++ err hsT lqT = ErrMismatch (GM.fSrcSpan zz) (pprint a)+ (text "Plugged Init types new - TC allowed")+ (pprint $ Ghc.expandTypeSynonyms t0)+ (pprint $ toRSort st0)+ (Just (hsT, lqT))+ (Ghc.getSrcSpan a)++subRTVar :: [(RTyVar, RTyVar)] -> SpecRTVar -> SpecRTVar+subRTVar su a@(RTVar v i) = Mb.maybe a (`RTVar` i) (lookup v su)++goPlug :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> (Doc -> Doc -> Error) -> (SpecType -> RReft -> RReft) -> SpecType -> SpecType+ -> SpecType+goPlug tce tyi err f = go+ where+ go st (RHole r) = (addHoles t') { rt_reft = f st r }+ where+ t' = everywhere (mkT $ addRefs tce tyi) st+ addHoles = everywhere (mkT addHole)+ -- NOTE: make sure we only add holes to RVar and RApp (NOT RFun)+ addHole :: SpecType -> SpecType+ addHole t@(RVar v _) = RVar v (f t (uReft ("v", hole)))+ addHole t@(RApp c ts ps _) = RApp c ts ps (f t (uReft ("v", hole)))+ addHole t = t++ go (RVar _ _) v@(RVar _ _) = v+ go (RFun _ _ i o _) (RFun x ii i' o' r) = RFun x ii (go i i') (go o o') r+ go (RAllT _ t _) (RAllT a t' r) = RAllT a (go t t') r+ go (RAllT a t r) t' = RAllT a (go t t') r+ go t (RAllP p t') = RAllP p (go t t')+ go t (RAllE b a t') = RAllE b a (go t t')+ go t (REx b x t') = REx b x (go t t')+ go t (RRTy e r o t') = RRTy e r o (go t t')+ go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy (go t1 t1') (go t2 t2') r+ -- zipWithDefM: if ts and ts' have different length then the liquid and haskell types are different.+ -- keep different types for now, as a pretty error message will be created at Bare.Check+ go (RApp _ ts _ _) (RApp c ts' p r)+ | length ts == length ts' = RApp c (Misc.zipWithDef go ts $ Bare.matchKindArgs ts ts') p r+ go hsT lqT = Ex.throw (err (F.pprint hsT) (F.pprint lqT))++ -- otherwise = Ex.throw err+ -- If we reach the default case, there's probably an error, but we defer+ -- throwing it as checkGhcSpec does a much better job of reporting the+ -- problem to the user.+ -- go st _ = st++addRefs :: F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType+addRefs tce tyi (RApp c ts _ r) = RApp c' ts ps r+ where+ RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r)+addRefs _ _ t = t++maybeTrue :: Ghc.NamedThing a => a -> ModName -> S.HashSet StableName -> SpecType -> RReft -> RReft+maybeTrue x target exports t r+ | not (isFunTy t) && (Ghc.isInternalName name || inTarget && notExported)+ = r+ | otherwise+ = killHoles r+ where+ inTarget = Ghc.moduleName (Ghc.nameModule name) == getModName target+ name = Ghc.getName x+ notExported = not (mkStableName (Ghc.getName x) `S.member` exports)++-- killHoles r@(U (Reft (v, rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) }++killHoles :: RReft -> RReft+killHoles ur = ur { ur_reft = tx $ ur_reft ur }+ where+ tx r = {- traceFix ("killholes: r = " ++ showFix r) $ -} F.mapPredReft dropHoles r+ dropHoles = F.pAnd . filter (not . isHole) . F.conjuncts
+ src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -0,0 +1,1052 @@+-- | This module has the code that uses the GHC definitions to:+-- 1. MAKE a name-resolution environment,+-- 2. USE the environment to translate plain symbols into Var, TyCon, etc.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Bare.Resolve+ ( -- * Creating the Environment+ makeEnv++ -- * Resolving symbols+ , ResolveSym (..)+ , Qualify (..)+ , Lookup+ , qualifyTop, qualifyTopDummy++ -- * Looking up names+ , maybeResolveSym+ , lookupGhcDataCon+ , lookupGhcDnTyCon+ , lookupGhcTyCon+ , lookupGhcVar+ , lookupGhcNamedVar++ -- * Checking if names exist+ , knownGhcVar+ , knownGhcTyCon+ , knownGhcDataCon+ , knownGhcType++ -- * Misc+ , srcVars+ , coSubRReft+ , unQualifySymbol++ -- * Conversions from Bare+ , ofBareTypeE+ , ofBareType+ , ofBPVar++ -- * Post-processing types+ , txRefSort+ , errResolve++ -- * Fixing local variables+ , resolveLocalBinds+ , partitionLocalBinds+ ) where++import qualified Control.Exception as Ex+import Control.Monad (mplus)+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 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.Misc as GM+import qualified Language.Haskell.Liquid.Misc as Misc+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.Visitors+import Language.Haskell.Liquid.Bare.Types+import Language.Haskell.Liquid.Bare.Misc+import Language.Haskell.Liquid.WiredIn++myTracepp :: (F.PPrint a) => String -> a -> a+myTracepp = F.notracepp++-- type Lookup a = Misc.Validate [Error] a+type Lookup a = Either [Error] a++-------------------------------------------------------------------------------+-- | 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+ , reSrc = src+ , reGlobSyms = S.fromList globalSyms+ , reCfg = cfg+ }+ where+ globalSyms = concatMap getGlobalSyms specs+ syms = [ (F.symbol v, v) | v <- vars ]+ vars = srcVars src++getGlobalSyms :: (ModName, BareSpec) -> [F.Symbol]+getGlobalSyms (_, spec)+ = filter (not . GM.isQualifiedSym)+ $ (mbName <$> measures spec)+ ++ (mbName <$> cmeasures spec)+ ++ (mbName <$> imeasures spec)+ where+ mbName = F.val . msName++makeLocalVars :: GhcSrc -> LocalVars+makeLocalVars = localVarMap . localBinds . _giCbs++-- TODO: rewrite using CoreVisitor+localBinds :: [Ghc.CoreBind] -> [Ghc.Var]+localBinds = concatMap (bgo S.empty)+ 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 _ _ = []++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)+ ]++localKey :: Ghc.Var -> Maybe F.Symbol+localKey v+ | isLocal m = Just x+ | otherwise = Nothing+ 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 =+ Misc.group [ (x, (m, t)) | t <- srcThings src+ , tSym <- Mb.maybeToList (tyThingSymbol t)+ , let (m, x) = qualifiedSymbol tSym+ , not (isLocal m)+ ]++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++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+ 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)++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)++instance Qualify TyConInfo where+ qualify env name l bs tci = tci { sizeFunction = qualify env name l bs <$> sizeFunction tci }++instance Qualify RTyCon where+ qualify env name l bs rtc = rtc { rtc_info = qualify env name l bs (rtc_info rtc) }++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+++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)++-------------------------------------------------------------------------------+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++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 [])++ -- where+ -- err e = Misc.errorP "error-lookupGhcVar" (F.showpp (e, F.loc lx, lx))+ -- err = Ex.throw++-- | @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.++lookupLocalVar :: Env -> LocSymbol -> [Ghc.Var] -> Maybe Ghc.Var+lookupLocalVar env lx gvs = Misc.findNearest lxn kvs+ 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++-------------------------------------------------------------------------------+-- | Checking existence of names+-------------------------------------------------------------------------------+knownGhcType :: Env -> ModName -> LocBareType -> Bool+knownGhcType env name (F.Loc l _ t) =+ case ofBareTypeE env name l Nothing t of+ Left e -> myTracepp ("knownType: " ++ F.showpp (t, e)) False+ Right _ -> True++++_rTypeTyCons :: (Ord c) => RType c tv r -> [c]+_rTypeTyCons = Misc.sortNub . foldRType f []+ where+ 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)+ | otherwise = (Nothing, sym)++splitModuleNameExact :: F.Symbol -> (F.Symbol, F.Symbol)+splitModuleNameExact x' = myTracepp ("splitModuleNameExact for " ++ F.showpp x)+ (GM.takeModuleNames x, GM.dropModuleNames x)+ where+ x = GM.stripParensSym x'++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)+ 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++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+ . fixReftTyVars t -- same as fixCoercions+ where+ πs = Mb.fromMaybe tπs ps+ tπs = ty_preds (toRTypeRep t)++fixReftTyVars :: BareType -> RReft -> RReft+fixReftTyVars bt = coSubRReft coSub+ where+ coSub = M.fromList [ (F.symbol a, F.FObj (specTvSymbol a)) | a <- tvs ]+ tvs = RT.allTyVars bt+ specTvSymbol = F.symbol . RT.bareRTyVar++coSubRReft :: F.CoSub -> RReft -> RReft+coSubRReft su r = r { ur_reft = coSubReft su (ur_reft r) }++coSubReft :: F.CoSub -> F.Reft -> F.Reft+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)++ofBSortE :: Env -> ModName -> F.SourcePos -> BSort -> Lookup RSort+ofBSortE env name l t = ofBRType env name (const id) l t++ofBPVar :: Env -> ModName -> F.SourcePos -> BPVar -> RPVar+ofBPVar env name l = fmap (ofBSort env name l)++--------------------------------------------------------------------------------+txParam :: F.SourcePos -> ((UsedPVar -> UsedPVar) -> t) -> [UsedPVar] -> RType c tv r -> t+txParam l f πs t = f (txPvar l (predMap πs t))++txPvar :: F.SourcePos -> M.HashMap F.Symbol UsedPVar -> UsedPVar -> UsedPVar+txPvar l m π = π { pargs = args' }+ where+ args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)+ | otherwise = pargs π'+ π' = Mb.fromMaybe err $ M.lookup (pname π) m+ err = uError $ ErrUnbPred sp (pprint π)+ sp = GM.sourcePosSrcSpan l++predMap :: [UsedPVar] -> RType c tv r -> M.HashMap F.Symbol UsedPVar+predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]++rtypePredBinds :: RType c tv r -> [UsedPVar]+rtypePredBinds = map RT.uPVar . ty_preds . toRTypeRep++++--------------------------------------------------------------------------------+type Expandable r = ( PPrint r+ , F.Reftable r+ , SubsTy RTyVar (RType RTyCon RTyVar ()) r+ , F.Reftable (RTProp RTyCon RTyVar r))++ofBRType :: (Expandable r) => Env -> ModName -> ([F.Symbol] -> r -> r) -> F.SourcePos -> BRType r+ -> Lookup (RRType r)+ofBRType env name 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+ rebind x t = F.subst1 t (x, F.EVar $ rTypeValueVar t)+ go bs (RAppTy t1 t2 r) = RAppTy <$> go bs t1 <*> go bs t2 <*> goReft bs r+ go bs (RApp tc ts rs r) = goRApp bs tc ts rs r+ go bs (RFun x i t1 t2 r) = goRFun bs x i t1 t2 r+ go bs (RVar a r) = RVar (RT.bareRTyVar a) <$> goReft bs r+ 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+ 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+ go bs (RHole r) = RHole <$> goReft bs r+ go bs (RExprArg le) = return $ RExprArg (qualify env name l bs 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+ 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 = 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++-}++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+++bareTCApp :: (Expandable r)+ => r+ -> Located Ghc.TyCon+ -> [RTProp RTyCon RTyVar r]+ -> [RType RTyCon RTyVar r]+ -> RType RTyCon RTyVar r+bareTCApp r (Loc l _ c) rs ts | Just rhs <- Ghc.synTyConRhs_maybe c+ = if GM.kindTCArity c < length ts+ then Ex.throw err -- error (F.showpp err)+ else tyApp (RT.subsTyVarsMeet su $ RT.ofType rhs) (drop nts ts) rs r+ where+ tvs = [ v | (v, b) <- zip (GM.tyConTyVarsDef c) (Ghc.tyConBinders c), GM.isAnonBinder b]+ su = zipWith (\a t -> (RT.rTyVar a, toRSort t, t)) tvs ts+ nts = length tvs++ err :: Error+ err = ErrAliasApp (GM.sourcePosSrcSpan l) (pprint c) (Ghc.getSrcSpan c)+ (PJ.hcat [ PJ.text "Expects"+ , pprint (GM.realTcArity c)+ , PJ.text "arguments, but is given"+ , pprint (length ts) ] )+-- TODO expandTypeSynonyms here to+bareTCApp r (Loc _ _ c) rs ts | Ghc.isFamilyTyCon c && isTrivial t+ = expandRTypeSynonyms (t `RT.strengthen` r)+ where t = RT.rApp c ts rs mempty++bareTCApp r (Loc _ _ c) rs ts+ = RT.rApp c ts rs r+++tyApp :: F.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 t [] [] r = t `RT.strengthen` r+tyApp _ _ _ _ = panic Nothing "Bare.Type.tyApp on invalid inputs"++expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r+expandRTypeSynonyms = RT.ofType . Ghc.expandTypeSynonyms . RT.toType False++{-+expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r+expandRTypeSynonyms t+ | rTypeHasHole t = t+ | otherwise = expandRTypeSynonyms' t++rTypeHasHole :: RType c tv r -> Bool+rTypeHasHole = foldRType f False+ where+ f _ (RHole _) = True+ f b _ = b+-}++------------------------------------------------------------------------------------------+-- | Is this the SAME as addTyConInfo? No. `txRefSort`+-- (1) adds the _real_ sorts to RProp,+-- (2) gathers _extra_ RProp at turns them into refinements,+-- e.g. tests/pos/multi-pred-app-00.hs+------------------------------------------------------------------------------------------++txRefSort :: TyConMap -> F.TCEmb Ghc.TyCon -> LocSpecType -> LocSpecType+txRefSort tyi tce t = F.atLoc t $ mapBot (addSymSort (GM.fSrcSpan t) tce tyi) (val t)++addSymSort :: Ghc.SrcSpan -> F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType+addSymSort sp tce tyi (RApp rc@RTyCon{} ts rs rr)+ = RApp rc ts (zipWith3 (addSymSortRef sp rc) pvs rargs [1..]) r2+ where+ (_, pvs) = RT.appRTyCon tce tyi rc ts+ -- 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'++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' :: (PPrint s) => Ghc.SrcSpan -> s -> Int -> RPVar -> SpecProp -> SpecProp+addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v+ = RProp xs t+ where+ t = ofRSort (pvType p) `RT.strengthen` r+ xs = spliceArgs "addSymSortRef 1" s p++addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]))))+ | length xs == length ts+ = RProp xts (RHole r)+ | otherwise+ = -- Misc.errorP "ZONK" $ F.showpp (rc, pname up, i, length xs, length ts)+ uError $ ErrPartPred sp (pprint rc) (pprint $ pname up) i (length xs) (length ts)+ where+ xts = Misc.safeZipWithError "addSymSortRef'" xs ts+ xs = Misc.snd3 <$> pargs up+ ts = Misc.fst3 <$> pargs p++addSymSortRef' _ _ _ _ (RProp s (RHole r))+ = RProp s (RHole r)++addSymSortRef' _ _ _ p (RProp s t)+ = RProp xs t+ where+ xs = spliceArgs "addSymSortRef 2" s p++spliceArgs :: String -> [(F.Symbol, b)] -> PVar t -> [(F.Symbol, t)]+spliceArgs msg syms p = go (fst <$> syms) (pargs p)+ where+ go [] [] = []+ go [] ((s,x,_):as) = (x, s):go [] as+ go (x:xs) ((s,_,_):as) = (x,s):go xs as+ go xs [] = panic Nothing $ "spliceArgs: " ++ msg ++ "on XS=" ++ show xs++---------------------------------------------------------------------------------+-- RJ: formerly, `replaceLocalBinds` AFAICT+-- | @resolveLocalBinds@ resolves that the "free" variables that appear in the+-- type-sigs for non-toplevel binders (that correspond to other locally bound)+-- source variables that are visible at that at non-top-level scope.+-- e.g. tests-names-pos-local02.hs+---------------------------------------------------------------------------------+resolveLocalBinds :: Env -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]+ -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]+---------------------------------------------------------------------------------+resolveLocalBinds env xtes = [ (x,t,es) | (x, (t, es)) <- topTs ++ replace locTs ]+ where+ (locTs, topTs) = partitionLocalBinds [ (x, (t, es)) | (x, t, es) <- xtes]+ replace = M.toList . replaceSigs . M.fromList+ replaceSigs sigm = coreVisitor replaceVisitor M.empty sigm cbs+ cbs = _giCbs (reSrc env)++replaceVisitor :: CoreVisitor SymMap SigMap+replaceVisitor = CoreVisitor+ { envF = addBind+ , bindF = updSigMap+ , exprF = \_ m _ -> m+ }++addBind :: SymMap -> Ghc.Var -> SymMap+addBind env v = case localKey v of+ Just vx -> M.insert vx (F.symbol v) env+ Nothing -> env++updSigMap :: SymMap -> SigMap -> Ghc.Var -> SigMap+updSigMap env m v = case M.lookup v m of+ Nothing -> m+ Just tes -> M.insert v (myTracepp ("UPD-LOCAL-SIG " ++ GM.showPpr v) $ renameLocalSig env tes) m++renameLocalSig :: SymMap -> (LocBareType, Maybe [Located F.Expr])+ -> (LocBareType, Maybe [Located F.Expr])+renameLocalSig env (t, es) = (F.substf tSub t, F.substf esSub es)+ where+ tSub = F.EVar . qualifySymMap env+ esSub = tSub `F.substfExcept` xs+ xs = ty_binds (toRTypeRep (F.val t))++qualifySymMap :: SymMap -> F.Symbol -> F.Symbol+qualifySymMap env x = M.lookupDefault x x env++type SigMap = M.HashMap Ghc.Var (LocBareType, Maybe [Located F.Expr])+type SymMap = M.HashMap F.Symbol F.Symbol++---------------------------------------------------------------------------------+partitionLocalBinds :: [(Ghc.Var, a)] -> ([(Ghc.Var, a)], [(Ghc.Var, a)])+---------------------------------------------------------------------------------+partitionLocalBinds = L.partition (Mb.isJust . localKey . fst)
+ src/Language/Haskell/Liquid/Bare/Slice.hs view
@@ -0,0 +1,174 @@+{-# 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
@@ -0,0 +1,89 @@+-- | This module contains functions that convert things+-- to their `Bare` versions, e.g. SpecType -> BareType etc.++module Language.Haskell.Liquid.Bare.ToBare+ ( -- * Types+ specToBare++ -- * Measures+ , measureToBare+ )+ where++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++--------------------------------------------------------------------------------+specToBare :: SpecType -> BareType+--------------------------------------------------------------------------------+specToBare = txRType specToBareTC specToBareTV++-- specToBare t = F.tracepp ("specToBare t2 = " ++ F.showpp t2) t1+ -- where+ -- t1 = bareOfType . toType $ t+ -- t2 = _specToBare t+++--------------------------------------------------------------------------------+measureToBare :: SpecMeasure -> BareMeasure+--------------------------------------------------------------------------------+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++specToBareTC :: RTyCon -> BTyCon+specToBareTC = tyConBTyCon . rtc_tc++specToBareTV :: RTyVar -> BTyVar+specToBareTV (RTV α) = BTV (F.symbol α)++txRType :: (c1 -> c2) -> (tv1 -> tv2) -> RType c1 tv1 r -> RType c2 tv2 r+txRType cF vF = go+ where+ -- go :: RType c1 tv1 r -> RType c2 tv2 r+ go (RVar α r) = RVar (vF α) r+ go (RAllT α t r) = RAllT (goRTV α) (go t) r+ go (RAllP π t) = RAllP (goPV π) (go t)+ go (RFun x i t t' r) = RFun x i (go t) (go t') r+ go (RAllE x t t') = RAllE x (go t) (go t')+ 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 (RExprArg e) = RExprArg e+ go (RHole r) = RHole r++ -- go' :: RType c1 tv1 () -> RType c2 tv2 ()+ 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)++ -- goRTV :: RTVU c1 tv1 -> RTVU c2 tv2+ goRTV = txRTV cF vF++ -- goPV :: PVU c1 tv1 -> PVU c2 tv2+ goPV = txPV cF vF++txRTV :: (c1 -> c2) -> (tv1 -> tv2) -> RTVU c1 tv1 -> RTVU c2 tv2+txRTV cF vF (RTVar α z) = RTVar (vF α) (txRType cF vF <$> z)++txPV :: (c1 -> c2) -> (tv1 -> tv2) -> PVU c1 tv1 -> PVU c2 tv2+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+ tx = txRType cF vF
+ src/Language/Haskell/Liquid/Bare/Typeclass.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.Bare.Typeclass+ ( compileClasses+ , elaborateClassDcp+ , makeClassAuxTypes+ -- , makeClassSelectorSigs+ )+where++-- TODO: Handle typeclasses with a single method (newtype)++import Control.Monad ( forM, guard )+import Data.Bifunctor (second)+import qualified Data.List as L+import qualified Data.HashSet as S+import Data.Hashable ()+import qualified Data.Maybe as Mb+import qualified Language.Fixpoint.Types as F+import qualified Language.Fixpoint.Misc as Misc+import Language.Haskell.Liquid.Bare.Elaborate+import qualified Language.Haskell.Liquid.GHC.Misc+ as GM+import qualified Liquid.GHC.API+ as Ghc+import qualified Language.Haskell.Liquid.Misc as Misc+import Language.Haskell.Liquid.Types+import qualified Language.Haskell.Liquid.Types.RefType+ as RT+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++++compileClasses+ :: GhcSrc+ -> Bare.Env+ -> (ModName, Ms.BareSpec)+ -> [(ModName, Ms.BareSpec)]+ -> (Ms.BareSpec, [(Ghc.ClsInst, [Ghc.Var])])+compileClasses src env (name, spec) rest =+ (spec { sigs = sigsNew } <> clsSpec, instmethods)+ where+ clsSpec = mempty+ { dataDecls = clsDecls+ , reflects = F.notracepp "reflects " $ S.fromList+ ( fmap+ ( fmap GM.dropModuleNames+ . GM.namedLocSymbol+ . Ghc.instanceDFunId+ . fst+ )+ instClss+ ++ methods+ )+ }+ clsDecls = makeClassDataDecl (M.toList refinedMethods)+ -- 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)])+ 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+ 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 ]+ -- instance methods++ mkSymbol x+ | Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x)+ | otherwise = F.dropSym 2 $ GM.simplesymbol x++ instmethods :: [(Ghc.ClsInst, [Ghc.Var])]+ instmethods =+ [ (inst, ms)+ | (inst, cls) <- instClss+ , let selIds = GM.dropModuleNames . F.symbol <$> Ghc.classAllSelIds cls+ , (_, e) <- Mb.maybeToList+ (GM.findVarDefMethod+ (GM.dropModuleNames . F.symbol $ Ghc.instanceDFunId inst)+ (_giCbs src)+ )+ , let ms = filter (\x -> GM.isMethod x && elem (mkSymbol x) selIds)+ (freeVars mempty e)+ ]+ instClss :: [(Ghc.ClsInst, Ghc.Class)]+ instClss =+ [ (inst, cls)+ | inst <- mconcat . Mb.maybeToList . _gsCls $ src+ , Ghc.moduleName (Ghc.nameModule (Ghc.getName inst)) == getModName name+ , let cls = Ghc.is_cls inst+ , cls `elem` refinedClasses+ ]+ refinedClasses :: [Ghc.Class]+ refinedClasses =+ Mb.mapMaybe resolveClassMaybe clsDecls+ ++ concatMap (Mb.mapMaybe resolveClassMaybe . dataDecls . snd) rest+ resolveClassMaybe :: DataDecl -> Maybe Ghc.Class+ resolveClassMaybe d =+ Bare.maybeResolveSym env+ name+ "resolveClassMaybe"+ (dataNameSymbol . tycName $ d)+ >>= Ghc.tyConClass_maybe+++-- a list of class with user defined refinements+makeClassDataDecl :: [(Ghc.Class, [(Ghc.Id, LocBareType)])] -> [DataDecl]+makeClassDataDecl = fmap (uncurry classDeclToDataDecl)++-- TODO: I should have the knowledge to construct DataConP manually than+-- following the rather unwieldy pipeline: Resolved -> Unresolved -> Resolved.+-- 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)+ , tycTyVars = tyVars+ , tycPVars = []+ , tycDCons = Just [dctor]+ , tycSrcPos = F.loc . GM.locNamedThing $ cls+ , tycSFun = Nothing+ , tycPropTy = Nothing+ , tycKind = DataUser+ }+ where+ dctor = F.notracepp "classDeclToDataDecl" DataCtor { dcName = F.dummyLoc $ F.symbol classDc+ -- YL: same as class tyvars??+ -- Ans: it's been working so far so probably yes+ , dcTyVars = tyVars+ -- YL: what is theta?+ -- Ans: where class constraints should go yet remain unused+ -- maybe should factor this out?+ , dcTheta = []+ , dcFields = fields+ , dcResult = Nothing+ }++ tyVars = F.symbol <$> Ghc.classTyVars cls++ fields = fmap attachRef classIds+ attachRef sid+ | Just ref <- L.lookup sid refinedIds+ = (F.symbol sid, RT.subts tyVarSubst (F.val ref))+ | otherwise+ = (F.symbol sid, RT.bareOfType . dropTheta . Ghc.varType $ sid)++ tyVarSubst = [ (GM.dropModuleUnique v, v) | v <- tyVars ]++ -- FIXME: dropTheta should not be needed as long as we+ -- handle classes and ordinary data types separately+ -- Might be helpful if we add an additional field for+ -- typeclasses+ dropTheta :: Ghc.Type -> Ghc.Type+ dropTheta = Misc.thd3 . Ghc.tcSplitMethodTy++ classIds = Ghc.classAllSelIds cls+ classDc = Ghc.classDataCon cls++-- | 'elaborateClassDcp' behaves differently from other datacon+-- functions. Each method type contains the full forall quantifiers+-- instead of having them chopped off+elaborateClassDcp+ :: (Ghc.CoreExpr -> F.Expr)+ -> (Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr)+ -> DataConP+ -> Ghc.TcRn (DataConP, DataConP)+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'+ pure+ ( dcp { dcpTyArgs = zip xs (stripPred <$> ts') }+ , dcp { dcpTyArgs = fmap (\(x, t) -> (x, strengthenTy x t)) (zip xs t') }+ )+ where+ addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType+ addCoherenceOblig t Nothing = t+ addCoherenceOblig t (Just r) = fromRTypeRep rrep+ { ty_res = res `RT.strengthen` r+ }+ where+ rrep = toRTypeRep t+ res = ty_res rrep+ prefts =+ L.reverse+ . take (length fts)+ $ fmap (Just . flip MkUReft mempty . mconcat) preftss+ ++ repeat Nothing+ preftss = (fmap . fmap) (uncurry (GM.coherenceObligToRef recsel))+ (GM.buildCoherenceOblig cls)++ -- ugly, should have passed cls as an argument+ cls = Mb.fromJust $ Ghc.tyConClass_maybe (Ghc.dataConTyCon dc)+ recsel = F.symbol ("lq$recsel" :: String)+ resTy = dcpTyRes dcp+ dc = dcpCon dcp+ tvars = (\x -> (makeRTVar x, mempty)) <$> dcpFreeTyVars dcp+ -- check if the names are qualified+ (xs, ts) = unzip (dcpTyArgs dcp)+ fts = fullTy <$> ts+ -- turns forall a b. (a -> b) -> f a -> f b into+ -- forall f. Functor f => forall a b. (a -> b) -> f a -> f b+ stripPred :: SpecType -> SpecType+ stripPred = Misc.fourth4 . bkUnivClass+ fullTy :: SpecType -> SpecType+ fullTy t = mkArrow+ tvars+ []+ [ ( recsel{- F.symbol dc-}+ , classRFInfo True+ , resTy+ , mempty+ )+ ]+ t+ -- YL: is this redundant if we already have strengthenClassSel?+ strengthenTy :: F.Symbol -> SpecType -> SpecType+ strengthenTy x t = mkUnivs tvs pvs (RFun z i clas (t' `RT.strengthen` mt) r)+ where+ (tvs, pvs, RFun z i clas t' r) = bkUniv t+ vv = rTypeValueVar t'+ mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))+++elaborateMethod :: F.Symbol -> S.HashSet F.Symbol -> SpecType -> SpecType+elaborateMethod dc methods st = mapExprReft+ (\_ -> substClassOpBinding tcbindSym dc methods)+ st+ where+ tcbindSym = grabtcbind st+ grabtcbind :: SpecType -> F.Symbol+ grabtcbind t =+ F.notracepp "grabtcbind"+ $ case Misc.fst4 . fst . bkArrow . Misc.thd3 . bkUniv $ t of+ tcbind : _ -> tcbind+ [] -> impossible+ Nothing+ ( "elaborateMethod: inserted dictionary binder disappeared:"+ ++ F.showpp t+ )+++-- Before: Functor.fmap ($p1Applicative $dFunctor)+-- After: Funcctor.fmap ($p1Applicative##GHC.Base.Applicative)+substClassOpBinding+ :: F.Symbol -> F.Symbol -> S.HashSet F.Symbol -> F.Expr -> F.Expr+substClassOpBinding tcbind dc methods = go+ where+ go :: F.Expr -> F.Expr+ go (F.EApp e0 e1)+ | F.EVar x <- e0, F.EVar y <- e1, y == tcbind, S.member x methods = F.EVar+ (x `F.suffixSymbol` dc)+ | otherwise = F.EApp (go e0) (go e1)+ go (F.ENeg e ) = F.ENeg (go e)+ go (F.EBin bop e0 e1 ) = F.EBin bop (go e0) (go e1)+ go (F.EIte e0 e1 e2 ) = F.EIte (go e0) (go e1) (go e2)+ go (F.ECst e0 s ) = F.ECst (go e0) s+ go (F.ELam (x, t) body) = F.ELam (x, t) (go body)+ go (F.PAnd es ) = F.PAnd (go <$> es)+ go (F.POr es ) = F.POr (go <$> es)+ go (F.PNot e ) = F.PNot (go e)+ go (F.PImp e0 e1 ) = F.PImp (go e0) (go e1)+ go (F.PIff e0 e1 ) = F.PIff (go e0) (go e1)+ go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1)+ -- a catch-all binding is not a good idea+ go e = e+++renameTvs :: (F.Symbolic tv, F.PPrint tv) => (tv -> tv) -> RType c tv r -> RType c tv r+renameTvs rename t+ | RVar tv r <- t+ = RVar (rename tv) r+ | RFun b i tin tout r <- t+ = RFun b i (renameTvs rename tin) (renameTvs rename tout) r+ | RAllT (RTVar tv info) tres r <- t+ = RAllT (RTVar (rename tv) info) (renameTvs rename tres) r+ | RAllP b tres <- t+ = RAllP (renameTvs rename <$> b) (renameTvs rename tres)+ | RApp tc ts tps r <- t+ -- TODO: handle rtprop properly+ = RApp tc (renameTvs rename <$> ts) tps r+ | RAllE b allarg ty <- t+ = RAllE b (renameTvs rename allarg) (renameTvs rename ty)+ | REx b exarg ty <- t+ = REx b (renameTvs rename exarg) (renameTvs rename ty)+ | RExprArg _ <- t+ = t+ | RAppTy arg res r <- t+ = RAppTy (renameTvs rename arg) (renameTvs rename res) r+ | RRTy env r obl ty <- t+ = RRTy (second (renameTvs rename) <$> env) r obl (renameTvs rename ty)+ | RHole _ <- t+ = t+++makeClassAuxTypes ::+ (SpecType -> Ghc.TcRn SpecType)+ -> [F.Located DataConP]+ -> [(Ghc.ClsInst, [Ghc.Var])]+ -> Ghc.TcRn [(Ghc.Var, LocSpecType)]+makeClassAuxTypes elab dcps xs = Misc.concatMapM (makeClassAuxTypesOne elab) dcpInstMethods+ where+ dcpInstMethods = do+ dcp <- dcps+ (inst, methods) <- xs+ let dc = dcpCon . F.val $ dcp+ -- YL: only works for non-newtype class+ dc' = Ghc.classDataCon $ Ghc.is_cls inst+ guard $ dc == dc'+ pure (dcp, inst, methods)++makeClassAuxTypesOne ::+ (SpecType -> Ghc.TcRn SpecType)+ -> (F.Located DataConP, Ghc.ClsInst, [Ghc.Var])+ -> Ghc.TcRn [(Ghc.Var, LocSpecType)]+makeClassAuxTypesOne elab (ldcp, inst, methods) =+ forM methods $ \method -> do+ let (headlessSig, preft) =+ case L.lookup (mkSymbol method) yts' of+ Nothing ->+ impossible Nothing ("makeClassAuxTypesOne : unreachable?" ++ F.showpp (mkSymbol method) ++ " " ++ F.showpp yts)+ Just sig -> sig+ -- dict binder will never be changed because we optimized PAnd[]+ -- lq0 lq1 ...+ --+ ptys = [(F.vv (Just i), classRFInfo True, pty, mempty) | (i,pty) <- zip [0,1..] isPredSpecTys]+ fullSig =+ mkArrow+ (zip isRTvs (repeat mempty))+ []+ ptys .+ subst (zip clsTvs isSpecTys) $+ headlessSig+ 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)))+ 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))++ -- "is" is used as a shorthand for instance, following the convention of the Ghc api+ where+ -- recsel = F.symbol ("lq$recsel" :: String)+ (_,predTys,_,_) = Ghc.instanceSig inst+ dfunApped = F.mkEApp dfunSymL [F.eVar $ F.vv (Just i) | (i,_) <- zip [0,1..] predTys]+ prefts = L.reverse . take (length yts) $ fmap (F.notracepp "prefts" . Just . flip MkUReft mempty . mconcat) preftss ++ repeat Nothing+ preftss = F.notracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRefE dfunApped)) (GM.buildCoherenceOblig cls)+ yts' = zip (fst <$> yts) (zip (snd <$> yts) prefts)+ 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}+ 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+ -- YL: poorly written. use a comprehension instead of assuming+ methodsSet = F.notracepp "methodSet" $ M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods))+ -- core rewriting mark1: dfunId+ -- ()+ 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+ 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]+ mkSymbol x+ | -- F.notracepp ("isDictonaryId:" ++ GM.showPpr x) $+ Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x)+ | otherwise = F.dropSym 2 $ GM.simplesymbol x+ -- res = dcpTyRes dcp+ clsTvs = dcpFreeTyVars dcp+ -- copy/pasted from Bare/Class.hs+ subst [] t = t+ subst ((a, ta):su) t = 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+ where go :: F.Expr -> F.Expr+ go (F.EApp e0 e1)+ | F.EVar x <- F.notracepp "e0" e0+ , (F.EVar dfun_mb, args) <- F.splitEApp e1+ , dfun_mb == dfun+ , Just method <- M.lookup x methods+ -- Before: Functor.fmap ($p1Applicative $dFunctor)+ -- After: Funcctor.fmap ($p1Applicative##GHC.Base.Applicative)+ = F.eApps (F.EVar method) args+ | otherwise+ = F.EApp (go e0) (go e1)+ go (F.ENeg e) = F.ENeg (go e)+ go (F.EBin bop e0 e1) = F.EBin bop (go e0) (go e1)+ go (F.EIte e0 e1 e2) = F.EIte (go e0) (go e1) (go e2)+ go (F.ECst e0 s) = F.ECst (go e0) s+ go (F.ELam (x, t) body) = F.ELam (x, t) (go body)+ go (F.PAnd es) = F.PAnd (go <$> es)+ go (F.POr es) = F.POr (go <$> es)+ go (F.PNot e) = F.PNot (go e)+ go (F.PImp e0 e1) = F.PImp (go e0) (go e1)+ go (F.PIff e0 e1) = F.PIff (go e0) (go e1)+ go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1)+ go e = F.notracepp "LEAF" e
+ src/Language/Haskell/Liquid/Bare/Types.hs view
@@ -0,0 +1,160 @@+-- | This module has the code that uses the GHC definitions to:+-- 1. MAKE a name-resolution environment,+-- 2. USE the environment to translate plain symbols into Var, TyCon, etc. ++module Language.Haskell.Liquid.Bare.Types + ( -- * Name resolution environment + Env (..)+ , TyThingMap + , ModSpecs+ , LocalVars ++ -- * Tycon and Datacon processing environment+ , TycEnv (..) + , DataConMap+ , RT.TyConMap++ -- * Signature processing environment + , SigEnv (..)++ -- * Measure related environment + , MeasEnv (..)++ -- * Misc + , PlugTV (..)+ , plugSrc+ , varRSort + , varSortedReft+ , failMaybe+ ) where ++import qualified Text.PrettyPrint.HughesPJ as PJ +import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import qualified Language.Fixpoint.Types as F +import qualified Language.Haskell.Liquid.Measure as Ms+import qualified Language.Haskell.Liquid.Types.RefType as RT +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)+++type ModSpecs = M.HashMap ModName Ms.BareSpec++-------------------------------------------------------------------------------+-- | See [NOTE: Plug-Holes-TyVars] for a rationale for @PlugTV@ +-------------------------------------------------------------------------------++data PlugTV v + = HsTV v -- ^ Use tyvars from GHC specification (in the `v`) + | LqTV v -- ^ Use tyvars from Liquid specification+ | GenTV -- ^ Generalize ty-vars + | RawTV -- ^ Do NOT generalize ty-vars (e.g. for type-aliases)+ deriving (Show)+++instance (Show v, F.PPrint v) => F.PPrint (PlugTV v) where + pprintTidy _ = PJ.text . show + +plugSrc :: PlugTV v -> Maybe v +plugSrc (HsTV v) = Just v +plugSrc (LqTV v) = Just v +plugSrc _ = Nothing++-------------------------------------------------------------------------------+-- | 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+ }++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)]++-------------------------------------------------------------------------------+-- | A @TyThingMap@ is used to resolve symbols into GHC @TyThing@ and, +-- from there into Var, TyCon, DataCon, etc.+-------------------------------------------------------------------------------+type TyThingMap = M.HashMap F.Symbol [(F.Symbol, Ghc.TyThing)]++-------------------------------------------------------------------------------+-- | A @SigEnv@ contains the needed to process type signatures +-------------------------------------------------------------------------------+data SigEnv = SigEnv + { sigEmbs :: !(F.TCEmb Ghc.TyCon) + , sigTyRTyMap :: !RT.TyConMap + , sigExports :: !(S.HashSet StableName)+ , sigRTEnv :: !BareRTEnv+ }++-------------------------------------------------------------------------------+-- | A @TycEnv@ contains the information needed to process Type- and Data- Constructors +-------------------------------------------------------------------------------+data TycEnv = TycEnv + { tcTyCons :: ![TyConP]+ , tcDataCons :: ![DataConP]+ , tcSelMeasures :: ![Measure SpecType Ghc.DataCon]+ , tcSelVars :: ![(Ghc.Var, LocSpecType)]+ , tcTyConMap :: !RT.TyConMap + , tcAdts :: ![F.DataDecl]+ , tcDataConMap :: !DataConMap + , tcEmbs :: !(F.TCEmb Ghc.TyCon)+ , tcName :: !ModName+ }++type DataConMap = M.HashMap (F.Symbol, Int) F.Symbol++-------------------------------------------------------------------------------+-- | Intermediate representation for Measure information +-------------------------------------------------------------------------------+-- REBARE: used to be output of makeGhcSpecCHOP2+data MeasEnv = MeasEnv + { meMeasureSpec :: !(MSpec SpecType Ghc.DataCon) + , meClassSyms :: ![(F.Symbol, Located (RRType F.Reft))] + , meSyms :: ![(F.Symbol, Located (RRType F.Reft))]+ , meDataCons :: ![(Ghc.Var, LocSpecType)] + , meClasses :: ![DataConP] + , meMethods :: ![(ModName, Ghc.Var, LocSpecType)] + , meCLaws :: ![(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])] + }++instance Semigroup MeasEnv where+ (<>) = error "FIXME:1773"+instance Monoid MeasEnv where+ mempty = error "FIXME:1773"++-------------------------------------------------------------------------------+-- | Converting @Var@ to @Sort@+-------------------------------------------------------------------------------+varSortedReft :: F.TCEmb Ghc.TyCon -> Ghc.Var -> F.SortedReft +varSortedReft emb = RT.rTypeSortedReft emb . varRSort ++varRSort :: Ghc.Var -> RSort+varRSort = RT.ofType . Ghc.varType++-------------------------------------------------------------------------------+-- | Handling failed resolution +-------------------------------------------------------------------------------+failMaybe :: Env -> ModName -> Either e r -> Either e (Maybe r)+failMaybe env name res = case res of + Right r -> Right (Just r) + Left e -> if isTargetModName env name + then Left e+ else Right Nothing ++isTargetModName :: Env -> ModName -> Bool +isTargetModName env name = name == _giTargetMod (reSrc env)
+ src/Language/Haskell/Liquid/Cabal.hs view
@@ -0,0 +1,21 @@+{- | This module provides a drop-in replacement for Cabal's 'defaultMain', to be used inside 'Setup.hs'+ modules of packages that wants to use the \"dev mode\". For more information, visit the documentation,+ especially the \"Developers' guide\".+-}++{-# LANGUAGE LambdaCase #-}+module Language.Haskell.Liquid.Cabal (liquidHaskellMain) where++import Distribution.Simple+import System.Environment++liquidHaskellMain :: IO ()+liquidHaskellMain = do+ mbDevMode <- lookupEnv "LIQUID_DEV_MODE"+ defaultMainWithHooks (devModeHooks mbDevMode)++devModeHooks :: Maybe String -> UserHooks+devModeHooks = \case+ Nothing -> simpleUserHooks+ Just x | x == "false" -> simpleUserHooks+ Just _ -> simpleUserHooks { buildHook = \_ _ _ _ -> return () }
+ src/Language/Haskell/Liquid/Constraint/Constraint.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- TODO: what exactly is the purpose of this module? What do these functions do?++module Language.Haskell.Liquid.Constraint.Constraint (+ constraintToLogic+, addConstraints+) where++import Prelude hiding (error)+import Data.Maybe+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Constraint.Types+import Language.Haskell.Liquid.Constraint.Env+import Language.Fixpoint.Types++--------------------------------------------------------------------------------+addConstraints :: CGEnv -> [(Symbol, SpecType)] -> CGEnv+--------------------------------------------------------------------------------+addConstraints γ t = γ {lcs = mappend (t2c t) (lcs γ)}+ where+ t2c z = LC [z]++--------------------------------------------------------------------------------+constraintToLogic :: REnv -> LConstraint -> Expr+--------------------------------------------------------------------------------+constraintToLogic γ (LC ts) = pAnd (constraintToLogicOne γ <$> ts)++-- RJ: The code below is atrocious. Please fix it!+constraintToLogicOne :: (Reftable r) => REnv -> [(Symbol, RRType r)] -> Expr+constraintToLogicOne γ binds+ = pAnd [subConstraintToLogicOne+ (zip xs xts)+ (last xs,+ (last (fst <$> xts), r))+ | xts <- xss]+ where+ symRts = init binds+ (xs, ts) = unzip symRts+ r = snd $ last binds+ xss = combinations ((\t -> [(x, t) | x <- localBindsOfType t γ]) <$> ts)++subConstraintToLogicOne :: (Foldable t, Reftable r, Reftable r1)+ => t (Symbol, (Symbol, RType t1 t2 r))+ -> (Symbol, (Symbol, RType t3 t4 r1)) -> Expr+subConstraintToLogicOne xts (sym', (sym, rt)) = PImp (pAnd rs) r+ where+ (rs , symExprs) = foldl go ([], []) xts+ ([r], _ ) = go ([], symExprs) (sym', (sym, rt))+ go (acc, su) (x', (x, t)) = let (Reft(v, p)) = toReft (fromMaybe mempty (stripRTypeBase t))+ su' = (x', EVar x):(v, EVar x) : su+ in+ (subst (mkSubst su') p : acc, su')++combinations :: [[a]] -> [[a]]+combinations [] = [[]]+combinations ([]:_) = []+combinations ((y:ys):yss) = [y:xs | xs <- combinations yss] ++ combinations (ys:yss)
+ src/Language/Haskell/Liquid/Constraint/Env.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE PartialTypeSignatures #-}++-- | This module defines the representation for Environments needed+-- during constraint generation.++module Language.Haskell.Liquid.Constraint.Env (++ -- * Insert+ (+++=)+ -- , (++=)+ , (+=)+ , extendEnvWithVV+ , addBinders+ , addSEnv+ , addEEnv+ , (-=)+ , globalize++ -- * Construction+ , fromListREnv+ , toListREnv+ , insertREnv -- TODO: remove this ASAP++ -- * Query+ , localBindsOfType+ , lookupREnv+ , (?=)++ -- * Pruning refinements (TODO: move!)+ , rTypeSortedReft'++ -- * Extend CGEnv+ , setLocation, setBind, setRecs, setTRec++ -- * Lookup CGEnv+ , getLocation++) where+++-- import Name (getSrcSpan)+import Prelude hiding (error)+-- import Outputable+-- import FastString (fsLit)+import Control.Monad.State++-- import GHC.Err.Located hiding (error)+import GHC.Stack++import Control.Arrow (first)+import Data.Maybe -- (fromMaybe)+import qualified Data.List as L+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import qualified Language.Fixpoint.Types as F+++import Language.Fixpoint.SortCheck (pruneUnsortedReft)++++import Liquid.GHC.API hiding (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.Constraint.Types+import Language.Haskell.Liquid.Constraint.Fresh ()+import Language.Haskell.Liquid.Transforms.RefSplit+import qualified Language.Haskell.Liquid.UX.CTags as Tg++-- import Debug.Trace (trace)+--------------------------------------------------------------------------------+-- | Refinement Type Environments ----------------------------------------------+--------------------------------------------------------------------------------++-- updREnvLocal :: REnv -> (_ -> _) -> REnv+updREnvLocal :: REnv+ -> (M.HashMap F.Symbol SpecType -> M.HashMap F.Symbol SpecType)+ -> REnv+updREnvLocal rE f = rE { reLocal = f (reLocal rE) }++-- RJ: REnv-Split-Bug?+filterREnv :: (SpecType -> Bool) -> REnv -> REnv+filterREnv f rE = rE `updREnvLocal` M.filter f++fromListREnv :: [(F.Symbol, SpecType)] -> [(F.Symbol, SpecType)] -> REnv+fromListREnv gXts lXts = REnv+ { reGlobal = M.fromList gXts+ , reLocal = M.fromList lXts+ }++-- RJ: REnv-Split-Bug?+deleteREnv :: F.Symbol -> REnv -> REnv+deleteREnv x rE = rE `updREnvLocal` M.delete x++insertREnv :: F.Symbol -> SpecType -> REnv -> REnv+insertREnv x y rE = {- trace ("insertREnv: " ++ show x) $ -} rE `updREnvLocal` M.insert x y++lookupREnv :: F.Symbol -> REnv -> Maybe SpecType+lookupREnv x rE = msum $ M.lookup x <$> renvMaps rE++memberREnv :: F.Symbol -> REnv -> Bool+memberREnv x rE = or $ M.member x <$> renvMaps rE++globalREnv :: REnv -> REnv+globalREnv (REnv gM lM) = REnv gM' M.empty+ where+ gM' = M.unionWith (\_ t -> t) gM lM++renvMaps :: REnv -> [M.HashMap F.Symbol SpecType]+renvMaps rE = [reLocal rE, reGlobal rE]++--------------------------------------------------------------------------------+localBindsOfType :: RRType r -> REnv -> [F.Symbol]+--------------------------------------------------------------------------------+localBindsOfType tx γ = fst <$> localsREnv (filterREnv ((== toRSort tx) . toRSort) γ)++-- RJ: REnv-Split-Bug?+localsREnv :: REnv -> [(F.Symbol, SpecType)]+localsREnv = M.toList . reLocal++globalsREnv :: REnv -> [(F.Symbol, SpecType)]+globalsREnv = M.toList . reGlobal++toListREnv :: REnv -> [(F.Symbol, SpecType)]+toListREnv re = globalsREnv re ++ localsREnv re++--------------------------------------------------------------------------------+extendEnvWithVV :: CGEnv -> SpecType -> CG CGEnv+--------------------------------------------------------------------------------+extendEnvWithVV γ t+ | F.isNontrivialVV vv && not (vv `memberREnv` renv γ)+ = γ += ("extVV", vv, t)+ | otherwise+ = return γ+ where+ vv = rTypeValueVar t++addBinders :: CGEnv -> F.Symbol -> [(F.Symbol, SpecType)] -> CG CGEnv+addBinders γ0 x' cbs = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs]++addBind :: SrcSpan -> F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)+addBind l x r = do+ st <- get+ let (i, bs') = F.insertBindEnv x r (Ci l Nothing Nothing) (binds st)+ put $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) }+ return ((x, F.sr_sort r), {- traceShow ("addBind: " ++ showpp x) -} i)++addClassBind :: CGEnv -> SrcSpan -> SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]+addClassBind γ l = mapM (uncurry (addBind l)) . classBinds (emb γ)++{- see tests/pos/polyfun for why you need everything in fixenv -}+addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+addCGEnv tx γ (eMsg, x, REx y tyy tyx) = do+ y' <- fresh+ γ' <- addCGEnv tx γ (eMsg, y', tyy)+ addCGEnv tx γ' (eMsg, x, tyx `F.subst1` (y, F.EVar y'))++addCGEnv tx γ (eMsg, sym, RAllE yy tyy tyx)+ = 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]+ (tyx', ttrue) = splitXRelatedRefs yy tyx++addCGEnv tx γ (_, x, t') = do+ idx <- fresh+ -- allowHOBinders <- allowHO <$> get+ let t = tx $ normalize idx t'+ let l = getLocation γ+ let γ' = γ { renv = insertREnv x t (renv γ) }+ tem <- getTemplates+ 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))+ => CGEnv -> F.Templates -> RRType r -> F.SortedReft+rTypeSortedReft' γ t+ = pruneUnsortedReft (feEnv $ fenv γ) t . f+ where+ f = rTypeSortedReft (emb γ)+++normalize :: Integer -> SpecType -> SpecType+normalize idx = normalizeVV idx . normalizePds++normalizeVV :: Integer -> SpecType -> SpecType+normalizeVV idx t@RApp{}+ | not (F.isNontrivialVV (rTypeValueVar t))+ = shiftVV t (F.vv $ Just idx)++normalizeVV _ t+ = t++--------------------------------------------------------------------------------+(+=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+--------------------------------------------------------------------------------+γ += (eMsg, x, r)+ | x == F.dummySymbol+ = return γ+ -- // | x `memberREnv` (renv γ)+ -- // = _dupBindErr x γ+ | otherwise+ = γ ++= (eMsg, x, r)++_dupBindError :: String -> F.Symbol -> CGEnv -> SpecType -> a+_dupBindError eMsg x γ r = panic Nothing s+ where+ s = unlines [ eMsg ++ " Duplicate binding for " ++ F.symbolString x+ , " New: " ++ showpp r+ , " Old: " ++ showpp (x `lookupREnv` renv γ) ]++--------------------------------------------------------------------------------+globalize :: CGEnv -> CGEnv+--------------------------------------------------------------------------------+globalize γ = γ {renv = globalREnv (renv γ)}++--------------------------------------------------------------------------------+(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+--------------------------------------------------------------------------------+(++=) γ (eMsg, x, t)+ = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ (eMsg, x, t)++--------------------------------------------------------------------------------+addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+--------------------------------------------------------------------------------+addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ++addEEnv :: CGEnv -> (F.Symbol, SpecType) -> CG CGEnv+addEEnv γ (x,t')= do+ idx <- fresh+ -- allowHOBinders <- allowHO <$> get+ let t = addRTyConInv (invs γ) $ normalize idx t'+ let l = getLocation γ+ let γ' = γ { renv = insertREnv x t (renv γ) }+ tem <- getTemplates+ is <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t+ modify (\s -> s { ebinds = ebinds s ++ (snd <$> is)})+ return $ γ' { fenv = insertsFEnv (fenv γ) is }+++(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv+(γ, _) +++= (x, e, t) = (γ {lcb = M.insert x e (lcb γ) }) += ("+++=", x, t)++(-=) :: CGEnv -> F.Symbol -> CGEnv+γ -= x = γ { renv = deleteREnv x (renv γ)+ , lcb = M.delete x (lcb γ)+ -- , fenv = removeFEnv x (fenv γ)+ }++(?=) :: (?callStack :: CallStack) => CGEnv -> F.Symbol -> Maybe SpecType+γ ?= x = lookupREnv x (renv γ)++------------------------------------------------------------------------+setLocation :: CGEnv -> Sp.Span -> CGEnv+------------------------------------------------------------------------+setLocation γ p = γ { cgLoc = Sp.push p $ cgLoc γ }++------------------------------------------------------------------------+setBind :: CGEnv -> Var -> CGEnv+------------------------------------------------------------------------+setBind γ x = γ `setLocation` Sp.Var x `setBind'` x++setBind' :: CGEnv -> Tg.TagKey -> CGEnv+setBind' γ k+ | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }+ | otherwise = γ++------------------------------------------------------------------------+setRecs :: CGEnv -> [Var] -> CGEnv+------------------------------------------------------------------------+setRecs γ xs = γ { recs = L.foldl' (flip S.insert) (recs γ) xs }++------------------------------------------------------------------------+setTRec :: CGEnv -> [(Var, SpecType)] -> CGEnv+------------------------------------------------------------------------+setTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'}+ where+ γ' = γ `setRecs` (fst <$> xts)+ trec' = fromMaybe M.empty $ trec γ+ xts' = first F.symbol <$> xts
+ src/Language/Haskell/Liquid/Constraint/Fresh.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Haskell.Liquid.Constraint.Fresh+ ( -- module Language.Haskell.Liquid.Types.Fresh+ -- , + refreshArgsTop+ , freshTyType+ , freshTyExpr+ , trueTy+ , addKuts+ )+ where++-- import Data.Maybe (catMaybes) -- , fromJust, isJust)+-- import Data.Bifunctor+-- import qualified Data.List as L+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.Hashable+import Control.Monad.State (gets, get, put, modify)+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.Constraint.Types+import qualified Language.Haskell.Liquid.GHC.Misc as GM+import Liquid.GHC.API as Ghc++--------------------------------------------------------------------------------+-- | This is all hardwiring stuff to CG ----------------------------------------+--------------------------------------------------------------------------------+instance Freshable CG Integer where+ fresh = do s <- get+ let n = freshIndex s+ put $ s { freshIndex = n + 1 }+ return n++--------------------------------------------------------------------------------+refreshArgsTop :: (Var, SpecType) -> CG SpecType+--------------------------------------------------------------------------------+refreshArgsTop (x, t)+ = do (t', su) <- refreshArgsSub t+ modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}+ return t'++--------------------------------------------------------------------------------+-- | Generation: Freshness -----------------------------------------------------+--------------------------------------------------------------------------------++-- | Right now, we generate NO new pvars. Rather than clutter code+-- with `uRType` calls, put it in one place where the above+-- invariant is /obviously/ enforced.+-- Constraint generation should ONLY use @freshTyType@ and @freshTyExpr@++freshTyType :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType+freshTyType allowTC k e τ = F.notracepp ("freshTyType: " ++ F.showpp k ++ GM.showPpr e)+ <$> freshTyReftype allowTC k (ofType τ)++freshTyExpr :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType+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++-- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive+-- definitions, and also to update the KVar profile.+addKVars :: KVKind -> SpecType -> CG ()+addKVars !k !t = do+ cfg <- gets (getConfig . ghcI)+ when True $ modify $ \s -> s { kvProf = updKVProf k ks (kvProf s) }+ when (isKut cfg k) $ addKuts k t+ where+ ks = F.KS $ S.fromList $ specTypeKVars t++isKut :: Config -> KVKind -> Bool+isKut _ (RecBindE _) = True+isKut cfg ProjectE = not (higherOrderFlag cfg) -- see ISSUE 1034, tests/pos/T1034.hs+isKut _ _ = False++addKuts :: (PPrint a) => a -> SpecType -> CG ()+addKuts _x t = modify $ \s -> s { kuts = mappend (F.KS ks) (kuts s) }+ where+ ks' = S.fromList $ specTypeKVars t+ ks+ | S.null ks' = ks'+ | otherwise = {- F.tracepp ("addKuts: " ++ showpp _x) -} ks'++specTypeKVars :: SpecType -> [F.KVar]+specTypeKVars = foldReft False (\ _ r ks -> kvarsExpr (F.reftPred $ ur_reft r) ++ ks) []++--------------------------------------------------------------------------------+trueTy :: Bool -> Type -> CG SpecType+--------------------------------------------------------------------------------+trueTy allowTC = ofType' >=> true allowTC++ofType' :: Type -> CG SpecType+ofType' = fixTy . ofType++fixTy :: SpecType -> CG SpecType+fixTy t = do tyi <- gets tyConInfo+ tce <- gets tyConEmbed+ return $ addTyConInfo tce tyi t++exprRefType :: CoreExpr -> SpecType+exprRefType = exprRefType_ M.empty++exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType+exprRefType_ γ (Let b e)+ = exprRefType_ (bindRefType_ γ b) e++exprRefType_ γ (Lam α e) | isTyVar α+ = RAllT (makeRTVar $ rTyVar α) (exprRefType_ γ e) mempty++exprRefType_ γ (Lam x e)+ = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)++exprRefType_ γ (Tick _ e)+ = exprRefType_ γ e++exprRefType_ γ (Var x)+ = M.lookupDefault (ofType $ varType x) x γ++exprRefType_ _ e+ = ofType $ exprType e++bindRefType_ :: M.HashMap Var SpecType -> Bind Var -> M.HashMap Var SpecType+bindRefType_ γ (Rec xes)+ = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes]++bindRefType_ γ (NonRec x e)+ = extendγ γ [(x, exprRefType_ γ e)]++extendγ :: (Eq k, Foldable t, Hashable k)+ => M.HashMap k v+ -> t (k, v)+ -> M.HashMap k v+extendγ γ xts+ = foldr (\(x,t) m -> M.insert x t m) γ xts
+ src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -0,0 +1,1143 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module defines the representation of Subtyping and WF Constraints,+-- and the code for syntax-directed constraint generation.++module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints, generateConstraintsWithEnv, caseEnv, consE ) where++import Prelude hiding (error)+import GHC.Stack ( CallStack )+import Liquid.GHC.API as Ghc hiding ( panic+ , (<+>)+ , text+ , vcat+ )+import qualified Language.Haskell.Liquid.GHC.Resugar as Rs+import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp+import qualified Language.Haskell.Liquid.GHC.Misc as GM -- ( isInternal, collectArguments, tickSrcSpan, showPpr )+import Text.PrettyPrint.HughesPJ ( text )+import Control.Monad.State+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Either.Extra (eitherToMaybe)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+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.Types.Visitor+import qualified Language.Fixpoint.Types as F+import qualified Language.Fixpoint.Types.Visitor as F+import Language.Haskell.Liquid.Constraint.Fresh ( addKuts, freshTyType, trueTy )+import Language.Haskell.Liquid.Constraint.Init ( initEnv, initCGI )+import Language.Haskell.Liquid.Constraint.Env+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.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.Transforms.CoreToLogic (weakenResult, runToLogic, coreToLogic)+import Language.Haskell.Liquid.Bare.DataType (dataConMap, makeDataConChecker)++--------------------------------------------------------------------------------+-- | Constraint Generation: Toplevel -------------------------------------------+--------------------------------------------------------------------------------+generateConstraints :: TargetInfo -> CGInfo+--------------------------------------------------------------------------------+generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info+ where+ act = do { γ <- initEnv info; consAct γ cfg info }+ cfg = getConfig info++generateConstraintsWithEnv :: TargetInfo -> CGInfo -> CGEnv -> CGInfo+--------------------------------------------------------------------------------+generateConstraintsWithEnv info cgi γ = {-# SCC "ConsGenEnv" #-} execState act cgi+ where+ act = consAct γ cfg info+ cfg = getConfig info++consAct :: CGEnv -> Config -> TargetInfo -> CG ()+consAct γ cfg info = do+ let sSpc = gsSig . giSpec $ info+ let gSrc = giSrc info+ when (gradual cfg) (mapM_ (addW . WfC γ . val . snd) (gsTySigs sSpc ++ gsAsmSigs sSpc))+ γ' <- foldM (consCBTop cfg info) γ (giCbs gSrc)+ -- Relational Checking: the following only runs when the list of relational specs is not empty+ (ψ, γ'') <- foldM (consAssmRel cfg info) ([], γ') (gsAsmRel sSpc ++ gsRelation sSpc)+ mapM_ (consRelTop cfg info γ'' ψ) (gsRelation sSpc)+ -- End: Relational Checking+ mapM_ (consClass γ) (gsMethods $ gsSig $ giSpec info)+ hcs <- gets hsCs+ hws <- gets hsWfs+ fcs <- concat <$> mapM (splitC (typeclass (getConfig info))) hcs+ fws <- concat <$> mapM splitW hws+ modify $ \st -> st { fEnv = fEnv st `mappend` feEnv (fenv γ)+ , cgLits = litEnv γ+ , cgConsts = cgConsts st `mappend` constEnv γ+ , fixCs = fcs+ , fixWfs = fws }++--------------------------------------------------------------------------------+-- | Ensure that the instance type is a subtype of the class type --------------+--------------------------------------------------------------------------------++consClass :: CGEnv -> (Var, MethodType LocSpecType) -> CG ()+consClass γ (x,mt)+ | Just ti <- tyInstance mt+ , Just tc <- tyClass mt+ = addC (SubC (γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc ti))) (val ti) (val tc)) ("cconsClass for " ++ GM.showPpr x)+consClass _ _+ = return ()++--------------------------------------------------------------------------------+consCBLet :: CGEnv -> CoreBind -> CG CGEnv+--------------------------------------------------------------------------------+consCBLet γ cb = do+ oldtcheck <- gets tcheck+ isStr <- doTermCheck (getConfig γ) cb+ -- TODO: yuck.+ modify $ \s -> s { tcheck = oldtcheck && isStr }+ γ' <- consCB (mkTCheck oldtcheck isStr) γ cb+ modify $ \s -> s{tcheck = oldtcheck}+ return γ'++--------------------------------------------------------------------------------+-- | Constraint Generation: Corebind -------------------------------------------+--------------------------------------------------------------------------------+consCBTop :: Config -> TargetInfo -> CGEnv -> CoreBind -> CG CGEnv+--------------------------------------------------------------------------------+consCBTop cfg info cgenv cb+ | all trustVar xs+ = foldM addB cgenv xs+ where+ xs = bindersOf cb+ tt = trueTy (typeclass cfg) . varType+ addB γ x = tt x >>= (\t -> γ += ("derived", F.symbol x, t))+ trustVar x = not (checkDerived cfg) && derivedVar (giSrc info) x++consCBTop _ _ γ cb+ = do oldtcheck <- gets tcheck+ -- lazyVars <- specLazy <$> get+ isStr <- doTermCheck (getConfig γ) cb+ modify $ \s -> s { tcheck = oldtcheck && isStr}+ -- remove invariants that came from the cb definition+ let (γ', i) = removeInvariant γ cb --- DIFF+ γ'' <- consCB (mkTCheck oldtcheck isStr) (γ'{cgVar = topBind cb}) cb+ modify $ \s -> s { tcheck = oldtcheck}+ return $ restoreInvariant γ'' i --- DIFF+ where+ topBind (NonRec v _) = Just v+ topBind (Rec [(v,_)]) = Just v+ topBind _ = Nothing++--------------------------------------------------------------------------------+consCB :: TCheck -> CGEnv -> CoreBind -> CG CGEnv+--------------------------------------------------------------------------------+-- do termination checking+consCB TerminationCheck γ (Rec xes)+ = do texprs <- gets termExprs+ modify $ \i -> i { recCount = recCount i + length xes }+ let xxes = mapMaybe (`lookup'` texprs) xs+ if null xxes+ then consCBSizedTys consBind γ xes+ else check xxes <$> consCBWithExprs consBind γ xes+ where+ xs = map fst xes+ check ys r | length ys == length xs = r+ | otherwise = panic (Just loc) msg+ msg = "Termination expressions must be provided for all mutually recursive binders"+ loc = getSrcSpan (head xs)+ lookup' k m = (k,) <$> M.lookup k m++-- don't do termination checking, but some strata checks?+consCB StrataCheck γ (Rec xes)+ = do xets <- forM xes $ \(x, e) -> (x, e,) <$> varTemplate γ (x, Just e)+ modify $ \i -> i { recCount = recCount i + length xes }+ let xts = [(x, to) | (x, _, to) <- xets]+ γ' <- foldM extender (γ `setRecs` (fst <$> xts)) xts+ mapM_ (consBind True γ') xets+ return γ'++-- don't do termination checking, and don't do any strata checks either?+consCB NoCheck γ (Rec xes)+ = do xets <- forM xes $ \(x, e) -> fmap (x, e,) (varTemplate γ (x, Just e))+ modify $ \i -> i { recCount = recCount i + length xes }+ let xts = [(x, to) | (x, _, to) <- xets]+ γ' <- foldM extender (γ `setRecs` (fst <$> xts)) xts+ mapM_ (consBind True γ') xets+ return γ'++-- | NV: Dictionaries are not checked, because+-- | class methods' preconditions are not satisfied+consCB _ γ (NonRec x _) | isDictionary x+ = do t <- trueTy (typeclass (getConfig γ)) (varType x)+ extender γ (x, Assumed t)+ where+ isDictionary = isJust . dlookup (denv γ)++consCB _ γ (NonRec x def)+ | Just (w, τ) <- grepDictionary def+ , Just d <- dlookup (denv γ) w+ = do st <- mapM (trueTy (typeclass (getConfig γ))) τ+ mapM_ addW (WfC γ <$> st)+ let xts = dmap (fmap (f st)) d+ let γ' = γ { denv = dinsert (denv γ) x xts }+ t <- trueTy (typeclass (getConfig γ)) (varType x)+ extender γ' (x, Assumed t)+ where+ f [t'] (RAllT α te _) = subsTyVarMeet' (ty_var_value α, t') te+ f (t':ts) (RAllT α te _) = f ts $ subsTyVarMeet' (ty_var_value α, t') te+ f _ _ = impossible Nothing "consCB on Dictionary: this should not happen"++consCB _ γ (NonRec x e)+ = do to <- varTemplate γ (x, Nothing)+ to' <- consBind False γ (x, e, to) >>= addPostTemplate γ+ extender γ (x, makeSingleton γ (simplify e) <$> to')++grepDictionary :: CoreExpr -> Maybe (Var, [Type])+grepDictionary = go []+ where+ go ts (App (Var w) (Type t)) = Just (w, reverse (t:ts))+ go ts (App e (Type t)) = go (t:ts) e+ go ts (App e (Var _)) = go ts e+ go ts (Let _ e) = go ts e+ go _ _ = Nothing++--------------------------------------------------------------------------------+consBind :: Bool -> CGEnv -> (Var, CoreExpr, Template SpecType) -> CG (Template SpecType)+--------------------------------------------------------------------------------+consBind _ _ (x, _, Assumed t)+ | RecSelId {} <- idDetails x -- don't check record selectors with assumed specs+ = return $ F.notracepp ("TYPE FOR SELECTOR " ++ show x) $ Assumed t++consBind isRec' γ (x, e, Asserted spect)+ = do let γ' = γ `setBind` x+ (_,πs,_) = bkUniv spect+ cgenv <- foldM addPToEnv γ' πs+ cconsE cgenv e (weakenResult (typeclass (getConfig γ)) x spect)+ when (F.symbol x `elemHEnv` holes γ) $+ -- have to add the wf constraint here for HOLEs so we have the proper env+ addW $ WfC cgenv $ fmap killSubst spect+ addIdA x (defAnn isRec' spect)+ return $ Asserted spect++consBind isRec' γ (x, e, Internal spect)+ = do let γ' = γ `setBind` x+ (_,πs,_) = bkUniv spect+ γπ <- foldM addPToEnv γ' πs+ let γπ' = γπ {cerr = Just $ ErrHMeas (getLocation γπ) (pprint x) (text explanation)}+ cconsE γπ' e spect+ when (F.symbol x `elemHEnv` holes γ) $+ -- have to add the wf constraint here for HOLEs so we have the proper env+ addW $ WfC γπ $ fmap killSubst spect+ addIdA x (defAnn isRec' spect)+ return $ Internal spect+ where+ explanation = "Cannot give singleton type to the function definition."++consBind isRec' γ (x, e, Assumed spect)+ = do let γ' = γ `setBind` x+ γπ <- foldM addPToEnv γ' πs+ cconsE γπ e =<< true (typeclass (getConfig γ)) spect+ addIdA x (defAnn isRec' spect)+ return $ Asserted spect+ where πs = ty_preds $ toRTypeRep spect++consBind isRec' γ (x, e, Unknown)+ = do t' <- consE (γ `setBind` x) e+ t <- topSpecType x t'+ addIdA x (defAnn isRec' t)+ when (GM.isExternalId x) (addKuts x t)+ return $ Asserted t++killSubst :: RReft -> RReft+killSubst = fmap killSubstReft++killSubstReft :: F.Reft -> F.Reft+killSubstReft = trans kv () ()+ where+ kv = defaultVisitor { txExpr = ks }+ ks _ (F.PKVar k _) = F.PKVar k mempty+ ks _ p = p++defAnn :: Bool -> t -> Annot t+defAnn True = AnnRDf+defAnn False = AnnDef++addPToEnv :: CGEnv+ -> PVar RSort -> CG CGEnv+addPToEnv γ π+ = do γπ <- γ += ("addSpec1", pname π, pvarRType π)+ foldM (+=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π]++--------------------------------------------------------------------------------+-- | Bidirectional Constraint Generation: CHECKING -----------------------------+--------------------------------------------------------------------------------+cconsE :: CGEnv -> CoreExpr -> SpecType -> CG ()+--------------------------------------------------------------------------------+cconsE g e t = do+ -- NOTE: tracing goes here+ -- traceM $ printf "cconsE:\n expr = %s\n exprType = %s\n lqType = %s\n" (showPpr e) (showPpr (exprType e)) (showpp t)+ cconsE' g e t++--------------------------------------------------------------------------------+cconsE' :: CGEnv -> CoreExpr -> SpecType -> CG ()+--------------------------------------------------------------------------------+cconsE' γ e t+ | Just (Rs.PatSelfBind _x e') <- Rs.lift e+ = cconsE' γ e' t++ | Just (Rs.PatSelfRecBind x e') <- Rs.lift e+ = let γ' = γ { grtys = insertREnv (F.symbol x) t (grtys γ)}+ in void $ consCBLet γ' (Rec [(x, e')])++cconsE' γ e@(Let b@(NonRec x _) ee) t+ = do sp <- gets specLVars+ if x `S.member` sp+ then cconsLazyLet γ e t+ else do γ' <- consCBLet γ b+ cconsE γ' ee t++cconsE' γ e (RAllP p t)+ = cconsE γ' e t''+ where+ t' = replacePredsWithRefs su <$> t+ su = (uPVar p, pVartoRConc p)+ (css, t'') = splitConstraints (typeclass (getConfig γ)) t'+ γ' = L.foldl' addConstraints γ css++cconsE' γ (Let b e) t+ = do γ' <- consCBLet γ b+ cconsE γ' e t++cconsE' γ (Case e x _ cases) t+ = do γ' <- consCBLet γ (NonRec x e)+ forM_ cases $ cconsCase γ' x t nonDefAlts+ where+ nonDefAlts = [a | Alt a _ _ <- cases, a /= DEFAULT]+ _msg = "cconsE' #nonDefAlts = " ++ show (length nonDefAlts)++cconsE' γ (Lam α e) (RAllT α' t r) | isTyVar α+ = do γ' <- updateEnvironment γ α+ addForAllConstraint γ' α e (RAllT α' t r)+ cconsE γ' e $ subsTyVarMeet' (ty_var_value α', rVar α) t++cconsE' γ (Lam x e) (RFun y i ty t r)+ | not (isTyVar x)+ = do γ' <- γ += ("cconsE", x', ty)+ cconsE γ' e t'+ addFunctionConstraint γ x e (RFun x' i ty t' r')+ addIdA x (AnnDef ty)+ where+ x' = F.symbol x+ t' = t `F.subst1` (y, F.EVar x')+ r' = r `F.subst1` (y, F.EVar x')++cconsE' γ (Tick tt e) t+ = cconsE (γ `setLocation` Sp.Tick tt) e t++cconsE' γ (Cast e co) t+ -- See Note [Type classes with a single method]+ | Just f <- isClassConCo co+ = cconsE γ (f e) t++cconsE' γ e@(Cast e' c) t+ = do t' <- castTy γ (exprType e) e' c+ addC (SubC γ (F.notracepp ("Casted Type for " ++ GM.showPpr e ++ "\n init type " ++ showpp t) t') t) ("cconsE Cast: " ++ GM.showPpr e)++cconsE' γ e t+ = do te <- consE γ e+ te' <- instantiatePreds γ e te >>= addPost γ+ addC (SubC γ te' t) ("cconsE: " ++ "\n t = " ++ showpp t ++ "\n te = " ++ showpp te ++ GM.showPpr e)++lambdaSingleton :: CGEnv -> F.TCEmb TyCon -> Var -> CoreExpr -> CG (UReft F.Reft)+lambdaSingleton γ tce x e+ | higherOrderFlag γ+ = do expr <- lamExpr γ e+ return $ case expr of+ Just e' -> uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'+ _ -> mempty+ where+ sx = typeSort tce $ Ghc.expandTypeSynonyms $ varType x+lambdaSingleton _ _ _ _+ = return mempty++addForAllConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()+addForAllConstraint γ _ _ (RAllT rtv rt rr)+ | F.isTauto rr+ = return ()+ | otherwise+ = do t' <- true (typeclass (getConfig γ)) rt+ let truet = RAllT rtv $ unRAllP t'+ addC (SubC γ (truet mempty) $ truet rr) "forall constraint true"+ where unRAllP (RAllT a t r) = RAllT a (unRAllP t) r+ unRAllP (RAllP _ t) = unRAllP t+ unRAllP t = t+addForAllConstraint γ _ _ _+ = impossible (Just $ getLocation γ) "addFunctionConstraint: called on non function argument"+++addFunctionConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()+addFunctionConstraint γ x e (RFun y i ty t r)+ = do ty' <- true (typeclass (getConfig γ)) ty+ t' <- true (typeclass (getConfig γ)) t+ let truet = RFun y i ty' t'+ lamE <- lamExpr γ e+ case (lamE, higherOrderFlag γ) of+ (Just e', True) -> do tce <- gets tyConEmbed+ let sx = typeSort tce $ varType x+ let ref = uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'+ addC (SubC γ (truet ref) $ truet r) "function constraint singleton"+ _ -> addC (SubC γ (truet mempty) $ truet r) "function constraint true"+addFunctionConstraint γ _ _ _+ = impossible (Just $ getLocation γ) "addFunctionConstraint: called on non function argument"++splitConstraints :: TyConable c+ => Bool -> RType c tv r -> ([[(F.Symbol, RType c tv r)]], RType c tv r)+splitConstraints allowTC (RRTy cs _ OCons t)+ = let (css, t') = splitConstraints allowTC t in (cs:css, t')+splitConstraints allowTC (RFun x i tx@(RApp c _ _ _) t r) | isErasable c+ = let (css, t') = splitConstraints allowTC t in (css, RFun x i tx t' r)+ where isErasable = if allowTC then isEmbeddedDict else isClass+splitConstraints _ t+ = ([], t)++-------------------------------------------------------------------+-- | @instantiatePreds@ peels away the universally quantified @PVars@+-- of a @RType@, generates fresh @Ref@ for them and substitutes them+-- in the body.+-------------------------------------------------------------------+instantiatePreds :: CGEnv+ -> CoreExpr+ -> SpecType+ -> CG SpecType+instantiatePreds γ e (RAllP π t)+ = do r <- freshPredRef γ e π+ instantiatePreds γ e $ replacePreds "consE" t [(π, r)]++instantiatePreds _ _ t0+ = return t0+++-------------------------------------------------------------------+cconsLazyLet :: CGEnv+ -> CoreExpr+ -> SpecType+ -> CG ()+cconsLazyLet γ (Let (NonRec x ex) e) t+ = do tx <- trueTy (typeclass (getConfig γ)) (varType x)+ γ' <- (γ, "Let NonRec") +++= (F.symbol x, ex, tx)+ cconsE γ' e t+cconsLazyLet _ _ _+ = panic Nothing "Constraint.Generate.cconsLazyLet called on invalid inputs"++--------------------------------------------------------------------------------+-- | Bidirectional Constraint Generation: SYNTHESIS ----------------------------+--------------------------------------------------------------------------------+consE :: CGEnv -> CoreExpr -> CG SpecType+--------------------------------------------------------------------------------+consE γ e+ | patternFlag γ+ , Just p <- Rs.lift e+ = consPattern γ (F.notracepp "CONSE-PATTERN: " p) (exprType e)++-- NV CHECK 3 (unVar and does this hack even needed?)+-- NV (below) is a hack to type polymorphic axiomatized functions+-- no need to check this code with flag, the axioms environment with+-- is empty if there is no axiomatization.++-- [NOTE: PLE-OPT] We *disable* refined instantiation for+-- reflected functions inside proofs.++-- If datacon definitions have references to self for fancy termination,+-- ignore them at the construction.+consE γ (Var x) | GM.isDataConId x+ = do t0 <- varRefType γ x+ -- NV: The check is expected to fail most times, so+ -- it is cheaper than direclty fmap ignoreSelf.+ let hasSelf = selfSymbol `elem` F.syms t0+ let t = if hasSelf+ then fmap ignoreSelf <$> t0+ else t0+ addLocA (Just x) (getLocation γ) (varAnn γ x t)+ return t++consE γ (Var x)+ = do t <- varRefType γ x+ addLocA (Just x) (getLocation γ) (varAnn γ x t)+ return t++consE _ (Lit c)+ = refreshVV $ uRType $ literalFRefType c++consE γ e'@(App e a@(Type τ))+ = do RAllT α te _ <- checkAll ("Non-all TyApp with expr", e) γ <$> consE γ e+ t <- if not (nopolyinfer (getConfig γ)) && isPos α && isGenericVar (ty_var_value α) te+ then freshTyType (typeclass (getConfig γ)) TypeInstE e τ+ else trueTy (typeclass (getConfig γ)) τ+ addW $ WfC γ t+ t' <- refreshVV t+ tt0 <- instantiatePreds γ e' (subsTyVarMeet' (ty_var_value α, t') te)+ let tt = makeSingleton γ (simplify e') $ subsTyReft γ (ty_var_value α) τ tt0+ return $ case rTVarToBind α of+ Just (x, _) -> maybe (checkUnbound γ e' x tt a) (F.subst1 tt . (x,)) (argType τ)+ Nothing -> tt+ where+ isPos α = not (extensionality (getConfig γ)) || rtv_is_pol (ty_var_info α)++consE γ e'@(App e a) | Just aDict <- getExprDict γ a+ = case dhasinfo (dlookup (denv γ) aDict) (getExprFun γ e) of+ Just riSig -> return $ fromRISig riSig+ _ -> do+ ([], πs, te) <- bkUniv <$> consE γ e+ te' <- instantiatePreds γ e' $ foldr RAllP te πs+ (γ', te''') <- dropExists γ te'+ te'' <- dropConstraints γ te'''+ updateLocA {- πs -} (exprLoc e) te''+ let RFun x _ tx t _ = checkFun ("Non-fun App with caller ", e') γ te''+ cconsE γ' a tx+ addPost γ' $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)++consE γ e'@(App e a)+ = do ([], πs, te) <- bkUniv <$> consE γ {- GM.tracePpr ("APP-EXPR: " ++ GM.showPpr (exprType e)) -} e+ te1 <- instantiatePreds γ e' $ foldr RAllP te πs+ (γ', te2) <- dropExists γ te1+ te3 <- dropConstraints γ te2+ updateLocA (exprLoc e) te3+ let RFun x _ tx t _ = checkFun ("Non-fun App with caller ", e') γ te3+ cconsE γ' a tx+ makeSingleton γ' (simplify e') <$> addPost γ' (maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ $ simplify a))++consE γ (Lam α e) | isTyVar α+ = do γ' <- updateEnvironment γ α+ t' <- consE γ' e+ return $ RAllT (makeRTVar $ rTyVar α) t' mempty++consE γ e@(Lam x e1)+ = do tx <- freshTyType (typeclass (getConfig γ)) LamE (Var x) τx+ γ' <- γ += ("consE", F.symbol x, tx)+ t1 <- consE γ' e1+ addIdA x $ AnnDef tx+ addW $ WfC γ tx+ tce <- gets tyConEmbed+ lamSing <- lambdaSingleton γ tce x e1+ return $ RFun (F.symbol x) (mkRFInfo $ getConfig γ) tx t1 lamSing+ where+ FunTy { ft_arg = τx } = exprType e++consE γ e@(Let _ _)+ = cconsFreshE LetE γ e++consE γ e@(Case _ _ _ [_])+ | Just p@Rs.PatProject{} <- Rs.lift e+ = consPattern γ p (exprType e)++consE γ e@(Case _ _ _ cs)+ = cconsFreshE (caseKVKind cs) γ e++consE γ (Tick tt e)+ = do t <- consE (setLocation γ (Sp.Tick tt)) e+ addLocA Nothing (GM.tickSrcSpan tt) (AnnUse t)+ return t++-- See Note [Type classes with a single method]+consE γ (Cast e co)+ | Just f <- isClassConCo co+ = consE γ (f e)++consE γ e@(Cast e' c)+ = castTy γ (exprType e) e' c++consE γ e@(Coercion _)+ = trueTy (typeclass (getConfig γ)) $ exprType e++consE _ e@(Type t)+ = panic Nothing $ "consE cannot handle type " ++ GM.showPpr (e, t)++caseKVKind ::[Alt Var] -> KVKind+caseKVKind [Alt (DataAlt _) _ (Var _)] = ProjectE+caseKVKind cs = CaseE (length cs)++updateEnvironment :: CGEnv -> TyVar -> CG CGEnv+updateEnvironment γ a+ | isValKind (tyVarKind a)+ = γ += ("varType", F.symbol $ varName a, kindToRType $ tyVarKind a)+ | otherwise+ = return γ++getExprFun :: CGEnv -> CoreExpr -> Var+getExprFun γ e = go e+ where+ go (App x (Type _)) = go x+ go (Var x) = x+ go _ = panic (Just (getLocation γ)) msg+ msg = "getFunName on \t" ++ GM.showPpr e++-- | `exprDict e` returns the dictionary `Var` inside the expression `e`+getExprDict :: CGEnv -> CoreExpr -> Maybe Var+getExprDict γ = go+ where+ go (Var x) = case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing}+ go (Tick _ e) = go e+ go (App a (Type _)) = go a+ go (Let _ e) = go e+ go _ = Nothing++--------------------------------------------------------------------------------+-- | With GADTs and reflection, refinements can contain type variables,+-- as 'coercions' (see ucsd-progsys/#1424). At application sites, we+-- must also substitute those from the refinements (not just the types).+-- https://github.com/ucsd-progsys/liquidhaskell/issues/1424+--+-- see: tests/ple/{pos,neg}/T1424.hs+--+--------------------------------------------------------------------------------++subsTyReft :: CGEnv -> RTyVar -> Type -> SpecType -> SpecType+subsTyReft γ a t = mapExprReft (\_ -> F.applyCoSub coSub)+ where+ coSub = M.fromList [(F.symbol a, typeSort (emb γ) t)]++--------------------------------------------------------------------------------+-- | Type Synthesis for Special @Pattern@s -------------------------------------+--------------------------------------------------------------------------------+consPattern :: CGEnv -> Rs.Pattern -> Type -> CG SpecType++{- [NOTE] special type rule for monadic-bind application++ G |- e1 ~> m tx G, x:tx |- e2 ~> m t+ -----------------------------------------+ G |- (e1 >>= \x -> e2) ~> m t+ -}++consPattern γ (Rs.PatBind e1 x e2 _ _ _ _ _) _ = do+ tx <- checkMonad (msg, e1) γ <$> consE γ e1+ γ' <- γ += ("consPattern", F.symbol x, tx)+ addIdA x (AnnDef tx)+ consE γ' e2+ where+ msg = "This expression has a refined monadic type; run with --no-pattern-inline: "++{- [NOTE] special type rule for monadic-return++ G |- e ~> et+ ------------------------+ G |- return e ~ m et+ -}+consPattern γ (Rs.PatReturn e m _ _ _) t = do+ et <- F.notracepp "Cons-Pattern-Ret" <$> consE γ e+ mt <- trueTy (typeclass (getConfig γ)) m+ tt <- trueTy (typeclass (getConfig γ)) t+ return (mkRAppTy mt et tt) -- /// {- $ RAppTy mt et mempty -}++{- [NOTE] special type rule for field projection, is+ t = G(x) ti = Proj(t, i)+ -----------------------------------------+ G |- case x of C [y1...yn] -> yi : ti+ -}++consPattern γ (Rs.PatProject xe _ τ c ys i) _ = do+ let yi = ys !! i+ t <- (addW . WfC γ) <<= freshTyType (typeclass (getConfig γ)) ProjectE (Var yi) τ+ γ' <- caseEnv γ xe [] (DataAlt c) ys (Just [i])+ ti <- {- γ' ??= yi -} varRefType γ' yi+ addC (SubC γ' ti t) "consPattern:project"+ return t++consPattern γ (Rs.PatSelfBind _ e) _ =+ consE γ e++consPattern γ p@Rs.PatSelfRecBind{} _ =+ cconsFreshE LetE γ (Rs.lower p)++mkRAppTy :: SpecType -> SpecType -> SpecType -> SpecType+mkRAppTy mt et RAppTy{} = RAppTy mt et mempty+mkRAppTy _ et (RApp c [_] [] _) = RApp c [et] [] mempty+mkRAppTy _ _ _ = panic Nothing "Unexpected return-pattern"++checkMonad :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType+checkMonad x g = go . unRRTy+ where+ go (RApp _ ts [] _)+ | not (null ts) = last ts+ go (RAppTy _ t _) = t+ go t = checkErr x g t++unRRTy :: SpecType -> SpecType+unRRTy (RRTy _ _ _ t) = unRRTy t+unRRTy t = t++--------------------------------------------------------------------------------+castTy :: CGEnv -> Type -> CoreExpr -> Coercion -> CG SpecType+castTy' :: CGEnv -> Type -> CoreExpr -> CG SpecType+--------------------------------------------------------------------------------+castTy γ t e (AxiomInstCo ca _ _)+ = fromMaybe <$> castTy' γ t e <*> lookupNewType (coAxiomTyCon ca)++castTy γ t e (SymCo (AxiomInstCo ca _ _))+ = do mtc <- lookupNewType (coAxiomTyCon ca)+ F.forM_ mtc (cconsE γ e)+ castTy' γ t e++castTy γ t e _+ = castTy' γ t e+++castTy' γ τ (Var x)+ = do t0 <- trueTy (typeclass (getConfig γ)) τ+ tx <- varRefType γ x+ let t = mergeCastTys t0 tx+ let ce = if typeclass (getConfig γ) && noADT (getConfig γ) then F.expr x+ else eCoerc (typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x)+ (typeSort (emb γ) τ)+ $ F.expr x+ return (t `strengthen` uTop (F.uexprReft ce) {- `F.meet` tx -})+ where eCoerc s t e+ | s == t = e+ | otherwise = F.ECoerc s t e++castTy' γ t (Tick _ e)+ = castTy' γ t e++castTy' _ _ e+ = panic Nothing $ "castTy cannot handle expr " ++ GM.showPpr e+++{-+mergeCastTys tcorrect trefined+ tcorrect has the correct GHC skeleton,+ trefined has the correct refinements (before coercion)+ mergeCastTys keeps the trefined when the two GHC types match+-}++mergeCastTys :: SpecType -> SpecType -> SpecType+mergeCastTys t1 t2+ | toType False t1 == toType False t2+ = t2+mergeCastTys (RApp c1 ts1 ps1 r1) (RApp c2 ts2 _ _)+ | c1 == c2+ = RApp c1 (zipWith mergeCastTys ts1 ts2) ps1 r1+mergeCastTys t _+ = t++{-+showCoercion :: Coercion -> String+showCoercion (AxiomInstCo co1 co2 co3)+ = "AxiomInstCo " ++ showPpr co1 ++ "\t\t " ++ showPpr co2 ++ "\t\t" ++ showPpr co3 ++ "\n\n" +++ "COAxiom Tycon = " ++ showPpr (coAxiomTyCon co1) ++ "\nBRANCHES\n" ++ concatMap showBranch bs+ where+ bs = fromBranchList $ co_ax_branches co1+ showBranch ab = "\nCoAxiom \nLHS = " ++ showPpr (coAxBranchLHS ab) +++ "\nRHS = " ++ showPpr (coAxBranchRHS ab)+showCoercion (SymCo c)+ = "Symc :: " ++ showCoercion c+showCoercion c+ = "Coercion " ++ showPpr c+-}++isClassConCo :: Coercion -> Maybe (Expr Var -> Expr Var)+-- See Note [Type classes with a single method]+isClassConCo co+ | Pair t1 t2 <- coercionKind co+ , isClassPred t2+ , (tc,ts) <- splitTyConApp t2+ , [dc] <- tyConDataCons tc+ , [tm] <- map irrelevantMult (Ghc.dataConOrigArgTys dc)+ -- tcMatchTy because we have to instantiate the class tyvars+ , Just _ <- ruleMatchTyX (mkUniqSet $ tyConTyVars tc) (mkRnEnv2 emptyInScopeSet) emptyTvSubstEnv tm t1+ = Just (\e -> mkCoreConApps dc $ map Type ts ++ [e])++ | otherwise+ = Nothing+ where+ ruleMatchTyX = ruleMatchTyKiX -- TODO: is this correct?++----------------------------------------------------------------------+-- Note [Type classes with a single method]+----------------------------------------------------------------------+-- GHC 7.10 encodes type classes with a single method as newtypes and+-- `cast`s between the method and class type instead of applying the+-- class constructor. Just rewrite the core to what we're used to+-- seeing..+--+-- specifically, we want to rewrite+--+-- e `cast` ((a -> b) ~ C)+--+-- to+--+-- D:C e+--+-- but only when+--+-- D:C :: (a -> b) -> C++--------------------------------------------------------------------------------+-- | @consFreshE@ is used to *synthesize* types with a **fresh template**.+-- e.g. at joins, recursive binders, polymorphic instantiations etc. It is+-- the "portal" that connects `consE` (synthesis) and `cconsE` (checking)+--------------------------------------------------------------------------------+cconsFreshE :: KVKind -> CGEnv -> CoreExpr -> CG SpecType+cconsFreshE kvkind γ e = do+ t <- freshTyType (typeclass (getConfig γ)) kvkind e $ exprType e+ addW $ WfC γ t+ cconsE γ e t+ return t+--------------------------------------------------------------------------------++checkUnbound :: (Show a, Show a2, F.Subable a)+ => CGEnv -> CoreExpr -> F.Symbol -> a -> a2 -> a+checkUnbound γ e x t a+ | x `notElem` F.syms t = t+ | otherwise = panic (Just $ getLocation γ) msg+ where+ msg = unlines [ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t+ , "In"+ , GM.showPpr e+ , "Arg = "+ , show a+ ]++dropExists :: CGEnv -> SpecType -> CG (CGEnv, SpecType)+dropExists γ (REx x tx t) = (, t) <$> γ += ("dropExists", x, tx)+dropExists γ t = return (γ, t)++dropConstraints :: CGEnv -> SpecType -> CG SpecType+dropConstraints cgenv (RFun x i tx@(RApp c _ _ _) t r) | isErasable c+ = flip (RFun x i tx) r <$> dropConstraints cgenv t+ where+ isErasable = if typeclass (getConfig cgenv) then isEmbeddedDict else isClass+dropConstraints cgenv (RRTy cts _ OCons rt)+ = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv xts+ addC (SubC γ' t1 t2) "dropConstraints"+ dropConstraints cgenv rt+ where+ (xts, t1, t2) = envToSub cts++dropConstraints _ t = return t++-------------------------------------------------------------------------------------+cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> CoreAlt -> CG ()+-------------------------------------------------------------------------------------+cconsCase γ x t acs (Alt ac ys ce)+ = do cγ <- caseEnv γ x acs ac ys mempty+ cconsE cγ ce t++{-++case x :: List b of+ Emp -> e++ Emp :: tdc forall a. {v: List a | cons v === 0}+ x :: xt List b+ ys == binders []++-}+-------------------------------------------------------------------------------------+caseEnv :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> Maybe [Int] -> CG CGEnv+-------------------------------------------------------------------------------------+caseEnv γ x _ (DataAlt c) ys pIs = do++ let (x' : ys') = F.symbol <$> (x:ys)+ xt0 <- checkTyCon ("checkTycon cconsCase", x) γ <$> γ ??= x+ let rt = shiftVV xt0 x'+ tdc <- γ ??= dataConWorkId c >>= refreshVV+ let (rtd,yts',_) = unfoldR tdc rt ys+ yts <- projectTypes (typeclass (getConfig γ)) pIs yts'+ 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 cbs = safeZip "cconsCase" (x':ys')+ (map (`F.subst1` (selfSymbol, F.EVar x'))+ (xt0 : yts))+ cγ' <- addBinders γ x' cbs+ addBinders cγ' x' [(x', substSelf <$> xt)]+ where allowTC = typeclass (getConfig γ)++caseEnv γ x acs a _ _ = do+ let x' = F.symbol x+ xt' <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)+ addBinders γ x' [(x', xt')]+++------------------------------------------------------+-- SELF special substitutions+------------------------------------------------------++substSelf :: UReft F.Reft -> UReft F.Reft+substSelf (MkUReft r p) = MkUReft (substSelfReft r) p++substSelfReft :: F.Reft -> F.Reft+substSelfReft (F.Reft (v, e)) = F.Reft (v, F.subst1 e (selfSymbol, F.EVar v))++ignoreSelf :: F.Reft -> F.Reft+ignoreSelf = F.mapExpr (\r -> if selfSymbol `elem` F.syms r then F.PTrue else r)++--------------------------------------------------------------------------------+-- | `projectTypes` masks (i.e. true's out) all types EXCEPT those+-- at given indices; it is used to simplify the environment used+-- when projecting out fields of single-ctor datatypes.+--------------------------------------------------------------------------------+projectTypes :: Bool -> Maybe [Int] -> [SpecType] -> CG [SpecType]+projectTypes _ Nothing ts = return ts+projectTypes allowTC (Just ints) ts = mapM (projT ints) (zip [0..] ts)+ where+ projT is (j, t)+ | j `elem` is = return t+ | otherwise = true allowTC t++altReft :: CGEnv -> [AltCon] -> AltCon -> F.Reft+altReft _ _ (LitAlt l) = literalFReft l+altReft γ acs DEFAULT = mconcat ([notLiteralReft l | LitAlt l <- acs] ++ [notDataConReft d | DataAlt d <- acs])+ where+ notLiteralReft = maybe mempty F.notExprReft . snd . literalConst (emb γ)+ notDataConReft d | exactDC (getConfig γ)+ = F.Reft (F.vv_, F.PNot (F.EApp (F.EVar $ makeDataConChecker d) (F.EVar F.vv_)))+ | otherwise = mempty+altReft _ _ _ = panic Nothing "Constraint : altReft"++unfoldR :: SpecType -> SpecType -> [Var] -> (SpecType, [SpecType], SpecType)+unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)+ where+ tbody = instantiatePvs (instantiateTys td ts) (reverse rs)+ ((ys0,_,yts',_), rt) = safeBkArrow (F.notracepp msg $ instantiateTys tbody tvs')+ msg = "INST-TY: " ++ F.showpp (td, ts, tbody, ys, tvs')+ yts'' = zipWith F.subst sus (yts'++[rt])+ (t3,yts) = (last yts'', init yts'')+ sus = F.mkSubst <$> L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys']+ (αs, ys') = mapSnd (F.symbol <$>) $ L.partition isTyVar ys+ tvs' :: [SpecType]+ tvs' = rVar <$> αs+ tvys = ofType . varType <$> αs++unfoldR _ _ _ = panic Nothing "Constraint.hs : unfoldR"++instantiateTys :: SpecType -> [SpecType] -> SpecType+instantiateTys = L.foldl' go+ where+ go (RAllT α tbody _) t = subsTyVarMeet' (ty_var_value α, t) tbody+ go _ _ = panic Nothing "Constraint.instantiateTy"++instantiatePvs :: SpecType -> [SpecProp] -> SpecType+instantiatePvs = L.foldl' go+ where+ go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]+ go t _ = errorP "" ("Constraint.instantiatePvs: t = " ++ showpp t)++checkTyCon :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType+checkTyCon _ _ t@RApp{} = t+checkTyCon x g t = checkErr x g t++checkFun :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType+checkFun _ _ t@RFun{} = t+checkFun x g t = checkErr x g t++checkAll :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType+checkAll _ _ t@RAllT{} = t+checkAll x g t = checkErr x g t++checkErr :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType+checkErr (msg, e) γ t = panic (Just sp) $ msg ++ GM.showPpr e ++ ", type: " ++ showpp t+ where+ sp = getLocation γ++varAnn :: CGEnv -> Var -> t -> Annot t+varAnn γ x t+ | x `S.member` recs γ = AnnLoc (getSrcSpan x)+ | otherwise = AnnUse t++-----------------------------------------------------------------------+-- | Helpers: Creating Fresh Refinement -------------------------------+-----------------------------------------------------------------------+freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp+freshPredRef γ e (PV _ (PVProp 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 ]+ γ' <- foldM (+=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]+ addW $ WfC γ' t+ return $ RProp targs t++freshPredRef _ _ (PV _ PVHProp _ _)+ = todo Nothing "EFFECTS:freshPredRef"+++--------------------------------------------------------------------------------+-- | Helpers: Creating Refinement Types For Various Things ---------------------+--------------------------------------------------------------------------------+argType :: Type -> Maybe F.Expr+argType (LitTy (NumTyLit i)) = mkI i+argType (LitTy (StrTyLit s)) = mkS $ bytesFS s+argType (TyVarTy x) = Just $ F.EVar $ F.symbol $ varName x+argType t+ | F.symbol (GM.showPpr t) == anyTypeSymbol+ = Just $ F.EVar anyTypeSymbol+argType _ = Nothing+++argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr+argExpr _ (Var v) = Just $ F.eVar v+argExpr γ (Lit c) = snd $ literalConst (emb γ) c+argExpr γ (Tick _ e) = argExpr γ e+argExpr γ (App e (Type _)) = argExpr γ e+argExpr _ _ = Nothing+++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+ (\x -> todo Nothing ("coreToLogic not working lamExpr: " ++ x))+ (coreToLogic allowTC e)++--------------------------------------------------------------------------------+(??=) :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType+--------------------------------------------------------------------------------+γ ??= x = case M.lookup x' (lcb γ) of+ Just e -> consE (γ -= x') e+ Nothing -> refreshTy tx+ where+ x' = F.symbol x+ tx = fromMaybe tt (γ ?= x')+ tt = ofType $ varType x+++--------------------------------------------------------------------------------+varRefType :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType+--------------------------------------------------------------------------------+varRefType γ x =+ varRefType' γ x <$> (γ ??= x) -- F.tracepp (printf "varRefType x = [%s]" (showpp x))++varRefType' :: CGEnv -> Var -> SpecType -> SpecType+varRefType' γ x t'+ | Just tys <- trec γ, Just tr <- M.lookup x' tys+ = strengthen' tr xr+ | otherwise+ = strengthen' t' xr+ where+ xr = singletonReft x+ x' = F.symbol x+ strengthen' | higherOrderFlag γ = strengthenMeet+ | otherwise = strengthenTop++-- | create singleton types for function application+makeSingleton :: CGEnv -> CoreExpr -> SpecType -> SpecType+makeSingleton γ cexpr t+ | higherOrderFlag γ, App f x <- simplify cexpr+ = case (funExpr γ f, argForAllExpr x) of+ (Just f', Just x')+ | not (if typeclass (getConfig γ) then GM.isEmbeddedDictExpr x else GM.isPredExpr x) -- (isClassPred $ exprType x)+ -> strengthenMeet t (uTop $ F.exprReft (F.EApp f' x'))+ (Just f', Just _)+ -> strengthenMeet t (uTop $ F.exprReft f')+ _ -> t+ | rankNTypes (getConfig γ)+ = case argExpr γ (simplify cexpr) of+ Just e' -> strengthenMeet t $ uTop (F.exprReft e')+ _ -> t+ | otherwise+ = t+ where+ argForAllExpr (Var x)+ | rankNTypes (getConfig γ)+ , Just e <- M.lookup x (forallcb γ)+ = Just e+ argForAllExpr e+ = argExpr γ e++++funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr++funExpr _ (Var v)+ = Just $ F.EVar (F.symbol v)++funExpr γ (App e1 e2)+ = case (funExpr γ e1, argExpr γ e2) of+ (Just e1', Just e2') | not (if typeclass (getConfig γ) then GM.isEmbeddedDictExpr e2+ else GM.isPredExpr e2) -- (isClassPred $ exprType e2)+ -> Just (F.EApp e1' e2')+ (Just e1', Just _) -> Just e1'+ _ -> Nothing++funExpr _ _+ = Nothing++simplify :: CoreExpr -> CoreExpr+simplify (Tick _ e) = simplify e+simplify (App e (Type _)) = simplify e+simplify (App e1 e2) = App (simplify e1) (simplify e2)+simplify (Lam x e) | isTyVar x = simplify e+simplify e = e+++singletonReft :: (F.Symbolic a) => a -> UReft F.Reft+singletonReft = uTop . F.symbolReft . F.symbol++-- | 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 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 t _ = t++-- topMeet :: (PPrint r, F.Reftable r) => r -> r -> r+-- topMeet r r' = r `F.meet` r'++--------------------------------------------------------------------------------+-- | Cleaner Signatures For Rec-bindings ---------------------------------------+--------------------------------------------------------------------------------+exprLoc :: CoreExpr -> Maybe SrcSpan+exprLoc (Tick tt _) = Just $ GM.tickSrcSpan tt+exprLoc (App e a) | isType a = exprLoc e+exprLoc _ = Nothing++isType :: Expr CoreBndr -> Bool+isType (Type _) = True+isType a = eqType (exprType a) predType++-- | @isGenericVar@ determines whether the @RTyVar@ has no class constraints+isGenericVar :: RTyVar -> SpecType -> Bool+isGenericVar α st = all (\(c, α') -> (α'/=α) || isGenericClass c ) (classConstrs st)+ where+ classConstrs t = [(c, ty_var_value α')+ | (c, ts) <- tyClasses t+ , t' <- ts+ , α' <- freeTyVars t']+ isGenericClass c = className c `elem` [ordClassName, eqClassName] -- , functorClassName, monadClassName]++-- instance MonadFail CG where+-- fail msg = panic Nothing msg++instance MonadFail Data.Functor.Identity.Identity where+ fail msg = panic Nothing msg
+ src/Language/Haskell/Liquid/Constraint/Init.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module defines the representation of Subtyping and WF Constraints,+-- and the code for syntax-directed constraint generation.++module Language.Haskell.Liquid.Constraint.Init (+ initEnv ,+ initCGI,+ ) where++import Prelude hiding (error, undefined)+import Control.Monad.State+import Data.Maybe (isNothing, fromMaybe, catMaybes, mapMaybe)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.List as L+import Data.Bifunctor+import qualified Language.Fixpoint.Types as F++import qualified Language.Haskell.Liquid.UX.CTags as Tg+import Language.Haskell.Liquid.Constraint.Fresh+import Language.Haskell.Liquid.Constraint.Env+import Language.Haskell.Liquid.WiredIn (dictionaryVar)+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)++--------------------------------------------------------------------------------+initEnv :: TargetInfo -> CG CGEnv+--------------------------------------------------------------------------------+initEnv info+ = do let tce = gsTcEmbeds (gsName sp)+ let fVars = giImpVars (giSrc info)+ let dcs = filter isConLikeId (snd <$> gsFreeSyms (gsName sp))+ let dcs' = filter isConLikeId fVars+ defaults <- forM fVars $ \x -> fmap (x,) (trueTy allowTC $ varType x)+ dcsty <- forM dcs (makeDataConTypes allowTC)+ dcsty' <- forM dcs' (makeDataConTypes allowTC)+ (hs,f0) <- refreshHoles allowTC $ grty info -- asserted refinements (for defined vars)+ f0'' <- refreshArgs' =<< grtyTop info -- default TOP reftype (for exported vars without spec)+ let f0' = if notruetypes $ getConfig sp then [] else f0''+ f1 <- refreshArgs' defaults -- default TOP reftype (for all vars)+ f1' <- refreshArgs' $ makeExactDc dcsty -- data constructors+ f2 <- refreshArgs' $ assm info -- assumed refinements (for imported vars)+ f3' <- refreshArgs' =<< recSelectorsTy info -- assumed refinements (for record selectors)+ f3 <- addPolyInfo' <$> refreshArgs' (vals gsAsmSigs (gsSig sp)) -- assumed refinedments (with `assume`)+ 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'+ let f4 = mergeDataConTypes tce (mergeDataConTypes tce f40 (f41 ++ f42)) (filter (isDataConId . fst) f2)+ let tx = mapFst 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 cbs = giCbs . giSrc $ info+ rTrue <- mapM (mapSndM (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)}+ where+ allowTC = typeclass (getConfig info)+ sp = giSpec info+ ialias = mkRTyConIAl (gsIaliases (gsData sp))+ vals f = map (mapSnd val) . f+ is autoinv = mkRTyConInv (gsInvariants (gsData sp) ++ ((Nothing,) <$> autoinv))+ addPolyInfo' = if reflection (getConfig info) then map (mapSnd addPolyInfo) else id++ makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs++addPolyInfo :: SpecType -> SpecType+addPolyInfo t = mkUnivs (go <$> as) ps t'+ where+ (as, ps, t') = bkUniv t+ pos = tyVarsPosition t'+ go (a,r) = if {- ty_var_value a `elem` ppos pos && -} ty_var_value a `notElem` pneg pos+ then (setRtvPol a False,r)+ else (a,r)++makeDataConTypes :: Bool -> Var -> CG (Var, SpecType)+makeDataConTypes allowTC x = (x,) <$> trueTy allowTC (varType x)++makeAutoDecrDataCons :: [(Id, SpecType)] -> S.HashSet TyCon -> [Id] -> ([LocSpecType], [(Id, SpecType)])+makeAutoDecrDataCons dcts specenv dcs+ = (simplify rsorts, tys)+ where+ (rsorts, tys) = unzip $ concatMap go tycons+ tycons = L.nub $ mapMaybe idTyCon dcs++ go tycon+ | S.member tycon specenv = zipWith (makeSizedDataCons dcts) (tyConDataCons tycon) [0..]+ go _+ = []++ simplify invs = dummyLoc . (`strengthen` invariant) . fmap (const mempty) <$> L.nub invs+ invariant = MkUReft (F.Reft (F.vv_, F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty++idTyCon :: Id -> Maybe TyCon+idTyCon = fmap dataConTyCon . idDataConM++lenOf :: F.Symbol -> F.Expr+lenOf x = F.mkEApp lenLocSymbol [F.EVar x]++makeSizedDataCons :: [(Id, SpecType)] -> DataCon -> Integer -> (RSort, (Id, SpecType))+makeSizedDataCons dcts x' n = (toRSort $ ty_res trep, (x, fromRTypeRep trep{ty_res = tres}))+ where+ x = dataConWorkId x'+ st = fromMaybe (impossible Nothing "makeSizedDataCons: this should never happen") $ L.lookup x dcts+ trep = toRTypeRep st+ tres = ty_res trep `strengthen` MkUReft (F.Reft (F.vv_, F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty++ recarguments = filter (\(t,_) -> toRSort t == toRSort tres) (zip (ty_args trep) (ty_binds trep))+ computelen = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf . snd <$> recarguments)++mergeDataConTypes :: F.TCEmb TyCon -> [(Var, SpecType)] -> [(Var, SpecType)] -> [(Var, SpecType)]+mergeDataConTypes tce xts yts = merge (L.sortBy f xts) (L.sortBy f yts)+ where+ f (x,_) (y,_) = compare x y+ merge [] ys = ys+ merge xs [] = xs+ merge (xt@(x, tx):xs) (yt@(y, ty):ys)+ | x == y = (x, mXY x tx y ty) : merge xs ys+ | x < y = xt : merge xs (yt : ys)+ | otherwise = yt : merge (xt : xs) ys+ 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)+++-- | TODO: All this *should* happen inside @Bare@ but appears+-- to happen after certain are signatures are @fresh@-ed,+-- which is why they are here.++-- NV : still some sigs do not get TyConInfo++predsUnify :: TargetSpec -> (Var, RRType RReft) -> (Var, RRType RReft)+predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@+ where+ tce = gsTcEmbeds (gsName sp)+ tyi = gsTyconEnv (gsName sp)+++--------------------------------------------------------------------------------+measEnv :: TargetSpec+ -> [(F.Symbol, SpecType)]+ -> [CoreBind]+ -> [(F.Symbol, F.Sort)]+ -> [(F.Symbol, F.Sort)]+ -> [(F.Symbol, F.Sort)]+ -> [(F.Symbol, SpecType)]+ -> [(F.Symbol, SpecType)]+ -> [F.Symbol]+ -> TargetInfo+ -> CGEnv+--------------------------------------------------------------------------------+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)))+ , denv = dmapty val $ gsDicts (gsSig sp)+ , recs = S.empty+ , invs = mempty+ , rinvs = mempty+ , ial = mkRTyConIAl (gsIaliases (gsData sp))+ , grtys = fromListREnv xts []+ , assms = fromListREnv asms []+ , intys = fromListREnv itys []+ , emb = tce+ , tgEnv = Tg.makeTagEnv cbs+ , tgKey = Nothing+ , trec = Nothing+ , lcb = M.empty+ , forallcb = M.empty+ , holes = fromListHEnv hs+ , lcs = mempty+ , cerr = Nothing+ , cgInfo = info+ , cgVar = Nothing+ }+ where+ tce = gsTcEmbeds (gsName sp)+ filterHO xs = if higherOrderFlag sp then xs else filter (F.isFirstOrder . snd) xs+ lts = lt1s ++ lt2s+ tcb' = []+++assm :: TargetInfo -> [(Var, SpecType)]+assm = assmGrty (giImpVars . giSrc)++grty :: TargetInfo -> [(Var, SpecType)]+grty = assmGrty (giDefVars . giSrc)++assmGrty :: (TargetInfo -> [Var]) -> TargetInfo -> [(Var, SpecType)]+assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]+ where+ xs = S.fromList . f $ info+ sigs = gsTySigs . gsSig . giSpec $ info+++recSelectorsTy :: TargetInfo -> CG [(Var, SpecType)]+recSelectorsTy info = forM topVs $ \v -> (v,) <$> trueTy (typeclass (getConfig info)) (varType v)+ where+ topVs = filter isTop $ giDefVars (giSrc info)+ isTop v = isExportedVar (giSrc info) v && not (v `S.member` sigVs) && isRecordSelector v+ sigVs = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]+ sp = gsSig . giSpec $ info++++grtyTop :: TargetInfo -> CG [(Var, SpecType)]+grtyTop info = forM topVs $ \v -> (v,) <$> trueTy (typeclass (getConfig info)) (varType v)+ where+ topVs = filter isTop $ giDefVars (giSrc info)+ isTop v = isExportedVar (giSrc info) v && not (v `S.member` sigVs) && not (isRecordSelector v)+ sigVs = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]+ sp = gsSig . giSpec $ info+++infoLits :: (TargetSpec -> [(F.Symbol, LocSpecType)]) -> (F.Sort -> Bool) -> TargetInfo -> F.SEnv F.Sort+infoLits litF selF info = F.fromListSEnv $ cbLits ++ measLits+ where+ cbLits = filter (selF . snd) $ coreBindLits tce info+ measLits = filter (selF . snd) $ mkSort <$> litF spc+ spc = giSpec info+ tce = gsTcEmbeds (gsName spc)+ mkSort = mapSnd (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+ }+ where+ tce = gsTcEmbeds nspc+ tspc = gsTerm spc+ spc = giSpec info+ tyi = gsTyconEnv nspc+ nspc = gsName spc+ notFn = isNothing . F.functionSort++coreBindLits :: F.TCEmb TyCon -> TargetInfo -> [(F.Symbol, F.Sort)]+coreBindLits tce info+ = sortNub $ [ (F.symbol x, F.strSort) | (_, Just (F.ESym x)) <- lconsts ] -- strings+ ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ] -- data constructors+ 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+ dconToSort = typeSort tce . expandTypeSynonyms . varType+ dconToSym = F.symbol . idDataCon+ isDCon x = isDataConId x && not (hasBaseTypeVar x)
+ src/Language/Haskell/Liquid/Constraint/Monad.hs view
@@ -0,0 +1,125 @@+-- | This module contains various functions that add/update in the CG monad.++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.Haskell.Liquid.Constraint.Monad where++import qualified Data.HashMap.Strict as M+import qualified Data.Text as T++import Control.Monad+import Control.Monad.State (gets, modify)+import Language.Haskell.Liquid.Types hiding (loc)+import Language.Haskell.Liquid.Constraint.Types+import Language.Haskell.Liquid.Constraint.Env+import Language.Fixpoint.Misc hiding (errorstar)+import Language.Haskell.Liquid.GHC.Misc -- (concatMapM)+import Liquid.GHC.API as Ghc hiding (panic, showPpr)++--------------------------------------------------------------------------------+-- | `addC` adds a subtyping constraint into the global pool.+--------------------------------------------------------------------------------+addC :: SubC -> String -> CG ()+--------------------------------------------------------------------------------+addC c@(SubC γ t1 t2) _msg+ | toType False t1 /= toType False t2+ = panic (Just $ getLocation γ) $ "addC: malformed constraint:\n" ++ _msg ++ showpp t1 ++ "\n <: \n" ++ showpp t2+ | otherwise+ = modify $ \s -> s { hsCs = c : hsCs s }+++addC c _msg+ = modify $ \s -> s { hsCs = c : hsCs s }++--------------------------------------------------------------------------------+-- | addPost: RJ: what DOES this function do?+--------------------------------------------------------------------------------+addPost :: CGEnv -> SpecType -> CG SpecType+--------------------------------------------------------------------------------+addPost cgenv (RRTy e r OInv rt)+ = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) cgenv e+ addC (SubR γ' OInv r) "precondition-oinv" >> return rt++addPost cgenv (RRTy e r OTerm rt)+ = do γ' <- foldM (\γ (x, t) -> γ += ("addPost", x, t)) cgenv e+ addC (SubR γ' OTerm r) "precondition-oterm" >> return rt++addPost cgenv (RRTy cts _ OCons rt)+ = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv xts+ addC (SubC γ' t1 t2) "precondition-ocons"+ addPost cgenv rt+ where+ (xts, t1, t2) = envToSub cts+addPost _ t+ = return t++--------------------------------------------------------------------------------+-- | Add Well formedness Constraint+--------------------------------------------------------------------------------+addW :: WfC -> CG ()+--------------------------------------------------------------------------------+addW !w = modify $ \s -> s { hsWfs = w : hsWfs s }++--------------------------------------------------------------------------------+-- | Add a warning+--------------------------------------------------------------------------------+addWarning :: Error -> CG ()+--------------------------------------------------------------------------------+addWarning w = modify $ \s -> s { logErrors = w : logErrors s }++-- | Add Identifier Annotations, used for annotation binders (i.e. at binder sites)+addIdA :: Var -> Annot SpecType -> CG ()+addIdA !x !t = modify $ \s -> s { annotMap = upd $ annotMap s }+ where+ l = getSrcSpan x+ upd m@(AI _) = if boundRecVar l m then m else addA l (Just x) t m++boundRecVar :: SrcSpan -> AnnInfo (Annot a) -> Bool+boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]+++-- | Used for annotating reads (i.e. at Var x sites)++addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()+addLocA !xo !l !t+ = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }++--------------------------------------------------------------------------------+-- | Update annotations for a location, due to (ghost) predicate applications+--------------------------------------------------------------------------------+updateLocA :: Maybe SrcSpan -> SpecType -> CG ()+--------------------------------------------------------------------------------+updateLocA (Just l) t = addLocA Nothing l (AnnUse t)+updateLocA _ _ = return ()+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+addA :: (Outputable a) => SrcSpan -> Maybe a -> b -> AnnInfo b -> AnnInfo b+--------------------------------------------------------------------------------+addA !l xo@(Just _) !t (AI m)+ | isGoodSrcSpan l+ = AI $ inserts l (T.pack . showPpr <$> xo, t) m+addA !l xo@Nothing !t (AI m)+ | l `M.member` m -- only spans known to be variables+ = AI $ inserts l (T.pack . showPpr <$> xo, t) m+addA _ _ _ !a+ = a+++lookupNewType :: Ghc.TyCon -> CG (Maybe SpecType)+lookupNewType tc+ = gets (M.lookup tc . newTyEnv)+++--------------------------------------------------------------------------------+{-@ envToSub :: {v:[(a, b)] | 2 <= len v} -> ([(a, b)], b, b) @-}+envToSub :: [(a, b)] -> ([(a, b)], b, b)+--------------------------------------------------------------------------------+envToSub = go []+ where+ go _ [] = impossible Nothing "This cannot happen: envToSub on 0 elems"+ go _ [(_,_)] = impossible Nothing "This cannot happen: envToSub on 1 elem"+ go ack [(_,l), (_, r)] = (reverse ack, l, r)+ go ack (x:xs) = go (x:ack) xs
+ src/Language/Haskell/Liquid/Constraint/Qualifier.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.Haskell.Liquid.Constraint.Qualifier+ ( giQuals+ , useSpcQuals+ )+ where++import Prelude hiding (error)+import Data.List (delete, nub)+import Data.Maybe (isJust, catMaybes, fromMaybe, isNothing)+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import Debug.Trace (trace)+import Language.Fixpoint.Types hiding (panic, mkQual)+import qualified Language.Fixpoint.Types.Config as FC+import Language.Fixpoint.SortCheck+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.GHC.Misc (getSourcePos)+import Language.Haskell.Liquid.Misc (condNull)+import Language.Haskell.Liquid.Types.PredType+import Liquid.GHC.API hiding (Expr, mkQual, panic)++import Language.Haskell.Liquid.Types+++--------------------------------------------------------------------------------+giQuals :: TargetInfo -> SEnv Sort -> [Qualifier]+--------------------------------------------------------------------------------+giQuals info lEnv+ = notracepp ("GI-QUALS: " ++ showpp lEnv)+ $ condNull (useSpcQuals info) (gsQualifiers . gsQual . giSpec $ info)+ ++ condNull (useSigQuals info) (sigQualifiers info lEnv)+ ++ condNull (useAlsQuals info) (alsQualifiers info lEnv)++-- --------------------------------------------------------------------------------+-- qualifiers :: GhcInfo -> SEnv Sort -> [Qualifier]+-- --------------------------------------------------------------------------------+-- qualifiers info env = spcQs ++ genQs+ -- where+ -- spcQs = gsQualifiers spc+ -- genQs = specificationQualifiers info env+ -- n = maxParams (getConfig spc)+ -- spc = spec info++maxQualParams :: (HasConfig t) => t -> Int+maxQualParams = maxParams . getConfig++-- | Use explicitly given qualifiers .spec or source (.hs, .lhs) files+useSpcQuals :: (HasConfig t) => t -> Bool+useSpcQuals i = useQuals i && not (useAlsQuals i)++-- | Scrape qualifiers from function signatures (incr :: x:Int -> {v:Int | v > x})+useSigQuals :: (HasConfig t) => t -> Bool+useSigQuals i = useQuals i && not (useAlsQuals i)++-- | Scrape qualifiers from refinement type aliases (type Nat = {v:Int | 0 <= 0})+useAlsQuals :: (HasConfig t) => t -> Bool+useAlsQuals i = useQuals i && i `hasOpt` higherOrderFlag && not (needQuals i)++useQuals :: (HasConfig t) => t -> Bool+useQuals = (FC.All /=) . eliminate . getConfig++needQuals :: (HasConfig t) => t -> Bool+needQuals = (FC.None == ) . eliminate . getConfig++--------------------------------------------------------------------------------+alsQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier]+--------------------------------------------------------------------------------+alsQualifiers info lEnv+ = [ q | a <- gsRTAliases . gsQual . giSpec $ info+ , q <- refTypeQuals lEnv (loc a) tce (rtBody (val a))+ , length (qParams q) <= k + 1+ , validQual lEnv q+ ]+ where+ k = maxQualParams info+ tce = gsTcEmbeds . gsName . giSpec $ info++validQual :: SEnv Sort -> Qualifier -> Bool+validQual lEnv q = isJust $ checkSortExpr (srcSpan q) env (qBody q)+ where+ env = unionSEnv lEnv qEnv+ qEnv = M.fromList (qualBinds q)+++--------------------------------------------------------------------------------+sigQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier]+--------------------------------------------------------------------------------+sigQualifiers info lEnv+ = [ q | (x, t) <- specBinders info+ , x `S.member` qbs+ , q <- refTypeQuals lEnv (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+ 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)+ , gsAsmSigs (gsSig sp)+ , gsRefSigs (gsSig sp)+ , gsCtors (gsData sp)+ , if info `hasOpt` scrapeInternals then gsInSigs (gsSig sp) else []+ ]+ where+ sp = giSpec info++specAxiomVars :: TargetInfo -> [Var]+specAxiomVars = gsReflects . gsRefl . giSpec++-- GRAVEYARD: scraping quals from imports kills the system with too much crap+-- specificationQualifiers info = {- filter okQual -} qs+-- where+-- qs = concatMap refTypeQualifiers ts+-- refTypeQualifiers = refTypeQuals $ tcEmbeds spc+-- ts = val <$> t1s ++ t2s+-- t1s = [t | (x, t) <- tySigs spc, x `S.member` definedVars]+-- t2s = [] -- [t | (_, t) <- ctor spc ]+-- definedVars = S.fromList $ defVars info+-- spc = spec info+--+-- okQual = not . any isPred . map snd . q_params+-- where+-- isPred (FApp tc _) = tc == stringFTycon "Pred"+-- isPred _ = False+++-- TODO: rewrite using foldReft'+--------------------------------------------------------------------------------+refTypeQuals :: SEnv Sort -> SourcePos -> TCEmb TyCon -> SpecType -> [Qualifier]+--------------------------------------------------------------------------------+refTypeQuals lEnv l tce t0 = go emptySEnv t0+ where+ scrape = refTopQuals lEnv 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+ go γ (RAllT _ t _) = go γ t+ go γ (RAllP p t) = go (insertSEnv (pname p) (rTypeSort tce (pvarRType p :: RSort)) γ) t+ go γ t@(RAppTy t1 t2 _) = go γ t1 ++ go γ t2 ++ scrape γ t+ go γ (RFun x _ t t' _) = go γ t ++ goBind x t γ t'+ go γ t@(RApp c ts rs _) = scrape γ t ++ concatMap (go γ') ts ++ goRefs c γ' rs+ where γ' = add (rTypeValueVar t) t γ+ go γ (RAllE x t t') = go γ t ++ goBind x t γ t'+ go γ (REx x t t') = go γ t ++ goBind x t γ t'+ go _ _ = []+ goRefs c g rs = concat $ zipWith (goRef g) rs (rTyConPVs c)+ goRef _ (RProp _ (RHole _)) _ = []+ goRef g (RProp s t) _ = go (insertsSEnv' g s) t+ insertsSEnv' = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ)+++refTopQuals :: (PPrint t, Reftable t, SubsTy RTyVar RSort t, Reftable (RTProp RTyCon RTyVar (UReft t)))+ => SEnv Sort+ -> SourcePos+ -> TCEmb TyCon+ -> RType RTyCon RTyVar r+ -> SEnv Sort+ -> RRType (UReft t)+ -> [Qualifier]+refTopQuals lEnv 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+ ]+ +++ [ mkP s e | let (MkUReft _ (Pr ps)) = fromMaybe (msg rrt) $ stripRTypeBase rrt+ , p <- findPVar (ty_preds $ toRTypeRep t0) <$> ps+ , (s, _, e) <- pargs p+ ]+ where+ mkQ' = mkQual lEnv l t0 γ+ mkP = mkPQual lEnv l tce t0 γ+ msg t = panic Nothing $ "Qualifier.refTopQuals: no typebase" ++ showpp t+ γ' = unionSEnv' γ lEnv++mkPQual :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))+ => SEnv Sort+ -> SourcePos+ -> TCEmb TyCon+ -> t+ -> SEnv Sort+ -> RRType r+ -> Expr+ -> Qualifier+mkPQual lEnv l tce t0 γ t e = mkQual lEnv l t0 γ' v so pa+ where+ v = "vv"+ so = rTypeSort tce t+ γ' = insertSEnv v so γ+ pa = PAtom Eq (EVar v) e++mkQual :: SEnv Sort+ -> SourcePos+ -> t+ -> SEnv Sort+ -> Symbol+ -> Sort+ -> Expr+ -> Qualifier+mkQual lEnv l _ γ v so p = mkQ "Auto" ((v, so) : xts) p l+ where+ xs = delete v $ nub $ syms p+ xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..]++envSort :: SourcePos -> SEnv Sort -> SEnv Sort -> Symbol -> Integer -> Maybe (Symbol, Sort)+envSort l lEnv tEnv x i+ | Just t <- lookupSEnv x tEnv = Just (x, t)+ | Just _ <- lookupSEnv x lEnv = Nothing+ | otherwise = Just (x, ai)+ where+ ai = trace msg $ fObj $ Loc l l $ tempSymbol "LHTV" i+ msg = "Unknown symbol in qualifier: " ++ show x
+ src/Language/Haskell/Liquid/Constraint/Relational.hs view
@@ -0,0 +1,787 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module defines the representation of Subtyping and WF Constraints,+-- and the code for syntax-directed constraint generation.++module Language.Haskell.Liquid.Constraint.Relational (consAssmRel, consRelTop) where++import Control.Monad.State+import Data.Bifunctor ( Bifunctor(bimap) )+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import Data.String ( IsString(..) )+import qualified Language.Fixpoint.Types as F+import qualified Language.Fixpoint.Types.Visitor as F+import Language.Haskell.Liquid.Constraint.Env+import Language.Haskell.Liquid.Constraint.Fresh+import Language.Haskell.Liquid.Constraint.Monad+import Language.Haskell.Liquid.Constraint.Types+import Liquid.GHC.API ( Alt+ , AltCon(..)+ , Bind(..)+ , CoreBind+ , CoreBndr+ , CoreExpr+ , Expr(..)+ , Type(..)+ , TyVar+ , Var(..))+import qualified Liquid.GHC.API as Ghc+import qualified Language.Haskell.Liquid.GHC.Misc as GM+import Language.Haskell.Liquid.GHC.Play (Subable(sub, subTy))+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 System.Console.CmdArgs.Verbosity (whenLoud)+import System.IO.Unsafe (unsafePerformIO)++data RelPred+ = RelPred { fun1 :: Var+ , fun2 :: Var+ , args1 :: [(F.Symbol, [F.Symbol])]+ , args2 :: [(F.Symbol, [F.Symbol])]+ , prop :: RelExpr+ } deriving Show++type PrEnv = [RelPred]++consAssmRel :: Config -> TargetInfo -> (PrEnv, CGEnv) -> (Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr) -> CG (PrEnv, CGEnv)+consAssmRel _ _ (ψ, γ) (x, y, t, s, _, rp) = traceChk "Assm" x y t s p $ do+ traceWhenLoud ("ASSUME " ++ F.showpp (fromRelExpr p', p)) $ subUnarySig γ' x t'+ subUnarySig γ' y s'+ γ'' <- if base t' && base s'+ then γ' `addPred` F.subst+ (F.mkSubst [(resL, F.EVar $ F.symbol x), (resR, F.EVar $ F.symbol y)])+ (fromRelExpr rp)+ else return γ'+ return (RelPred x' y' bs cs rp : ψ, γ'')+ where+ p = fromRelExpr rp+ γ' = γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc t))+ (x', y') = mkRelCopies x y+ t' = val t+ s' = val s+ (vs, ts) = vargs t'+ (us, ss) = vargs s'+ bs = zip vs (fst . vargs <$> ts)+ cs = zip us (fst . vargs <$> ss)+ p' = L.foldl (\q (v, u) -> unapplyRelArgsR v u q) rp (zip vs us)++consRelTop :: Config -> TargetInfo -> CGEnv -> PrEnv -> (Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr) -> CG ()+consRelTop _ ti γ ψ (x, y, t, s, ra, rp) = traceChk "Init" e d t s p $ do+ subUnarySig γ' x t'+ subUnarySig γ' y s'+ consRelCheckBind γ' ψ e d t' s' ra rp+ where+ p = fromRelExpr rp+ γ' = γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc t))+ cbs = giCbs $ giSrc ti+ e = lookupBind x cbs+ d = lookupBind y cbs+ t' = removeAbsRef $ val t+ s' = removeAbsRef $ val s++removeAbsRef :: SpecType -> SpecType+removeAbsRef (RVar v (MkUReft r _))+ = out+ where+ r' = MkUReft r mempty+ out = RVar v r'+removeAbsRef (RFun b i s t (MkUReft r _))+ = out+ where+ r' = MkUReft r mempty+ out = RFun b i (removeAbsRef s) (removeAbsRef t) r'+removeAbsRef (RAllT b t r)+ = RAllT b (removeAbsRef t) r+removeAbsRef (RAllP p t)+ = removeAbsRef (forgetRAllP p t)+removeAbsRef (RApp (RTyCon c _ i) as _ (MkUReft r _))+ = out+ where+ c' = RTyCon c [] i+ as' = map removeAbsRef as+ r' = MkUReft r mempty+ out = RApp c' as' [] r'+removeAbsRef (RAllE b a t)+ = RAllE b (removeAbsRef a) (removeAbsRef t)+removeAbsRef (REx b a t)+ = REx b (removeAbsRef a) (removeAbsRef t)+removeAbsRef (RAppTy s t r)+ = RAppTy (removeAbsRef s) (removeAbsRef t) r+removeAbsRef (RRTy e r o t)+ = RRTy e r o (removeAbsRef t)+removeAbsRef t+ = t++--------------------------------------------------------------+-- Core Checking Rules ---------------------------------------+--------------------------------------------------------------++resL, resR :: F.Symbol+resL = fromString "r1"+resR = fromString "r2"++relSuffixL, relSuffixR :: String+relSuffixL = "l"+relSuffixR = "r"++-- recursion rule+consRelCheckBind :: CGEnv -> PrEnv -> CoreBind -> CoreBind -> SpecType -> SpecType -> RelExpr -> RelExpr -> CG ()+consRelCheckBind γ ψ b1@(NonRec _ e1) b2@(NonRec _ e2) t1 t2 ra rp+ | Nothing <- args e1 e2 t1 t2 p =+ traceChk "Bind NonRec" b1 b2 t1 t2 p $ do+ γ' <- γ `addPred` a+ consRelCheck γ' ψ e1 e2 t1 t2 p+ where+ a = fromRelExpr ra+ p = fromRelExpr rp++consRelCheckBind γ ψ (NonRec x1 e1) b2 t1 t2 a p =+ consRelCheckBind γ ψ (Rec [(x1, e1)]) b2 t1 t2 a p++consRelCheckBind γ ψ b1 (NonRec x2 e2) t1 t2 a p =+ consRelCheckBind γ ψ b1 (Rec [(x2, e2)]) t1 t2 a p++consRelCheckBind γ ψ b1@(Rec [(f1, e1)]) b2@(Rec [(f2, e2)]) t1 t2 ra rp+ | Just (xs1, xs2, vs1, vs2, ts1, ts2, qs) <- args e1 e2 t1 t2 p+ = traceChk "Bind Rec" b1 b2 t1 t2 p $ do+ forM_ (refts t1 ++ refts t2) (\r -> entlFunReft γ r "consRelCheckBind Rec")+ let xs' = zipWith mkRelCopies xs1 xs2+ let (xs1', xs2') = unzip xs'+ let (e1'', e2'') = L.foldl' subRel (e1', e2') (zip xs1 xs2)+ γ' <- γ += ("Bind Rec f1", F.symbol f1', t1) >>= (+= ("Bind Rec f2", F.symbol f2', t2))+ γ'' <- foldM (\γγ (x, t) -> γγ += ("Bind Rec x1", F.symbol x, t)) γ' (zip (xs1' ++ xs2') (ts1 ++ ts2))+ let vs2xs = F.subst $ F.mkSubst $ zip (vs1 ++ vs2) $ map (F.EVar . F.symbol) (xs1' ++ xs2')+ let (ho, fo) = partitionArgs xs1 xs2 ts1 ts2 qs+ γ''' <- γ'' `addPreds` traceWhenLoud ("PRECONDITION " ++ F.showpp (vs2xs (F.PAnd fo)) ++ "\n" +++ "ASSUMPTION " ++ F.showpp (vs2xs a))+ map vs2xs [F.PAnd fo, a]+ let p' = unapp rp (zip vs1 vs2)+ let ψ' = ho ++ ψ+ consRelCheck γ''' ψ' (xbody e1'') (xbody e2'') (vs2xs $ ret t1) (vs2xs $ ret t2) (vs2xs $ concl (fromRelExpr p'))+ where+ a = fromRelExpr ra+ p = fromRelExpr rp+ (f1', f2') = mkRelCopies f1 f2+ (e1', e2') = subRelCopies e1 f1 e2 f2+ unapp :: RelExpr -> [(F.Symbol, F.Symbol)] -> RelExpr+ unapp = L.foldl' (\p' (v1, v2) -> unapplyRelArgsR v1 v2 p')+ subRel (e1'', e2'') (x1, x2) = subRelCopies e1'' x1 e2'' x2++consRelCheckBind _ _ (Rec [(_, e1)]) (Rec [(_, e2)]) t1 t2 _ rp+ = F.panic $ "consRelCheckBind Rec: exprs, types, and pred should have same number of args " +++ show (args e1 e2 t1 t2 p)+ where+ p = fromRelExpr rp++consRelCheckBind _ _ b1@(Rec _) b2@(Rec _) _ _ _ _+ = F.panic $ "consRelCheckBind Rec: multiple binders are not supported " ++ F.showpp (b1, b2)++consRelCheck :: CGEnv -> PrEnv -> CoreExpr -> CoreExpr ->+ SpecType -> SpecType -> F.Expr -> CG ()+consRelCheck γ ψ (Tick tt e) d t s p =+ consRelCheck (γ `setLocation` Sp.Tick tt) ψ e d t s p++consRelCheck γ ψ e (Tick tt d) t s p =+ consRelCheck (γ `setLocation` Sp.Tick tt) ψ e d t s p++consRelCheck γ ψ l1@(Lam α1 e1) e2 rt1@(RAllT s1 t1 r1) t2 p+ | Ghc.isTyVar α1+ = traceChk "Lam Type L" l1 e2 rt1 t2 p $ do+ entlFunReft γ r1 "consRelCheck Lam Type"+ γ' <- γ `extendWithTyVar` α1+ consRelCheck γ' ψ e1 e2 (sb (s1, α1) t1) t2 p+ where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)++consRelCheck γ ψ e1 l2@(Lam α2 e2) t1 rt2@(RAllT s2 t2 r2) p+ | Ghc.isTyVar α2+ = traceChk "Lam Type" e1 l2 t1 rt2 p $ do+ entlFunReft γ r2 "consRelCheck Lam Type"+ γ' <- γ `extendWithTyVar` α2+ consRelCheck γ' ψ e1 e2 t1 (sb (s2, α2) t2) p+ where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)++consRelCheck γ ψ l1@(Lam α1 e1) l2@(Lam α2 e2) rt1@(RAllT s1 t1 r1) rt2@(RAllT s2 t2 r2) p+ | Ghc.isTyVar α1 && Ghc.isTyVar α2+ = traceChk "Lam Type" l1 l2 rt1 rt2 p $ do+ entlFunRefts γ r1 r2 "consRelCheck Lam Type"+ γ' <- γ `extendWithTyVar` α1+ γ'' <- γ' `extendWithTyVar` α2+ consRelCheck γ'' ψ e1 e2 (sb (s1, α1) t1) (sb (s2, α2) t2) p+ where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)++consRelCheck γ ψ l1@(Lam x1 e1) l2@(Lam x2 e2) rt1@(RFun v1 _ s1 t1 r1) rt2@(RFun v2 _ s2 t2 r2) pr@(F.PImp q p)+ = traceChk "Lam Expr" l1 l2 rt1 rt2 pr $ do+ entlFunRefts γ r1 r2 "consRelCheck Lam Expr"+ let (pvar1, pvar2) = (F.symbol evar1, F.symbol evar2)+ let subst = F.subst $ F.mkSubst [(v1, F.EVar pvar1), (v2, F.EVar pvar2)]+ γ' <- γ += ("consRelCheck Lam L", pvar1, subst s1)+ γ'' <- γ' += ("consRelCheck Lam R", pvar2, subst s2)+ let p' = unapplyRelArgs v1 v2 p+ let (ho, fo) = partitionArg x1 x2 s1 s2 q+ γ''' <- γ'' `addPreds` traceWhenLoud ("PRECONDITION " ++ F.showpp (map subst fo)) map subst fo+ consRelCheck γ''' (ho ++ ψ) e1' e2' (subst t1) (subst t2) (subst p')+ where+ (evar1, evar2) = mkRelCopies x1 x2+ (e1', e2') = subRelCopies e1 x1 e2 x2++consRelCheck γ ψ l1@(Let (NonRec x1 d1) e1) l2@(Let (NonRec x2 d2) e2) t1 t2 p+ = traceChk "Let" l1 l2 t1 t2 p $ do+ (s1, s2, _) <- consRelSynth γ ψ d1 d2+ let (evar1, evar2) = mkRelCopies x1 x2+ let (e1', e2') = subRelCopies e1 x1 e2 x2+ γ' <- γ += ("consRelCheck Let L", F.symbol evar1, s1)+ γ'' <- γ' += ("consRelCheck Let R", F.symbol evar2, s2)+ consRelCheck γ'' ψ e1' e2' t1 t2 p+++consRelCheck γ ψ l1@(Let (Rec []) e1) l2@(Let (Rec []) e2) t1 t2 p+ = traceChk "Let Rec Nil" l1 l2 t1 t2 p $ do+ consRelCheck γ ψ e1 e2 t1 t2 p++consRelCheck γ ψ l1@(Let (Rec ((x1, d1):bs1)) e1) l2@(Let (Rec ((x2, d2):bs2)) e2) t1 t2 p+ = traceChk "Let Rec Cons" l1 l2 t1 t2 p $ do+ (s1, s2, _) <- consRelSynth γ ψ d1 d2+ let (evar1, evar2) = mkRelCopies x1 x2+ let (e1', e2') = subRelCopies e1 x1 e2 x2+ γ' <- γ += ("consRelCheck Let L", F.symbol evar1, s1)+ γ'' <- γ' += ("consRelCheck Let R", F.symbol evar2, s2)+ consRelCheck γ'' ψ (Let (Rec bs1) e1') (Let (Rec bs2) e2') t1 t2 p++consRelCheck γ ψ c1@(Case e1 x1 _ alts1) e2 t1 t2 p =+ traceChk "Case Async L" c1 e2 t1 t2 p $ do+ s1 <- consUnarySynth γ e1+ γ' <- γ += ("consRelCheck Case Async L", x1', s1)+ forM_ alts1 $ consRelCheckAltAsyncL γ' ψ t1 t2 p x1' s1 e2+ where+ x1' = F.symbol $ mkCopyWithSuffix relSuffixL x1++consRelCheck γ ψ e1 c2@(Case e2 x2 _ alts2) t1 t2 p =+ traceChk "Case Async R" e1 c2 t1 t2 p $ do+ s2 <- consUnarySynth γ e2+ γ' <- γ += ("consRelCheck Case Async R", x2', s2)+ forM_ alts2 $ consRelCheckAltAsyncR γ' ψ t1 t2 p e1 x2' s2+ where+ x2' = F.symbol $ mkCopyWithSuffix relSuffixR x2++consRelCheck γ ψ e d t1 t2 p =+ traceChk "Synth" e d t1 t2 p $ do+ (s1, s2, qs) <- consRelSynth γ ψ e d+ let psubst = F.substf (matchFunArgs t1 s1) . F.substf (matchFunArgs t2 s2)+ consRelSub γ s1 s2 (F.PAnd qs) (psubst p)+ addC (SubC γ s1 t1) ("consRelCheck (Synth): s1 = " ++ F.showpp s1 ++ " t1 = " ++ F.showpp t1)+ addC (SubC γ s2 t2) ("consRelCheck (Synth): s2 = " ++ F.showpp s2 ++ " t2 = " ++ F.showpp t2)++consExtAltEnv :: CGEnv -> F.Symbol -> SpecType -> AltCon -> [Var] -> CoreExpr -> String -> CG (CGEnv, CoreExpr)+consExtAltEnv γ x s c bs e suf = do+ ct <- ctorTy γ c s+ unapply γ x s bs (removeAbsRef ct) e suf++consRelCheckAltAsyncL :: CGEnv -> PrEnv -> SpecType -> SpecType -> F.Expr ->+ F.Symbol -> SpecType -> CoreExpr -> Alt CoreBndr -> CG ()+consRelCheckAltAsyncL γ ψ t1 t2 p x1 s1 e2 (Ghc.Alt c bs1 e1) = do+ (γ', e1') <- consExtAltEnv γ x1 s1 c bs1 e1 relSuffixL+ consRelCheck γ' ψ e1' e2 t1 t2 p++consRelCheckAltAsyncR :: CGEnv -> PrEnv -> SpecType -> SpecType -> F.Expr ->+ CoreExpr -> F.Symbol -> SpecType -> Alt CoreBndr -> CG ()+consRelCheckAltAsyncR γ ψ t1 t2 p e1 x2 s2 (Ghc.Alt c bs2 e2) = do+ (γ', e2') <- consExtAltEnv γ x2 s2 c bs2 e2 relSuffixR+ consRelCheck γ' ψ e1 e2' t1 t2 p++ctorTy :: CGEnv -> AltCon -> SpecType -> CG SpecType+ctorTy γ (DataAlt c) (RApp _ ts _ _)+ | Just ct <- mbct = refreshTy $ ct `instantiateTys` ts+ | Nothing <- mbct = F.panic $ "ctorTy: data constructor out of scope" ++ F.showpp c+ where mbct = γ ?= F.symbol (Ghc.dataConWorkId c)+ctorTy _ (DataAlt _) t =+ F.panic $ "ctorTy: type " ++ F.showpp t ++ " doesn't have top-level data constructor"+ctorTy _ (LitAlt c) _ = return $ uTop <$> literalFRefType c+ctorTy _ DEFAULT t = return t++unapply :: CGEnv -> F.Symbol -> SpecType -> [Var] -> SpecType -> CoreExpr -> String -> CG (CGEnv, CoreExpr)+unapply γ y yt (z : zs) (RFun x _ s t _) e suffix = do+ γ' <- γ += ("unapply arg", evar, s)+ unapply γ' y yt zs (t `F.subst1` (x, F.EVar evar)) e' suffix+ where+ z' = mkCopyWithSuffix suffix z+ evar = F.symbol z'+ 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+ γ' <- γ += ("unapply res", y, yt')+ return $ traceWhenLoud ("SCRUTINEE " ++ F.showpp (y, yt')) (γ', e)++instantiateTys :: SpecType -> [SpecType] -> SpecType+instantiateTys = L.foldl' go+ where+ go (RAllT α tbody _) t = subsTyVarMeet' (ty_var_value α, t) tbody+ go tbody t =+ F.panic $ "instantiateTys: non-polymorphic type " ++ F.showpp tbody ++ " to instantiate with " ++ F.showpp t++--------------------------------------------------------------+-- Core Synthesis Rules --------------------------------------+--------------------------------------------------------------++consRelSynth :: CGEnv -> PrEnv -> CoreExpr -> CoreExpr -> CG (SpecType, SpecType, [F.Expr])+consRelSynth γ ψ (Tick tt e) d =+ consRelSynth (γ `setLocation` Sp.Tick tt) ψ e d++consRelSynth γ ψ e (Tick tt d) =+ consRelSynth (γ `setLocation` Sp.Tick tt) ψ e d++consRelSynth γ ψ a1@(App e1 d1) e2 | Type t1 <- GM.unTickExpr d1 =+ traceSyn "App Ty L" a1 e2 $ do+ (ft1', t2, ps) <- consRelSynth γ ψ e1 e2+ let (α1, ft1, _) = unRAllT ft1' "consRelSynth App Ty L"+ t1' <- trueTy (typeclass (getConfig γ)) t1+ return (subsTyVarMeet' (ty_var_value α1, t1') ft1, t2, ps)++consRelSynth γ ψ e1 a2@(App e2 d2) | Type t2 <- GM.unTickExpr d2 =+ traceSyn "App Ty R" e1 a2 $ do+ (t1, ft2', ps) <- consRelSynth γ ψ e1 e2+ let (α2, ft2, _) = unRAllT ft2' "consRelSynth App Ty R"+ t2' <- trueTy (typeclass (getConfig γ)) t2+ return (t1, subsTyVarMeet' (ty_var_value α2, t2') ft2, ps)++consRelSynth γ ψ a1@(App e1 d1) a2@(App e2 d2) = traceSyn "App Exp Exp" a1 a2 $ do+ (ft1, ft2, fps) <- consRelSynth γ ψ e1 e2+ (t1, t2, ps) <- consRelSynthApp γ ψ ft1 ft2 fps d1 d2+ return (t1, t2, ps)++consRelSynth γ ψ e d = traceSyn "Unary" e d $ do+ t <- consUnarySynth γ e >>= refreshTy+ s <- consUnarySynth γ d >>= refreshTy+ let ps = lookupRelSig ψ e d t s+ return (t, s, traceWhenLoud ("consRelSynth Unary synthed preds:" ++ F.showpp ps) ps)++lookupRelSig :: PrEnv -> CoreExpr -> CoreExpr -> SpecType -> SpecType -> [F.Expr]+lookupRelSig ψ (Var x1) (Var x2) t1 t2 = concatMap match ψ+ where+ match :: RelPred -> [F.Expr]+ match (RelPred f1 f2 bs1 bs2 p) | f1 == x1, f2 == x2 =+ let (vs1, ts1') = vargs t1+ (vs2, ts2') = vargs t2+ vs1' = concatMap (fst . vargs) ts1'+ vs2' = concatMap (fst . vargs) ts2'+ bs1' = concatMap snd bs1+ bs2' = concatMap snd bs2+ bs2vs = F.mkSubst $ zip (map fst bs1 ++ map fst bs2 ++ bs1' ++ bs2') $ map F.EVar (vs1 ++ vs2 ++ vs1' ++ vs2')+ in [F.subst bs2vs (fromRelExpr p)]+ match _ = []+lookupRelSig _ _ _ _ _ = []++consRelSynthApp :: CGEnv -> PrEnv -> SpecType -> SpecType ->+ [F.Expr] -> CoreExpr -> CoreExpr -> CG (SpecType, SpecType, [F.Expr])+consRelSynthApp γ ψ ft1 ft2 ps e1 (Tick _ e2) =+ consRelSynthApp γ ψ ft1 ft2 ps e1 e2+consRelSynthApp γ ψ ft1 ft2 ps (Tick t1 e1) e2 =+ consRelSynthApp (γ `setLocation` Sp.Tick t1) ψ ft1 ft2 ps e1 e2++consRelSynthApp γ ψ ft1@(RFun v1 _ s1 t1 r1) ft2@(RFun v2 _ s2 t2 r2) ps@[F.PImp q p] d1@(Var x1) d2@(Var x2)+ = traceSynApp ft1 ft2 ps d1 d2 $ do+ entlFunRefts γ r1 r2 "consRelSynthApp HO"+ let qsubst = F.subst $ F.mkSubst [(v1, F.EVar resL), (v2, F.EVar resR)]+ consRelCheck γ ψ d1 d2 s1 s2 (qsubst q)+ let subst = F.subst $ F.mkSubst [(v1, F.EVar $ F.symbol x1), (v2, F.EVar $ F.symbol x2)]+ return (subst t1, subst t2, [(subst . unapplyRelArgs v1 v2) p])+consRelSynthApp γ ψ ft1@(RFun v1 _ s1 t1 r1) ft2@(RFun v2 _ s2 t2 r2) ps@[] d1@(Var x1) d2@(Var x2)+ = traceSynApp ft1 ft2 ps d1 d2 $ do+ entlFunRefts γ r1 r2 "consRelSynthApp FO"+ consUnaryCheck γ d1 s1+ consUnaryCheck γ d2 s2+ (_, _, qs) <- consRelSynth γ ψ d1 d2+ let subst =+ F.subst $ F.mkSubst+ [(v1, F.EVar $ F.symbol x1), (v2, F.EVar $ F.symbol x2)]+ return (subst t1, subst t2, map subst qs)+consRelSynthApp _ _ RFun{} RFun{} ps d1@(Var _) d2@(Var _)+ = F.panic $ "consRelSynthApp: multiple rel sigs not supported " ++ F.showpp (ps, d1, d2)+consRelSynthApp _ _ RFun{} RFun{} _ d1 d2 =+ F.panic $ "consRelSynthApp: expected application to variables, got" ++ F.showpp (d1, d2)+consRelSynthApp _ _ t1 t2 p d1 d2 =+ F.panic $ "consRelSynthApp: malformed function types or predicate for arguments " ++ F.showpp (t1, t2, p, d1, d2)++--------------------------------------------------------------+-- Unary Rules -----------------------------------------------+--------------------------------------------------------------++symbolType :: CGEnv -> Var -> String -> SpecType+symbolType γ x msg+ | Just t <- γ ?= F.symbol x = t+ | otherwise = F.panic $ msg ++ " " ++ F.showpp x ++ " not in scope " ++ F.showpp γ++consUnarySynth :: CGEnv -> CoreExpr -> CG SpecType+consUnarySynth γ (Tick t e) = consUnarySynth (γ `setLocation` Sp.Tick t) e+consUnarySynth γ (Var x) = return $ traceWhenLoud ("SELFIFICATION " ++ F.showpp (x, removeAbsRef $ selfify t x)) removeAbsRef $ selfify t x+ where t = symbolType γ x "consUnarySynth (Var)"+consUnarySynth _ e@(Lit c) =+ traceUSyn "Lit" e $ do+ return $ removeAbsRef $ uRType $ literalFRefType c+consUnarySynth γ e@(Let _ _) =+ traceUSyn "Let" e $ do+ t <- freshTyType (typeclass (getConfig γ)) LetE e $ Ghc.exprType e+ addW $ WfC γ t+ consUnaryCheck γ e t+ return $ removeAbsRef t+consUnarySynth γ e'@(App e d) =+ traceUSyn "App" e' $ do+ et <- consUnarySynth γ e+ consUnarySynthApp γ et d+consUnarySynth γ e'@(Lam α e) | Ghc.isTyVar α =+ traceUSyn "LamTyp" e' $ do+ γ' <- γ `extendWithTyVar` α+ t' <- consUnarySynth γ' e+ return $ removeAbsRef $ RAllT (makeRTVar $ rTyVar α) t' mempty+consUnarySynth γ e@(Lam x d) =+ traceUSyn "Lam" e $ do+ let Ghc.FunTy { ft_arg = s' } = checkFun e $ Ghc.exprType e+ s <- freshTyType (typeclass (getConfig γ)) LamE (Var x) s'+ γ' <- γ += ("consUnarySynth (Lam)", F.symbol x, s)+ t <- consUnarySynth γ' d+ addW $ WfC γ s+ return $ removeAbsRef $ RFun (F.symbol x) (mkRFInfo $ getConfig γ) s t mempty+consUnarySynth γ e@(Case _ _ _ alts) =+ traceUSyn "Case" e $ do+ t <- freshTyType (typeclass (getConfig γ)) (caseKVKind alts) e $ Ghc.exprType e+ addW $ WfC γ t+ return $ removeAbsRef t+consUnarySynth _ e@(Cast _ _) = F.panic $ "consUnarySynth is undefined for Cast " ++ F.showpp e+consUnarySynth _ e@(Type _) = F.panic $ "consUnarySynth is undefined for Type " ++ F.showpp e+consUnarySynth _ e@(Coercion _) = F.panic $ "consUnarySynth is undefined for Coercion " ++ F.showpp e++caseKVKind :: [Alt Var] -> KVKind+caseKVKind [Ghc.Alt (DataAlt _) _ (Var _)] = ProjectE+caseKVKind cs = CaseE (length cs)++checkFun :: CoreExpr -> Type -> Type+checkFun _ t@Ghc.FunTy{} = t+checkFun e t = F.panic $ "FunTy was expected but got " ++ F.showpp t ++ "\t for expression" ++ F.showpp e++base :: SpecType -> Bool+base RApp{} = True+base RVar{} = True+base _ = False++selfifyExpr :: SpecType -> F.Expr -> Maybe SpecType+selfifyExpr (RFun v i s t r) f = (\t' -> RFun v i s t' r) <$> selfifyExpr t (F.EApp f (F.EVar v))+selfifyExpr t e | base t = Just $ t `strengthen` eq e+ where eq = uTop . F.exprReft+selfifyExpr _ _ = Nothing++selfify :: F.Symbolic a => SpecType -> a -> SpecType+selfify t x | base t = t `strengthen` eq x+ where eq = uTop . F.symbolReft . F.symbol+selfify t e | Just t' <- selfifyExpr t (F.EVar $ F.symbol e) = t'+selfify t _ = t++consUnarySynthApp :: CGEnv -> SpecType -> CoreExpr -> CG SpecType+consUnarySynthApp γ t (Tick y e) = do+ consUnarySynthApp (γ `setLocation` Sp.Tick y) t e+consUnarySynthApp γ (RFun x _ s t _) d@(Var y) = do+ consUnaryCheck γ d s+ return $ t `F.subst1` (x, F.EVar $ F.symbol y)+consUnarySynthApp γ (RAllT α t _) (Type s) = do+ s' <- trueTy (typeclass (getConfig γ)) s+ return $ subsTyVarMeet' (ty_var_value α, s') t+consUnarySynthApp _ RFun{} d =+ F.panic $ "consUnarySynthApp expected Var as a funciton arg, got " ++ F.showpp d+consUnarySynthApp γ t@(RAllP{}) e+ = consUnarySynthApp γ (removeAbsRef t) e++consUnarySynthApp _ ft d =+ F.panic $ "consUnarySynthApp malformed function type " ++ F.showpp ft +++ " for argument " ++ F.showpp d++consUnaryCheck :: CGEnv -> CoreExpr -> SpecType -> CG ()+consUnaryCheck γ (Let (NonRec x d) e) t = do+ s <- consUnarySynth γ d+ γ' <- γ += ("consUnaryCheck Let", F.symbol x, s)+ consUnaryCheck γ' e t+consUnaryCheck γ e t = do+ s <- consUnarySynth γ e+ addC (SubC γ s t) ("consUnaryCheck (Synth): s = " ++ F.showpp s ++ " t = " ++ F.showpp t)++--------------------------------------------------------------+-- Rel. Predicate Subtyping ---------------------------------+--------------------------------------------------------------++consRelSub :: CGEnv -> SpecType -> SpecType -> F.Expr -> F.Expr -> CG ()+consRelSub γ f1@(RFun g1 _ s1@RFun{} t1 _) f2@(RFun g2 _ s2@RFun{} t2 _)+ pr1@(F.PImp qr1@F.PImp{} p1) pr2@(F.PImp qr2@F.PImp{} p2)+ = traceSub "hof" f1 f2 pr1 pr2 $ do+ 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+ 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)+ = traceSub "hof" f1 f2 pr1 pr2 $ do+ 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+ consRelSub γ'' t1 t2 (psubst p1) (psubst p2)+consRelSub γ f1@(RFun x1 _ s1 e1 _) f2 p1 p2 =+ traceSub "fun" f1 f2 p1 p2 $ do+ γ' <- γ += ("consRelSub RFun L", F.symbol x1, s1)+ let psubst = unapplyArg resL x1+ consRelSub γ' e1 f2 (psubst p1) (psubst p2)+consRelSub γ f1 f2@(RFun x2 _ s2 e2 _) p1 p2 =+ traceSub "fun" f1 f2 p1 p2 $ do+ γ' <- γ += ("consRelSub RFun R", F.symbol x2, s2)+ let psubst = unapplyArg resR x2+ consRelSub γ' f1 e2 (psubst p1) (psubst p2)+consRelSub γ t1 t2 p1 p2 | isBase t1 && isBase t2 =+ traceSub "base" t1 t2 p1 p2 $ do+ rl <- fresh+ rr <- fresh+ γ' <- γ += ("consRelSub Base L", rl, t1)+ γ'' <- γ' += ("consRelSub Base R", rr, t2)+ let cstr = F.subst (F.mkSubst [(resL, F.EVar rl), (resR, F.EVar rr)]) $ F.PImp p1 p2+ entl γ'' (traceWhenLoud ("consRelSub Base cstr " ++ F.showpp cstr) cstr) "consRelSub Base"+consRelSub _ t1@(RHole _) t2@(RHole _) _ _ = F.panic $ "consRelSub is undefined for RHole " ++ show (t1, t2)+consRelSub _ t1@(RExprArg _) t2@(RExprArg _) _ _ = F.panic $ "consRelSub is undefined for RExprArg " ++ show (t1, t2)+consRelSub _ t1@REx {} t2@REx {} _ _ = F.panic $ "consRelSub is undefined for REx " ++ show (t1, t2)+consRelSub _ t1@RAllE {} t2@RAllE {} _ _ = F.panic $ "consRelSub is undefined for RAllE " ++ show (t1, t2)+consRelSub _ t1@RRTy {} t2@RRTy {} _ _ = F.panic $ "consRelSub is undefined for RRTy " ++ show (t1, t2)+consRelSub _ t1@RAllP {} t2@RAllP {} _ _ = F.panic $ "consRelSub is undefined for RAllP " ++ show (t1, t2)+consRelSub _ t1@RAllT {} t2@RAllT {} _ _ = F.panic $ "consRelSub is undefined for RAllT " ++ show (t1, t2)+consRelSub _ t1 t2 _ _ = F.panic $ "consRelSub is undefined for different types " ++ show (t1, t2)++--------------------------------------------------------------+-- Helper Definitions ----------------------------------------+--------------------------------------------------------------++isFuncPred :: F.Expr -> Bool+isFuncPred (F.PImp _ _) = True+isFuncPred _ = False++partitionArg :: Var -> Var -> SpecType -> SpecType -> F.Expr -> (PrEnv, [F.Expr])+partitionArg x1 x2 s1 s2 q = partitionArgs [x1] [x2] [s1] [s2] [q]++partitionArgs :: [Var] -> [Var] -> [SpecType] -> [SpecType] -> [F.Expr] -> (PrEnv, [F.Expr])+partitionArgs xs1 xs2 ts1 ts2 qs = (map toRel ho, map toUnary fo)+ where+ (ho, fo) = L.partition (isFuncPred . toUnary) (zip5 xs1 xs2 ts1 ts2 qs)+ toRel (f1, f2, t1, t2, q) =+ let (vs1, ts1') = vargs t1+ in let (vs2, ts2') = vargs t2+ in let bs1 = zip vs1 (fst . vargs <$> ts1')+ in let bs2 = zip vs2 (fst . vargs <$> ts2')+ in let rp = RelPred f1 f2 bs1 bs2 $ ERBasic q+ in traceWhenLoud ("partitionArgs toRel: " ++ F.showpp (f1, f2, bs1, bs2, q)) rp+ toUnary (_, _, _, _, q) = q++unRAllT :: SpecType -> String -> (RTVU RTyCon RTyVar, SpecType, RReft)+unRAllT (RAllT α2 ft2 r2) _ = (α2, ft2, r2)+unRAllT t msg = F.panic $ msg ++ ": expected RAllT, got: " ++ F.showpp t++forgetRAllP :: PVU RTyCon RTyVar -> SpecType -> SpecType+forgetRAllP _ t = t++args :: CoreExpr -> CoreExpr -> SpecType -> SpecType -> F.Expr ->+ Maybe ([Var], [Var], [F.Symbol], [F.Symbol], [SpecType], [SpecType], [F.Expr])+args e1 e2 t1 t2 ps+ | xs1 <- xargs e1, xs2 <- xargs e2,+ (vs1, ts1) <- vargs t1, (vs2, ts2) <- vargs t2,+ qs <- prems ps,+ all (length qs ==) [length xs1, length xs2, length vs1, length vs2, length ts1, length ts2]+ = Just (xs1, xs2, vs1, vs2, ts1, ts2, qs)+args e1 e2 t1 t2 ps = traceWhenLoud ("args guard" ++ F.showpp (xargs e1, xargs e2, vargs t1, vargs t2, prems ps)) Nothing++xargs :: CoreExpr -> [Var]+xargs (Tick _ e) = xargs e+xargs (Lam x e) | Ghc.isTyVar x = xargs e+xargs (Lam x e) = x : xargs e+xargs _ = []++xbody :: CoreExpr -> CoreExpr+xbody (Tick _ e) = xbody e+xbody (Lam _ e) = xbody e+xbody e = e++refts :: SpecType -> [RReft]+refts (RAllT _ t r ) = r : refts t+refts (RFun _ _ _ t r) = r : refts t+refts _ = []++vargs :: SpecType -> ([F.Symbol], [SpecType])+vargs (RAllT _ t _ ) = vargs t+vargs (RFun v _ s t _) = bimap (v :) (s :) $ vargs t+vargs _ = ([], [])++ret :: SpecType -> SpecType+ret (RAllT _ t _ ) = ret t+ret (RFun _ _ _ t _) = ret t+ret t = t++prems :: F.Expr -> [F.Expr]+prems (F.PImp q p) = q : prems p+prems _ = []++concl :: F.Expr -> F.Expr+concl (F.PImp _ p) = concl p+concl p = p++extendWithTyVar :: CGEnv -> TyVar -> CG CGEnv+extendWithTyVar γ a+ | isValKind (Ghc.tyVarKind a)+ = γ += ("extendWithTyVar", F.symbol a, kindToRType $ Ghc.tyVarKind a)+ | otherwise+ = return γ++matchFunArgs :: SpecType -> SpecType -> F.Symbol -> F.Expr+matchFunArgs (RAllT _ t1 _) t2 x = matchFunArgs t1 t2 x+matchFunArgs t1 (RAllT _ t2 _) x = matchFunArgs t1 t2 x+matchFunArgs (RFun x1 _ _ t1 _) (RFun x2 _ _ t2 _) x =+ if x == x1 then F.EVar x2 else matchFunArgs t1 t2 x+matchFunArgs t1 t2 x | isBase t1 && isBase t2 = F.EVar x+matchFunArgs t1 t2 _ = F.panic $ "matchFunArgs undefined for " ++ F.showpp (t1, t2)++entl :: CGEnv -> F.Expr -> String -> CG ()+entl γ p = addC (SubR γ OCons $ uReft (F.vv_, F.PIff (F.EVar F.vv_) p))++entlFunReft :: CGEnv -> RReft -> String -> CG ()+entlFunReft γ r msg = do+ entl γ (F.reftPred $ ur_reft r) $ "entlFunRefts " ++ msg++entlFunRefts :: CGEnv -> RReft -> RReft -> String -> CG ()+entlFunRefts γ r1 r2 msg = do+ entlFunReft γ r1 $ msg ++ " L"+ entlFunReft γ r2 $ msg ++ " R"++subRelCopies :: CoreExpr -> Var -> CoreExpr -> Var -> (CoreExpr, CoreExpr)+subRelCopies e1 x1 e2 x2 = (subVarAndTy x1 evar1 e1, subVarAndTy x2 evar2 e2)+ where (evar1, evar2) = mkRelCopies x1 x2++subVarAndTy :: Var -> Var -> CoreExpr -> CoreExpr+subVarAndTy x v = subTy (M.singleton x $ TyVarTy v) . sub (M.singleton x $ Var v)++mkRelCopies :: Var -> Var -> (Var, Var)+mkRelCopies x1 x2 = (mkCopyWithSuffix relSuffixL x1, mkCopyWithSuffix relSuffixR x2)++mkCopyWithName :: String -> Var -> Var+mkCopyWithName s v =+ Ghc.setVarName v $ Ghc.mkSystemName (Ghc.getUnique v) (Ghc.mkVarOcc s)++mkCopyWithSuffix :: String -> Var -> Var+mkCopyWithSuffix s v = mkCopyWithName (Ghc.getOccString v ++ s) v++lookupBind :: Var -> [CoreBind] -> CoreBind+lookupBind x bs = case lookup x (concatMap binds bs) of+ Nothing -> F.panic $ "Not found definition for " ++ show x+ Just e -> e+ where+ binds b@(NonRec x' _) = [ (x', b) ]+ binds (Rec bs' ) = [ (x', Rec [(x',e)]) | (x',e) <- bs' ]++subUnarySig :: CGEnv -> Var -> SpecType -> CG ()+subUnarySig γ x tRel =+ forM_ mkargs $ \(rt, ut) -> addC (SubC γ ut rt) $ "subUnarySig tUn = " ++ F.showpp ut ++ " tRel = " ++ F.showpp rt+ where+ mkargs = zip (snd $ vargs tRel) (snd $ vargs tUn)+ tUn = symbolType γ x $ "subUnarySig " ++ F.showpp x++addPred :: CGEnv -> F.Expr -> CG CGEnv+addPred γ p = extendWithExprs γ [p]++addPreds :: CGEnv -> [F.Expr] -> CG CGEnv+addPreds = extendWithExprs++extendWithExprs :: CGEnv -> [F.Expr] -> CG CGEnv+extendWithExprs γ ps = do+ dummy <- fresh+ let reft = uReft (F.vv_, F.PAnd ps)+ γ += ("extend with predicate env", dummy, RVar (symbolRTyVar F.dummySymbol) reft)++unapplyArg :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr+unapplyArg f y e = F.mapExpr sb e+ where+ sb :: F.Expr -> F.Expr+ sb (F.EApp (F.EVar r) (F.EVar x))+ | r == f && x == y = F.EVar r+ sb e' = e'++unapplyRelArgs :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr+unapplyRelArgs x1 x2 = unapplyArg resL x1 . unapplyArg resR x2++unapplyRelArgsR :: F.Symbol -> F.Symbol -> RelExpr -> RelExpr+unapplyRelArgsR x1 x2 (ERBasic e) = ERBasic (unapplyRelArgs x1 x2 e)+unapplyRelArgsR x1 x2 (ERChecked e re) = ERChecked (unapplyRelArgs x1 x2 e) (unapplyRelArgsR x1 x2 re)+unapplyRelArgsR x1 x2 (ERUnChecked e re) = ERUnChecked (unapplyRelArgs x1 x2 e) (unapplyRelArgsR x1 x2 re)++--------------------------------------------------------------+-- RelExpr & F.Expr ------------------------------------------+--------------------------------------------------------------++fromRelExpr :: RelExpr -> F.Expr+fromRelExpr (ERBasic e) = e+fromRelExpr (ERChecked a b) = F.PImp a (fromRelExpr b)+fromRelExpr (ERUnChecked a b) = F.PImp a (fromRelExpr b)++--------------------------------------------------------------+-- Debug -----------------------------------------------------+--------------------------------------------------------------+++traceSub :: (PPrint t, PPrint s, PPrint p, PPrint q) => String -> t -> s -> p -> q -> a -> a+traceSub msg t s p q = traceWhenLoud (msg ++ " RelSub\n"+ ++ "t: " ++ F.showpp t ++ "\n\n"+ ++ "s: " ++ F.showpp s ++ "\n\n"+ ++ "p: " ++ F.showpp p ++ "\n\n"+ ++ "q: " ++ F.showpp q)+++traceChk+ :: (PPrint e, PPrint d, PPrint t, PPrint s, PPrint p)+ => String -> e -> d -> t -> s -> p -> a -> a+traceChk expr = trace (expr ++ " To CHECK")++traceSyn+ :: (PPrint e, PPrint d, PPrint a, PPrint b, PPrint c)+ => String -> e -> d -> CG (a, b, c) -> CG (a, b, c)+traceSyn expr e d cg+ = do+ (a, b, c) <- cg+ trace (expr ++ " To SYNTH") e d a b c cg++traceSynApp+ :: (PPrint e, PPrint d, PPrint a, PPrint b, PPrint c)+ => e -> d -> a -> b -> c -> t -> t+traceSynApp = trace "SYNTH APP TO "++traceUSyn+ :: (PPrint e, PPrint a)+ => String -> e -> CG a -> CG a+traceUSyn expr e cg = do+ t <- cg+ trace (expr ++ " To SYNTH UNARY") e dummy t dummy dummy cg+ where dummy = F.PTrue++trace+ :: (PPrint e, PPrint d, PPrint t, PPrint s, PPrint p)+ => String -> e -> d -> t -> s -> p -> a -> a+trace msg e d t s p = traceWhenLoud (msg ++ "\n"+ ++ "e: " ++ F.showpp e ++ "\n\n"+ ++ "d: " ++ F.showpp d ++ "\n\n"+ ++ "t: " ++ F.showpp t ++ "\n\n"+ ++ "s: " ++ F.showpp s ++ "\n\n"+ ++ "p: " ++ F.showpp p)++traceWhenLoud :: String -> a -> a+traceWhenLoud s a = unsafePerformIO $ whenLoud (putStrLn s) >> return a
+ src/Language/Haskell/Liquid/Constraint/Split.hs view
@@ -0,0 +1,451 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++--------------------------------------------------------------------------------+-- | Constraint Splitting ------------------------------------------------------+--------------------------------------------------------------------------------++module Language.Haskell.Liquid.Constraint.Split (++ -- * Split Subtyping Constraints+ splitC++ -- * Split Well-formedness Constraints+ , splitW++ -- * ???+ , envToSub++ -- * Panic+ , panicUnbound+ ) where++import Prelude hiding (error)++++import Text.PrettyPrint.HughesPJ hiding (first, parens)++import Data.Maybe (fromMaybe)+import Control.Monad+import Control.Monad.State (gets)+import qualified Control.Exception as Ex++import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Misc hiding (errorstar)+import Language.Fixpoint.SortCheck (pruneUnsortedReft)++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.Constraint.Types+import Language.Haskell.Liquid.Constraint.Env+import Language.Haskell.Liquid.Constraint.Constraint+import Language.Haskell.Liquid.Constraint.Monad (envToSub)++--------------------------------------------------------------------------------+splitW :: WfC -> CG [FixWfC]+--------------------------------------------------------------------------------+splitW (WfC γ t@(RFun x _ t1 t2 _))+ = do ws' <- splitW (WfC γ t1)+ γ' <- γ += ("splitW", x, t1)+ ws <- bsplitW γ t+ ws'' <- splitW (WfC γ' t2)+ return $ ws ++ ws' ++ ws''++splitW (WfC γ t@(RAppTy t1 t2 _))+ = do ws <- bsplitW γ t+ ws' <- splitW (WfC γ t1)+ ws'' <- splitW (WfC γ t2)+ return $ ws ++ ws' ++ ws''++splitW (WfC γ t'@(RAllT a t _))+ = do γ' <- updateEnv γ a+ ws <- bsplitW γ t'+ ws' <- splitW (WfC γ' t)+ return $ ws ++ ws'++splitW (WfC γ (RAllP _ r))+ = splitW (WfC γ r)++splitW (WfC γ t@(RVar _ _))+ = bsplitW γ t++splitW (WfC γ t@(RApp _ ts rs _))+ = do ws <- bsplitW γ t+ γ' <- if bscope (getConfig γ) then γ `extendEnvWithVV` t else return γ+ ws' <- concat <$> mapM (splitW . WfC γ') ts+ ws'' <- concat <$> mapM (rsplitW γ) rs+ return $ ws ++ ws' ++ ws''++splitW (WfC γ (RAllE x tx t))+ = do ws <- splitW (WfC γ tx)+ γ' <- γ += ("splitW1", x, tx)+ ws' <- splitW (WfC γ' t)+ return $ ws ++ ws'++splitW (WfC γ (REx x tx t))+ = do ws <- splitW (WfC γ tx)+ γ' <- γ += ("splitW2", x, tx)+ ws' <- splitW (WfC γ' t)+ return $ ws ++ ws'++splitW (WfC γ (RRTy _ _ _ t))+ = splitW (WfC γ t)++splitW (WfC _ t)+ = panic Nothing $ "splitW cannot handle: " ++ showpp t++rsplitW :: CGEnv+ -> Ref RSort SpecType+ -> CG [FixWfC]+rsplitW _ (RProp _ (RHole _)) =+ panic Nothing "Constrains: rsplitW for RProp _ (RHole _)"++rsplitW γ (RProp ss t0) = do+ γ' <- foldM (+=) γ [("rsplitW", x, ofRSort s) | (x, s) <- ss]+ splitW $ WfC γ' t0+++bsplitW :: CGEnv -> SpecType -> CG [FixWfC]+bsplitW γ t =+ do temp <- getTemplates+ isHO <- gets allowHO+ return $ bsplitW' γ t temp isHO++bsplitW' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+ => CGEnv -> RRType r -> F.Templates -> Bool -> [F.WfC Cinfo]+bsplitW' γ t temp isHO+ | isHO || F.isNonTrivial r'+ = F.wfC (feBinds $ fenv γ) r' ci+ | otherwise+ = []+ where+ r' = rTypeSortedReft' γ temp t+ ci = Ci (getLocation γ) Nothing (cgVar γ)++splitfWithVariance :: Applicative f+ => (t -> t -> f [a]) -> t -> t -> Variance -> f [a]+splitfWithVariance f t1 t2 Invariant = (++) <$> f t1 t2 <*> f t2 t1+splitfWithVariance f t1 t2 Bivariant = (++) <$> f t1 t2 <*> f t2 t1+splitfWithVariance f t1 t2 Covariant = f t1 t2+splitfWithVariance f t1 t2 Contravariant = f t2 t1++updateEnv :: CGEnv -> RTVar RTyVar (RType RTyCon RTyVar b0) -> CG CGEnv+updateEnv γ a+ | Just (x, s) <- rTVarToBind a+ = γ += ("splitS RAllT", x, fmap (const mempty) s)+ | otherwise+ = return γ++------------------------------------------------------------+splitC :: Bool -> SubC -> CG [FixSubC]+------------------------------------------------------------++splitC allowTC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2+ = do γ' <- γ += ("addExBind 0", x, forallExprRefType γ tx)+ splitC allowTC (SubC γ' t1 t2)++splitC allowTC (SubC γ t1 (REx x tx t2))+ = do y <- fresh+ γ' <- γ += ("addExBind 1", y, forallExprRefType γ tx)+ splitC allowTC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))++-- existential at the left hand side is treated like forall+splitC allowTC (SubC γ (REx x tx t1) t2)+ = do -- let tx' = traceShow ("splitC allowTC: " ++ showpp z) tx+ y <- fresh+ γ' <- γ += ("addExBind 2", y, forallExprRefType γ tx)+ splitC allowTC (SubC γ' (F.subst1 t1 (x, F.EVar y)) t2)++splitC allowTC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2+ = do γ' <- γ += ("addAllBind 3", x, forallExprRefType γ tx)+ splitC allowTC (SubC γ' t1 t2)++splitC allowTC (SubC γ (RAllE x tx t1) t2)+ = do y <- fresh+ γ' <- γ += ("addAABind 1", y, forallExprRefType γ tx)+ splitC allowTC (SubC γ' (t1 `F.subst1` (x, F.EVar y)) t2)++splitC allowTC (SubC γ t1 (RAllE x tx t2))+ = do y <- fresh+ γ' <- γ += ("addAllBind 2", y, forallExprRefType γ tx)+ splitC allowTC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))++splitC allowTC (SubC cgenv (RRTy env _ OCons t1) t2)+ = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv xts+ c1 <- splitC allowTC (SubC γ' t1' t2')+ c2 <- splitC allowTC (SubC cgenv t1 t2 )+ return $ c1 ++ c2+ where+ (xts, t1', t2') = envToSub env++splitC allowTC (SubC cgenv (RRTy e r o t1) t2)+ = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv e+ c1 <- splitC allowTC (SubR γ' o r)+ c2 <- splitC allowTC (SubC cgenv t1 t2)+ return $ c1 ++ c2++splitC allowTC (SubC γ (RFun x1 i1 t1 t1' r1) (RFun x2 i2 t2 t2' r2))+ = do cs' <- splitC allowTC (SubC γ t2 t1)+ γ' <- γ+= ("splitC allowTC", x2, t2)+ cs <- bsplitC γ (RFun x1 i1 t1 t1' (r1 `F.subst1` (x1, F.EVar x2)))+ (RFun x2 i2 t2 t2' r2)+ let t1x2' = t1' `F.subst1` (x1, F.EVar x2)+ cs'' <- splitC allowTC (SubC γ' t1x2' t2')+ return $ cs ++ cs' ++ cs''++splitC allowTC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))+ = do cs <- bsplitC γ t1 t2+ cs' <- splitC allowTC (SubC γ r1 r2)+ cs'' <- splitC allowTC (SubC γ r1' r2')+ cs''' <- splitC allowTC (SubC γ r2' r1')+ return $ cs ++ cs' ++ cs'' ++ cs'''++splitC allowTC (SubC γ t1 (RAllP p t))+ = splitC allowTC $ SubC γ t1 t'+ where+ t' = fmap (replacePredsWithRefs su) t+ su = (uPVar p, pVartoRConc p)++splitC _ (SubC γ t1@(RAllP _ _) t2)+ = panic (Just $ getLocation γ) $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2++splitC allowTC (SubC γ t1'@(RAllT α1 t1 _) t2'@(RAllT α2 t2 _))+ | α1 == α2+ = do γ' <- updateEnv γ α2+ cs <- bsplitC γ t1' t2'+ cs' <- splitC allowTC $ SubC γ' t1 (F.subst su t2)+ return (cs ++ cs')+ | otherwise+ = do γ' <- updateEnv γ α2+ cs <- bsplitC γ t1' t2'+ cs' <- splitC allowTC $ SubC γ' t1 (F.subst su t2'')+ return (cs ++ cs')+ where+ t2'' = subsTyVarMeet' (ty_var_value α2, RVar (ty_var_value α1) mempty) t2+ su = case (rTVarToBind α1, rTVarToBind α2) of+ (Just (x1, _), Just (x2, _)) -> F.mkSubst [(x1, F.EVar x2)]+ _ -> F.mkSubst []++splitC allowTC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | (if allowTC then isEmbeddedDict else isClass) c1 && c1 == c2+ = return []++splitC _ (SubC γ t1@RApp{} t2@RApp{})+ = do (t1',t2') <- unifyVV t1 t2+ cs <- bsplitC γ t1' t2'+ γ' <- if bscope (getConfig γ) then γ `extendEnvWithVV` t1' else return γ+ let RApp c t1s r1s _ = t1'+ let RApp _ t2s r2s _ = t2'+ let isapplied = True -- TC.tyConArity (rtc_tc c) == length t1s+ let tyInfo = rtc_info c+ csvar <- splitsCWithVariance γ' t1s t2s $ varianceTyArgs tyInfo+ csvar' <- rsplitsCWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo+ return $ cs ++ csvar ++ csvar'++splitC _ (SubC γ t1@(RVar a1 _) t2@(RVar a2 _))+ | a1 == a2+ = bsplitC γ t1 t2++splitC _ (SubC γ t1 t2)+ = panic (Just $ getLocation γ) $ "(Another Broken Test!!!) splitc unexpected:\n" ++ traceTy t1 ++ "\n <:\n" ++ traceTy t2++splitC _ (SubR γ o r)+ = do ts <- getTemplates+ let r1' = pruneUnsortedReft γ'' ts r1+ return $ F.subC γ' r1' r2 Nothing tag ci+ where+ γ'' = feEnv $ fenv γ+ γ' = feBinds $ fenv γ+ r1 = F.RR F.boolSort rr+ r2 = F.RR F.boolSort $ F.Reft (vv, F.EVar vv)+ vv = "vvRec"+ ci = Ci src err (cgVar γ)+ err = Just $ ErrAssType src o (text $ show o ++ "type error") g (rHole rr)+ rr = F.toReft r+ tag = getTag γ+ src = getLocation γ+ g = reLocal $ renv γ++traceTy :: SpecType -> String+traceTy (RVar v _) = parens ("RVar " ++ showpp v)+traceTy (RApp c ts _ _) = parens ("RApp " ++ showpp c ++ unwords (traceTy <$> ts))+traceTy (RAllP _ t) = parens ("RAllP " ++ traceTy t)+traceTy (RAllT _ t _) = parens ("RAllT " ++ traceTy t)+traceTy (RFun _ _ t t' _) = parens ("RFun " ++ parens (traceTy t) ++ parens (traceTy t'))+traceTy (RAllE _ tx t) = parens ("RAllE " ++ parens (traceTy tx) ++ parens (traceTy t))+traceTy (REx _ tx t) = parens ("REx " ++ parens (traceTy tx) ++ parens (traceTy t))+traceTy (RExprArg _) = "RExprArg"+traceTy (RAppTy t t' _) = parens ("RAppTy " ++ parens (traceTy t) ++ parens (traceTy t'))+traceTy (RHole _) = "rHole"+traceTy (RRTy _ _ _ t) = parens ("RRTy " ++ traceTy t)++parens :: String -> String+parens s = "(" ++ s ++ ")"++rHole :: F.Reft -> SpecType+rHole = RHole . uTop+++splitsCWithVariance :: CGEnv+ -> [SpecType]+ -> [SpecType]+ -> [Variance]+ -> CG [FixSubC]+splitsCWithVariance γ t1s t2s variants+ = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitC (typeclass (getConfig γ)) (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants)++rsplitsCWithVariance :: Bool+ -> CGEnv+ -> [SpecProp]+ -> [SpecProp]+ -> [Variance]+ -> CG [FixSubC]+rsplitsCWithVariance False _ _ _ _+ = return []++rsplitsCWithVariance _ γ t1s t2s variants+ = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants)++bsplitC :: CGEnv+ -> SpecType+ -> SpecType+ -> CG [F.SubC Cinfo]+bsplitC γ t1 t2 = do+ temp <- getTemplates+ isHO <- gets allowHO+ t1' <- addLhsInv γ <$> refreshVV t1+ return $ bsplitC' γ t1' t2 temp isHO++addLhsInv :: CGEnv -> SpecType -> SpecType+addLhsInv γ t = addRTyConInv (invs γ) t `strengthen` r+ where+ r = (mempty :: UReft F.Reft) { ur_reft = F.Reft (F.dummySymbol, p) }+ p = constraintToLogic rE' (lcs γ)+ rE' = insertREnv v t (renv γ)+ v = rTypeValueVar t+++bsplitC' :: CGEnv -> SpecType -> SpecType -> F.Templates -> Bool -> [F.SubC Cinfo]+bsplitC' γ t1 t2 tem isHO+ | isHO+ = mkSubC γ' r1' r2' tag ci+ | F.isFunctionSortedReft r1' && F.isNonTrivial r2'+ = mkSubC γ' (r1' {F.sr_reft = mempty}) r2' tag ci+ | F.isNonTrivial r2'+ = mkSubC γ' r1' r2' tag ci+ | otherwise+ = []+ where+ γ' = feBinds $ fenv γ+ r1' = rTypeSortedReft' γ tem t1+ r2' = rTypeSortedReft' γ tem t2+ tag = getTag γ+ src = getLocation γ+ g = reLocal $ renv γ++ ci sr = Ci src (err sr) (cgVar γ)+ err sr = Just $ fromMaybe (ErrSubType src (text "subtype") Nothing g t1 (replaceTop t2 sr)) (cerr γ)++mkSubC :: F.IBindEnv -> F.SortedReft -> F.SortedReft -> F.Tag -> (F.SortedReft -> a) -> [F.SubC a]+mkSubC g sr1 sr2 tag ci = concatMap (\sr2' -> F.subC g sr1 sr2' Nothing tag (ci sr2')) (splitSortedReft sr2)++splitSortedReft :: F.SortedReft -> [F.SortedReft]+splitSortedReft (F.RR t (F.Reft (v, r))) = [ F.RR t (F.Reft (v, ra)) | ra <- refaConjuncts r ]++refaConjuncts :: F.Expr -> [F.Expr]+refaConjuncts p = [p' | p' <- F.conjuncts p, not $ F.isTautoPred p']++replaceTop :: SpecType -> F.SortedReft -> SpecType+replaceTop (RApp c ts rs r) r' = RApp c ts rs $ replaceReft r r'+replaceTop (RVar a r) r' = RVar a $ replaceReft r r'+replaceTop (RFun b i t1 t2 r) r' = RFun b i t1 t2 $ replaceReft r r'+replaceTop (RAppTy t1 t2 r) r' = RAppTy t1 t2 $ replaceReft r r'+replaceTop (RAllT a t r) r' = RAllT a t $ replaceReft r r'+replaceTop t _ = t++replaceReft :: RReft -> F.SortedReft -> RReft+replaceReft rr (F.RR _ r) = rr {ur_reft = F.Reft (v, F.subst1 p (vr, F.EVar v) )}+ where+ F.Reft (v, _) = ur_reft rr+ F.Reft (vr,p) = r++unifyVV :: SpecType -> SpecType -> CG (SpecType, SpecType)+unifyVV t1@RApp{} t2@RApp{}+ = do vv <- F.vv . Just <$> fresh+ return (shiftVV t1 vv, shiftVV t2 vv)++unifyVV _ _+ = panic Nothing "Constraint.Generate.unifyVV called on invalid inputs"++rsplitC :: CGEnv+ -> SpecProp+ -> SpecProp+ -> CG [FixSubC]+rsplitC _ _ (RProp _ (RHole _))+ = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"++rsplitC _ (RProp _ (RHole _)) _+ = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"++rsplitC γ (RProp s1 r1) (RProp s2 r2)+ = do γ' <- foldM (+=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2]+ splitC (typeclass (getConfig γ)) (SubC γ' (F.subst su r1) r2)+ where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]+++--------------------------------------------------------------------------------+-- | Reftypes from F.Fixpoint Expressions --------------------------------------+--------------------------------------------------------------------------------+forallExprRefType :: CGEnv -> SpecType -> SpecType+forallExprRefType γ t = t `strengthen` uTop r'+ where+ r' = fromMaybe mempty $ forallExprReft γ r+ r = F.sr_reft $ rTypeSortedReft (emb γ) t++forallExprReft :: CGEnv -> F.Reft -> Maybe F.Reft+forallExprReft γ r =+ do e <- F.isSingletonReft r+ forallExprReft_ γ $ F.splitEApp e++forallExprReft_ :: CGEnv -> (F.Expr, [F.Expr]) -> Maybe F.Reft+forallExprReft_ γ (F.EVar x, [])+ = case forallExprReftLookup γ x of+ Just (_,_,_,_,t) -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t+ Nothing -> Nothing++forallExprReft_ γ (F.EVar f, es)+ = case forallExprReftLookup γ f of+ Just (xs,_,_,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in+ Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t+ Nothing -> Nothing++forallExprReft_ _ _+ = Nothing++-- forallExprReftLookup :: CGEnv -> F.Symbol -> Int+forallExprReftLookup :: CGEnv+ -> F.Symbol+ -> Maybe ([F.Symbol], [RFInfo], [SpecType], [RReft], SpecType)+forallExprReftLookup γ sym = snap <$> F.lookupSEnv sym (syenv γ)+ 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)+++--------------------------------------------------------------------------------+getTag :: CGEnv -> F.Tag+--------------------------------------------------------------------------------+getTag γ = maybe Tg.defaultTag (`Tg.getTag` tgEnv γ) (tgKey γ)+++--------------------------------------------------------------------------------+-- | Constraint Generation Panic -----------------------------------------------+--------------------------------------------------------------------------------+panicUnbound :: (PPrint x) => CGEnv -> x -> a+panicUnbound γ x = Ex.throw (ErrUnbound (getLocation γ) (F.pprint x) :: Error)
+ src/Language/Haskell/Liquid/Constraint/Template.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.Constraint.Template (+ Template(..)+, unTemplate+, varTemplate+, addPostTemplate+, safeFromAsserted+, topSpecType+, derivedVar+, extender+) where++import Prelude hiding (error)+import qualified Data.Foldable as F+import qualified Data.Traversable as T+import qualified Data.HashSet as S+import Control.Monad.State ( gets )+import Text.PrettyPrint.HughesPJ ( text, (<+>) )+import GHC.Types.Var (Var)+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.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)++-- Template++data Template a+ = Asserted a+ | Assumed a+ | Internal a+ | Unknown+ deriving (Functor, F.Foldable, T.Traversable)++deriving instance (Show a) => (Show (Template a))++instance PPrint a => PPrint (Template a) where+ pprintTidy k (Asserted t) = text "Asserted" <+> pprintTidy k t+ pprintTidy k (Assumed t) = text "Assumed" <+> pprintTidy k t+ pprintTidy k (Internal t) = text "Internal" <+> pprintTidy k t+ pprintTidy _ Unknown = text "Unknown"++unTemplate :: Template t -> t+unTemplate (Asserted t) = t+unTemplate (Assumed t) = t+unTemplate (Internal t) = t+unTemplate _ = panic Nothing "Constraint.Template.unTemplate called on `Unknown`"++addPostTemplate :: CGEnv+ -> Template SpecType+ -> CG (Template SpecType)+addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t+addPostTemplate γ (Assumed t) = Assumed <$> addPost γ t+addPostTemplate γ (Internal t) = Internal <$> addPost γ t+addPostTemplate _ Unknown = return Unknown++safeFromAsserted :: [Char] -> Template t -> t+safeFromAsserted _ (Asserted t) = t+safeFromAsserted msg _ = panic Nothing $ "safeFromAsserted:" ++ msg++-- | @varTemplate@ is only called with a `Just e` argument when the `e`+-- corresponds to the body of a @Rec@ binder.+varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)+varTemplate γ (x, eo) = varTemplate' γ (x, eo) >>= mapM (topSpecType x)++-- | @lazVarTemplate@ is like `varTemplate` but for binders that are *not*+-- termination checked and hence, the top-level refinement / KVar is+-- stripped out. e.g. see tests/neg/T743.hs+-- varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)+-- lazyVarTemplate γ (x, eo) = dbg <$> (topRTypeBase <$>) <$> varTemplate' γ (x, eo)+-- where+-- dbg = traceShow ("LAZYVAR-TEMPLATE: " ++ show x)++varTemplate' :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)+varTemplate' γ (x, eo)+ = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ), lookupREnv (F.symbol x) (intys γ)) of+ (_, Just t, _, _) -> Asserted <$> refreshArgsTop (x, t)+ (_, _, _, Just t) -> Internal <$> refreshArgsTop (x, t)+ (_, _, Just t, _) -> Assumed <$> refreshArgsTop (x, t)+ (Just e, _, _, _) -> do t <- freshTyExpr (typeclass (getConfig γ)) (RecBindE x) e (exprType e)+ addW (WfC γ t)+ Asserted <$> refreshArgsTop (x, t)+ (_, _, _, _) -> return Unknown++-- | @topSpecType@ strips out the top-level refinement of "derived var"+topSpecType :: Var -> SpecType -> CG SpecType+topSpecType x t = do+ info <- gets ghcI+ return $ if derivedVar (giSrc info) x then topRTypeBase t else t++derivedVar :: TargetSrc -> Var -> Bool+derivedVar src x = S.member x (giDerVars src)++extender :: F.Symbolic a => CGEnv -> (a, Template SpecType) -> CG CGEnv+extender γ (x, Asserted t)+ = case lookupREnv (F.symbol x) (assms γ) of+ Just t' -> γ += ("extender", F.symbol x, t')+ _ -> γ += ("extender", F.symbol x, t)+extender γ (x, Assumed t)+ = γ += ("extender", F.symbol x, t)+extender γ _+ = return γ
+ src/Language/Haskell/Liquid/Constraint/Termination.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE TupleSections #-}+-- | This module defines code for generating termination constraints.++module Language.Haskell.Liquid.Constraint.Termination (+ TCheck(..)+, mkTCheck+, doTermCheck+, makeTermEnvs+, makeDecrIndex+, checkIndex+, recType+, unOCons+, consCBSizedTys+, consCBWithExprs+) where++import Data.Maybe ( fromJust, catMaybes, mapMaybe )+import qualified Data.List as L+import qualified Data.HashSet as S+import qualified Data.Traversable as T+import qualified Data.HashMap.Strict as M+import Control.Applicative (liftA2)+import Control.Monad.State ( gets, forM, foldM )+import Text.PrettyPrint.HughesPJ ( (<+>), text )+import GHC.Types.Var (Var)+import GHC.Types.Name (NamedThing, getSrcSpan)+import GHC.Core.TyCon (TyCon)+import GHC.Core (Bind, CoreExpr, bindersOf)+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.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)+++data TCheck = TerminationCheck | StrataCheck | NoCheck++mkTCheck :: Bool -> Bool -> TCheck+mkTCheck tc is+ | not is = StrataCheck+ | tc = TerminationCheck+ | otherwise = NoCheck++doTermCheck :: Config -> Bind Var -> CG Bool+doTermCheck cfg bind = do+ lazyVs <- gets specLazy+ termVs <- gets specTmVars+ let skip = any (\x -> S.member x lazyVs || nocheck x) xs+ let chk = not (structuralTerm cfg) || any (`S.member` termVs) xs+ return $ chk && not skip+ where+ nocheck = if typeclass cfg then GM.isEmbeddedDictVar else GM.isInternal+ xs = bindersOf bind++makeTermEnvs :: CGEnv -> [(Var, [F.Located F.Expr])] -> [(Var, CoreExpr)]+ -> [SpecType] -> [SpecType]+ -> [CGEnv]+makeTermEnvs γ xtes xes ts ts' = setTRec γ . zip xs <$> rts+ where+ vs = zipWith collectArgs' ts ces+ syms = fst5 . bkArrowDeep <$> ts+ syms' = fst5 . bkArrowDeep <$> ts'+ sus' = zipWith mkSub syms syms'+ sus = zipWith mkSub syms ((F.symbol <$>) <$> vs)+ ess = (\x -> safeFromJust (err x) (x `L.lookup` xtes)) <$> xs+ tes = zipWith (\su es -> F.subst su <$> es) sus ess+ tes' = zipWith (\su es -> F.subst su <$> es) sus' ess+ rss = zipWith makeLexRefa tes' <$> (repeat <$> tes)+ rts = zipWith (addObligation OTerm) ts' <$> rss+ (xs, ces) = unzip xes+ mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']+ collectArgs' = GM.collectArguments . length . ty_binds . toRTypeRep+ err x = "Constant: makeTermEnvs: no terminating expression for " ++ GM.showPpr x++addObligation :: Oblig -> SpecType -> RReft -> SpecType+addObligation o t r = mkArrow αs πs xts $ RRTy [] r o t2+ where+ (αs, πs, t1) = bkUniv t+ ((xs, is, ts, rs), t2) = bkArrow t1+ xts = zip4 xs is ts rs++--------------------------------------------------------------------------------+-- | TERMINATION TYPE ----------------------------------------------------------+--------------------------------------------------------------------------------++makeDecrIndex :: (Var, Template SpecType, [Var]) -> CG (Maybe Int)+makeDecrIndex (x, Assumed t, args)+ = do dindex <- makeDecrIndexTy x t args+ 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+ case dindex of+ Left msg -> addWarning msg >> return Nothing+ Right i -> return $ Just i+makeDecrIndex _ = return Nothing++makeDecrIndexTy :: Var -> SpecType -> [Var] -> CG (Either (TError t) Int)+makeDecrIndexTy x st args+ = do autosz <- gets autoSize+ return $ case dindex autosz of+ Nothing -> Left msg+ Just i -> Right i+ where+ msg = ErrTermin (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++recType :: F.Symbolic a+ => S.HashSet TyCon+ -> (([a], Maybe Int), (t, Maybe Int, SpecType))+ -> SpecType+recType _ ((_, Nothing), (_, Nothing, t)) = t+recType autoenv ((vs, indexc), (_, index, t))+ = makeRecType autoenv t v dxt index+ where v = (vs !!) <$> indexc+ dxt = (xts !!) <$> index+ xts = zip (ty_binds trep) (ty_args trep)+ trep = toRTypeRep $ unOCons t++checkIndex :: (NamedThing t, PPrint t, PPrint a)+ => (t, [a], Template (RType c tv r), Maybe Int)+ -> CG (Maybe (RType c tv r))+checkIndex (_, _, _, Nothing ) = return Nothing+checkIndex (x, vs, t, Just index) = safeLogIndex msg1 vs index >> safeLogIndex msg2 ts index+ where+ loc = getSrcSpan x+ ts = ty_args $ toRTypeRep $ unOCons $ unTemplate t+ msg1 = ErrTermin loc [xd] (text "No decreasing" <+> F.pprint index <-> text "-th argument on" <+> xd <+> text "with" <+> F.pprint vs)+ msg2 = ErrTermin loc [xd] (text "No decreasing parameter")+ xd = F.pprint x++makeRecType :: (Enum a1, Eq a1, Num a1, F.Symbolic a)+ => S.HashSet TyCon+ -> SpecType+ -> Maybe a+ -> Maybe (F.Symbol, SpecType)+ -> Maybe a1+ -> SpecType+makeRecType autoenv t vs dxs is+ = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}+ where+ (xs', ts') = unzip $ replaceN (fromJust is) (safeFromLeft "makeRecType" $ makeDecrType autoenv vdxs) xts+ vdxs = liftA2 (,) vs dxs+ xts = zip (ty_binds trep) (ty_args trep)+ trep = toRTypeRep $ unOCons t++unOCons :: RType c tv r -> RType c tv r+unOCons (RAllT v t r) = RAllT v (unOCons t) r+unOCons (RAllP p t) = RAllP p $ unOCons t+unOCons (RFun x i tx t r) = RFun x i (unOCons tx) (unOCons t) r+unOCons (RRTy _ _ OCons t) = unOCons t+unOCons t = t++mergecondition :: RType c tv r -> RType c tv r -> RType c tv r+mergecondition (RAllT _ t1 _) (RAllT v t2 r2) = RAllT v (mergecondition t1 t2) r2+mergecondition (RAllP _ t1) (RAllP p t2) = RAllP p (mergecondition t1 t2)+mergecondition (RRTy xts r OCons t1) t2 = RRTy xts r OCons (mergecondition t1 t2)+mergecondition (RFun _ _ t11 t12 _) (RFun x2 i t21 t22 r2) = RFun x2 i (mergecondition t11 t21) (mergecondition t12 t22) r2+mergecondition _ t = t++safeLogIndex :: Error -> [a] -> Int -> CG (Maybe a)+safeLogIndex err ls n+ | n >= length ls = addWarning err >> return Nothing+ | otherwise = return $ Just $ ls !! n++-- RJ: AAAAAAARGHHH!!!!!! THIS CODE IS HORRIBLE!!!!!!!!!+consCBSizedTys :: (Bool -> CGEnv -> (Var, CoreExpr, Template SpecType) -> CG (Template SpecType)) ->+ CGEnv -> [(Var, CoreExpr)] -> CG CGEnv+consCBSizedTys consBind γ xes+ = do ts' <- forM xes $ \(x, e) -> varTemplate γ (x, Just e)+ autoenv <- gets autoSize+ ts <- forM ts' $ T.mapM refreshArgs+ let vs = zipWith collectArgs' ts es+ is <- mapM makeDecrIndex (zip3 vars ts vs) >>= 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+ γ' <- foldM extender γ (zip vars ts)+ let γs = zipWith makeRecInvariants [γ' `setTRec` zip vars rts' | rts' <- rts] (filter (not . noMakeRec) <$> vs)+ mapM_ (uncurry $ consBind True) (zip γs (zip3 vars es ts))+ return γ'+ where+ noMakeRec = if allowTC then GM.isEmbeddedDictVar else GM.isPredVar+ allowTC = typeclass (getConfig γ)+ (vars, es) = unzip xes+ dxs = F.pprint <$> vars+ collectArgs' = GM.collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate+ checkEqTypes :: [Maybe SpecType] -> CG [SpecType]+ checkEqTypes x = checkAllVsHead err1 toRSort (catMaybes x)+ err1 = ErrTermin loc dxs $ text "The decreasing parameters should be of same type"+ checkSameLens :: [Maybe Int] -> CG [Maybe Int]+ checkSameLens = checkAllVsHead err2 length+ err2 = ErrTermin loc dxs $ text "All Recursive functions should have the same number of decreasing parameters"+ loc = getSrcSpan (head vars)++ checkAllVsHead :: Eq b => Error -> (a -> b) -> [a] -> CG [a]+ checkAllVsHead _ _ [] = return []+ checkAllVsHead err f (x:xs)+ | all (== f x) (f <$> xs) = return (x:xs)+ | otherwise = addWarning err >> return []++consCBWithExprs :: (Bool -> CGEnv -> (Var, CoreExpr, Template SpecType) -> CG (Template SpecType)) ->+ CGEnv -> [(Var, CoreExpr)] -> CG CGEnv+consCBWithExprs consBind γ xes+ = do ts0 <- forM xes $ \(x, e) -> varTemplate γ (x, Just e)+ texprs <- gets termExprs+ let xtes = mapMaybe (`lookup'` texprs) xs+ let ts = safeFromAsserted err <$> ts0+ ts' <- mapM refreshArgs ts+ let xts = zip xs (Asserted <$> ts')+ γ' <- foldM extender γ xts+ let γs = makeTermEnvs γ' xtes xes ts ts'+ mapM_ (uncurry $ consBind True) (zip γs (zip3 xs es (Asserted <$> ts')))+ return γ'+ where (xs, es) = unzip xes+ lookup' k m = (k,) <$> M.lookup k m+ err = "Constant: consCBWithExprs"
+ src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.Constraint.ToFixpoint+ ( cgInfoFInfo+ , fixConfig+ , refinementEQs+ , canRewrite+ ) where++import Prelude hiding (error)+import qualified Liquid.GHC.API as Ghc+import Liquid.GHC.API (Var, Id, TyCon)+import qualified Language.Fixpoint.Types.Config as FC+import System.Console.CmdArgs.Default (def)+import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Solver.Rewrite (unify)+import Language.Haskell.Liquid.Constraint.Types+import qualified Language.Haskell.Liquid.Types.RefType as RT+import Language.Haskell.Liquid.Constraint.Qualifier+import Control.Monad (guard)+import qualified Data.Maybe as Mb++-- AT: Move to own module?+-- imports for AxiomEnv+import qualified Language.Haskell.Liquid.UX.Config as 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+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+-- import Language.Fixpoint.Misc+import qualified Language.Haskell.Liquid.Misc as Misc++import Language.Haskell.Liquid.Types hiding ( binds )++fixConfig :: FilePath -> Config -> FC.Config+fixConfig tgt cfg = def+ { FC.solver = Mb.fromJust (smtsolver cfg)+ , FC.linear = linear cfg+ , FC.eliminate = eliminate cfg+ , FC.nonLinCuts = not (higherOrderFlag cfg) -- eliminate cfg /= FC.All+ , FC.save = saveQuery cfg+ , FC.srcFile = tgt+ , FC.cores = cores cfg+ , FC.minPartSize = minPartSize cfg+ , FC.maxPartSize = maxPartSize cfg+ , FC.elimStats = elimStats cfg+ , FC.elimBound = elimBound cfg+ , FC.allowHO = higherOrderFlag cfg+ , FC.allowHOqs = higherorderqs cfg+ , FC.smtTimeout = smtTimeout cfg+ , FC.stringTheory = stringTheory cfg+ , FC.gradual = gradual cfg+ , FC.ginteractive = ginteractive cfg+ , FC.noslice = noslice cfg+ , FC.rewriteAxioms = Config.allowPLE cfg+ , FC.pleWithUndecidedGuards = Config.pleWithUndecidedGuards 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+ , FC.oldPLE = oldPLE cfg+ , FC.rwTerminationCheck = rwTerminationCheck cfg+ , FC.noLazyPLE = noLazyPLE cfg+ , FC.fuel = fuel cfg+ , FC.noEnvironmentReduction = not (environmentReduction cfg)+ , FC.inlineANFBindings = inlineANFBindings cfg+ }++cgInfoFInfo :: TargetInfo -> CGInfo -> IO (F.FInfo Cinfo)+cgInfoFInfo info cgi = return (targetFInfo info cgi)++targetFInfo :: TargetInfo -> CGInfo -> F.FInfo Cinfo+targetFInfo info cgi = mappend (mempty { F.ae = ax }) fi+ where+ fi = F.fi cs ws bs ls consts ks qs bi aHO aHOqs es mempty adts ebs+ cs = fixCs cgi+ ws = fixWfs cgi+ bs = binds cgi+ ebs = ebinds cgi+ ls = fEnv cgi+ consts = cgConsts cgi+ ks = kuts cgi+ adts = cgADTs cgi+ qs = giQuals info (fEnv cgi)+ bi = (\x -> Ci x Nothing Nothing) <$> bindSpans cgi+ aHO = allowHO cgi+ aHOqs = higherOrderFlag info+ es = [] -- makeAxioms info+ ax = makeAxiomEnvironment info (dataConTys cgi) (F.cm fi)+ -- msg = show . map F.symbol . M.keys . tyConInfo++makeAxiomEnvironment :: TargetInfo -> [(Var, SpecType)] -> M.HashMap F.SubcId (F.SubC Cinfo) -> F.AxiomEnv+makeAxiomEnvironment info xts fcs+ = F.AEnv eqs+ (concatMap makeSimplify xts)+ (doExpand sp cfg <$> fcs)+ (makeRewrites info <$> fcs)+ where+ eqs = if oldPLE cfg+ then makeEquations (typeclass cfg) sp ++ map (uncurry $ specTypeEq emb) xts+ else axioms+ emb = gsTcEmbeds (gsName sp)+ cfg = getConfig info+ sp = giSpec info+ axioms = gsMyAxioms refl ++ gsImpAxioms refl+ refl = gsRefl sp+++makeRewrites :: TargetInfo -> F.SubC Cinfo -> [F.AutoRewrite]+makeRewrites info sub = concatMap (makeRewriteOne tce) $ filter ((`S.member` rws) . fst) sigs+ where+ tce = gsTcEmbeds (gsName spec)+ spec = giSpec info+ sig = gsSig spec+ sigs = gsTySigs sig ++ gsAsmSigs sig+ isGlobalRw = Mb.maybe False (`elem` globalRws) parentFunction++ parentFunction :: Maybe Var+ parentFunction =+ case subVar sub of+ Just v -> Just v+ Nothing ->+ Mb.listToMaybe $ do+ D s e v <- coreDefs $ giCbs $ giSrc info+ let (Ghc.RealSrcSpan cc _) = ci_loc $ F.sinfo sub+ guard $ s <= Ghc.srcSpanStartLine cc && e >= Ghc.srcSpanEndLine cc+ return v++ rws =+ if isGlobalRw+ then S.empty+ else S.difference+ (S.union localRws globalRws)+ (Mb.maybe S.empty forbiddenRWs parentFunction)++ allDeps = coreDeps $ giCbs $ giSrc info+ forbiddenRWs sv =+ S.insert sv $ dependsOn allDeps [sv]++ localRws = Mb.fromMaybe S.empty $ do+ var <- parentFunction+ usable <- M.lookup var $ gsRewritesWith $ gsRefl spec+ return $ S.fromList usable++ globalRws = S.map val $ gsRewrites $ gsRefl spec+++canRewrite :: S.HashSet F.Symbol -> F.Expr -> F.Expr -> Bool+canRewrite freeVars' from to = noFreeSyms && doesNotDiverge+ where+ fromSyms = S.intersection freeVars' (S.fromList $ F.syms from)+ toSyms = S.intersection freeVars' (S.fromList $ F.syms to)+ noFreeSyms = S.null $ S.difference toSyms fromSyms+ doesNotDiverge = Mb.isNothing (unify (S.toList freeVars') from to)+ || Mb.isJust (unify (S.toList freeVars') to from)++refinementEQs :: LocSpecType -> [(F.Expr, F.Expr)]+refinementEQs t =+ case stripRTypeBase tres of+ Just r ->+ [ (lhs, rhs) | (F.EEq lhs rhs) <- F.splitPAnd $ F.reftPred (F.toReft r) ]+ Nothing ->+ []+ where+ tres = ty_res tRep+ tRep = toRTypeRep $ val t++makeRewriteOne :: F.TCEmb TyCon -> (Var, LocSpecType) -> [F.AutoRewrite]+makeRewriteOne tce (_, t)+ = [rw | (lhs, rhs) <- refinementEQs t , rw <- rewrites lhs rhs ]+ where++ rewrites :: F.Expr -> F.Expr -> [F.AutoRewrite]+ rewrites lhs rhs =+ (guard (canRewrite freeVars' lhs rhs) >> [F.AutoRewrite xs lhs rhs])+ ++ (guard (canRewrite freeVars' rhs lhs) >> [F.AutoRewrite xs rhs lhs])++ freeVars' = S.fromList (ty_binds tRep)++ 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))++ tRep = toRTypeRep $ val t++_isClassOrDict :: Id -> Bool+_isClassOrDict x = F.tracepp ("isClassOrDict: " ++ F.showpp x) (hasClassArg x || GM.isDictionary x || Mb.isJust (Ghc.isClassOpId_maybe x))++hasClassArg :: Id -> Bool+hasClassArg x = F.tracepp msg (GM.isDataConId x && any Ghc.isClassPred (t:ts'))+ where+ msg = "hasClassArg: " ++ showpp (x, t:ts')+ (ts, t) = Ghc.splitFunTys . snd . Ghc.splitForAllTyCoVars . Ghc.varType $ x+ ts' = map Ghc.irrelevantMult ts+++doExpand :: TargetSpec -> Config -> F.SubC Cinfo -> Bool+doExpand sp cfg sub = Config.allowGlobalPLE cfg+ || (Config.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+-- 2. Make the `ctor` well-sorted or +-- 3. Don't create `define` for the ctor. +-- Unfortunately 3 breaks a bunch of tests...++specTypeEq :: F.TCEmb TyCon -> Var -> SpecType -> F.Equation+specTypeEq emb f t = F.mkEquation (F.symbol f) xts body tOut+ where+ xts = Misc.safeZipWithError "specTypeEq" xs (RT.rTypeSort emb <$> ts)+ body = specTypeToResultRef bExp t+ tOut = RT.rTypeSort emb (ty_res tRep)+ tRep = toRTypeRep t+ xs = ty_binds tRep+ ts = ty_args tRep+ bExp = F.eApps (F.eVar f) (F.EVar <$> xs)++makeSimplify :: (Var, SpecType) -> [F.Rewrite]+makeSimplify (var, t)+ | not (GM.isDataConId var)+ = []+ | otherwise+ = go $ specTypeToResultRef (F.eApps (F.EVar $ F.symbol var) (F.EVar <$> ty_binds (toRTypeRep t))) t+ where+ go (F.PAnd es) = concatMap go es++ go (F.PAtom eq (F.EApp (F.EVar f) expr) bd)+ | eq `elem` [F.Eq, F.Ueq]+ , (F.EVar dc, xs) <- F.splitEApp expr+ , dc == F.symbol var+ , all isEVar xs+ = [F.SMeasure f dc (fromEVar <$> xs) bd]++ go (F.PIff (F.EApp (F.EVar f) expr) bd)+ | (F.EVar dc, xs) <- F.splitEApp expr+ , dc == F.symbol var+ , all isEVar xs+ = [F.SMeasure f dc (fromEVar <$> xs) bd]++ go (F.EApp (F.EVar f) expr)+ | (F.EVar dc, xs) <- F.splitEApp expr+ , dc == F.symbol var+ , all isEVar xs+ = [F.SMeasure f dc (fromEVar <$> xs) F.PTrue]++ go (F.PNot (F.EApp (F.EVar f) expr))+ | (F.EVar dc, xs) <- F.splitEApp expr+ , dc == F.symbol var+ , all isEVar xs+ = [F.SMeasure f dc (fromEVar <$> xs) F.PFalse]++ go _ = []++ isEVar (F.EVar _) = True+ isEVar _ = False++ fromEVar (F.EVar x) = x+ fromEVar _ = impossible Nothing "makeSimplify.fromEVar"++makeEquations :: Bool -> TargetSpec -> [F.Equation]+makeEquations allowTC sp = [ F.mkEquation f xts (equationBody allowTC (F.EVar f) xArgs e mbT) t+ | F.Equ f xts e t _ <- axioms+ , let xArgs = F.EVar . fst <$> xts+ , let mbT = if null xArgs then Nothing else M.lookup f sigs+ ]+ where+ axioms = gsMyAxioms refl ++ gsImpAxioms refl+ refl = gsRefl sp+ sigs = M.fromList [ (GM.simplesymbol v, t) | (v, t) <- gsTySigs (gsSig sp) ]++equationBody :: Bool -> F.Expr -> [F.Expr] -> F.Expr -> Maybe LocSpecType -> F.Expr+equationBody allowTC f xArgs e mbT+ | Just t <- mbT = F.pAnd [eBody, rBody t]+ | otherwise = eBody+ where+ eBody = F.PAtom F.Eq (F.eApps f xArgs) e+ rBody t = specTypeToLogic allowTC xArgs (F.eApps f xArgs) (val t)++-- NV Move this to types?+-- sound but imprecise approximation of a type in the logic+specTypeToLogic :: Bool -> [F.Expr] -> F.Expr -> SpecType -> F.Expr+specTypeToLogic allowTC es expr st+ | ok = F.subst su (F.PImp (F.pAnd args) res)+ | otherwise = F.PTrue+ where+ res = specTypeToResultRef expr st+ args = zipWith mkExpr (mkReft <$> ts) es+ mkReft t = F.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+ okArgs = all okArg ts++ okArg (RVar _ _) = True+ okArg t@RApp{} = F.isTauto (t{rt_reft = mempty})+ okArg _ = False+++ su = F.mkSubst $ zip xs es+ (cls, nocls) = L.partition ((if allowTC then isEmbeddedClass else isClassType).snd) $ zip (ty_binds trep) (ty_args trep)+ :: ([(F.Symbol, SpecType)], [(F.Symbol, SpecType)])+ (xs, ts) = unzip nocls :: ([F.Symbol], [SpecType])++ trep = toRTypeRep st+++specTypeToResultRef :: F.Expr -> SpecType -> F.Expr+specTypeToResultRef e t+ = mkExpr $ F.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
@@ -0,0 +1,469 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.Liquid.Constraint.Types+ ( -- * Constraint Generation Monad+ CG++ -- * Constraint information+ , CGInfo (..)++ -- * Constraint Generation Environment+ , CGEnv (..)++ -- * Logical constraints (FIXME: related to bounds?)+ , LConstraint (..)++ -- * Fixpoint environment+ , FEnv (..)+ , initFEnv+ , insertsFEnv+ -- , removeFEnv++ -- * Hole Environment+ , HEnv+ , fromListHEnv+ , elemHEnv++ -- * Subtyping Constraints+ , SubC (..)+ , FixSubC++ , subVar++ -- * Well-formedness Constraints+ , WfC (..)+ , FixWfC++ -- * Invariants+ , RTyConInv+ , mkRTyConInv+ , addRTyConInv+ , addRInv++ -- * Aliases?+ , RTyConIAl+ , mkRTyConIAl++ , removeInvariant, restoreInvariant, makeRecInvariants++ , getTemplates++ , getLocation+ ) where++import Prelude hiding (error)+import Text.PrettyPrint.HughesPJ hiding ((<>))+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.List as L+import Control.DeepSeq+import Data.Maybe (isJust, mapMaybe)+import Control.Monad.State++import Language.Haskell.Liquid.GHC.SpanStack+import Liquid.GHC.API as Ghc hiding ( (<+>)+ , vcat+ , parens+ , ($+$)+ )+import Language.Haskell.Liquid.Misc (thrd3)+import Language.Haskell.Liquid.WiredIn (wiredSortedSyms)+import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Misc++import qualified Language.Haskell.Liquid.UX.CTags as Tg++import Language.Haskell.Liquid.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+ , fenv :: !FEnv -- ^ Fixpoint Environment+ , recs :: !(S.HashSet Var) -- ^ recursive defs being processed (for annotations)+ , invs :: !RTyConInv -- ^ Datatype invariants+ , rinvs :: !RTyConInv -- ^ Datatype recursive invariants: ignored in the base case assumed in rec call+ , ial :: !RTyConIAl -- ^ Datatype checkable invariants+ , grtys :: !REnv -- ^ Top-level variables with (assert)-guarantees to verify+ , assms :: !REnv -- ^ Top-level variables with assumed types+ , intys :: !REnv -- ^ Top-level variables with auto generated internal types+ , emb :: F.TCEmb Ghc.TyCon -- ^ How to embed GHC Tycons into fixpoint sorts+ , tgEnv :: !Tg.TagEnv -- ^ Map from top-level binders to fixpoint tag+ , tgKey :: !(Maybe Tg.TagKey) -- ^ Current top-level binder+ , trec :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints+ , lcb :: !(M.HashMap F.Symbol CoreExpr) -- ^ Let binding that have not been checked (c.f. LAZYVARs)+ , forallcb :: !(M.HashMap Var F.Expr) -- ^ Polymorhic let bindings+ , holes :: !HEnv -- ^ Types with holes, will need refreshing+ , lcs :: !LConstraint -- ^ Logical Constraints+ , cerr :: !(Maybe (TError SpecType)) -- ^ error that should be reported at the user+ , cgInfo :: !TargetInfo -- ^ top-level TargetInfo+ , cgVar :: !(Maybe Var) -- ^ top level function being checked+ } -- deriving (Data, Typeable)++instance HasConfig CGEnv where+ getConfig = getConfig . cgInfo++newtype LConstraint = LC [[(F.Symbol, SpecType)]]++instance Monoid LConstraint where+ mempty = LC []+ mappend = (<>)++instance Semigroup LConstraint where+ LC cs1 <> LC cs2 = LC (cs1 ++ cs2)++instance PPrint CGEnv where+ pprintTidy k = pprintTidy k . renv++instance Show CGEnv where+ show = showpp++getLocation :: CGEnv -> SrcSpan+getLocation = srcSpan . cgLoc++--------------------------------------------------------------------------------+-- | Subtyping Constraints -----------------------------------------------------+--------------------------------------------------------------------------------++-- RJ: what is the difference between these two?++data SubC = SubC { senv :: !CGEnv+ , lhs :: !SpecType+ , rhs :: !SpecType+ }+ | SubR { senv :: !CGEnv+ , oblig :: !Oblig+ , ref :: !RReft+ }++data WfC = WfC !CGEnv !SpecType+ -- deriving (Data, Typeable)++type FixSubC = F.SubC Cinfo+type FixWfC = F.WfC Cinfo+type FixBindEnv = F.BindEnv Cinfo++subVar :: FixSubC -> Maybe Var+subVar = ci_var . F.sinfo++instance PPrint SubC where+ pprintTidy k c@SubC {} =+ "The environment:"+ $+$+ ""+ $+$+ pprintTidy k (senv c)+ $+$+ ""+ $+$+ "Location: " <> pprintTidy k (getLocation (senv c))+ $+$+ "The constraint:"+ $+$+ ""+ $+$+ "||-" <+> vcat [ pprintTidy k (lhs c)+ , "<:"+ , pprintTidy k (rhs c) ]++ pprintTidy k c@SubR {} =+ "The environment:"+ $+$+ ""+ $+$+ pprintTidy k (senv c)+ $+$+ ""+ $+$+ "Location: " <> pprintTidy k (getLocation (senv c))+ $+$+ "The constraint:"+ $+$+ ""+ $+$+ "||-" <+> vcat [ pprintTidy k (ref c)+ , parens (pprintTidy k (oblig c))]++instance PPrint WfC where+ pprintTidy k (WfC _ r) = {- pprintTidy k w <> text -} "<...> |-" <+> pprintTidy k r+++--------------------------------------------------------------------------------+-- | 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+ }+++getTemplates :: CG F.Templates+getTemplates = do+ fg <- gets pruneRefs+ ts <- gets unsorted+ return $ if fg then F.anything else ts+++instance PPrint CGInfo where+ pprintTidy = pprCGInfo++pprCGInfo :: F.Tidy -> CGInfo -> Doc+pprCGInfo _k _cgi+ = "*********** Constraint Information (omitted) *************"+ -- -$$ (text "*********** Haskell SubConstraints ***********")+ -- -$$ (pprintLongList $ hsCs cgi)+ -- -$$ (text "*********** Haskell WFConstraints ************")+ -- -$$ (pprintLongList $ hsWfs cgi)+ -- -$$ (text "*********** Fixpoint SubConstraints **********")+ -- -$$ (F.toFix $ fixCs cgi)+ -- -$$ (text "*********** Fixpoint WFConstraints ************")+ -- -$$ (F.toFix $ fixWfs cgi)+ -- -$$ (text "*********** Fixpoint Kut Variables ************")+ -- -$$ (F.toFix $ kuts cgi)+ -- -$$ "*********** Literals in Source ************"+ -- -$$ F.pprint (cgLits _cgi)+ -- -$$ (text "*********** KVar Distribution *****************")+ -- -$$ (pprint $ kvProf cgi)+ -- -$$ (text "Recursive binders:" <+> pprint (recCount cgi))+++--------------------------------------------------------------------------------+-- | Helper Types: HEnv --------------------------------------------------------+--------------------------------------------------------------------------------++newtype HEnv = HEnv (S.HashSet F.Symbol)++fromListHEnv :: [F.Symbol] -> HEnv+fromListHEnv = HEnv . S.fromList++elemHEnv :: F.Symbol -> HEnv -> Bool+elemHEnv x (HEnv s) = x `S.member` s++--------------------------------------------------------------------------------+-- | Helper Types: Invariants --------------------------------------------------+--------------------------------------------------------------------------------+data RInv = RInv { _rinv_args :: [RSort] -- empty list means that the invariant is generic+ -- for all type arguments+ , _rinv_type :: SpecType+ , _rinv_name :: Maybe Var+ } deriving Show++type RTyConInv = M.HashMap RTyCon [RInv]+type RTyConIAl = M.HashMap RTyCon [RInv]++--------------------------------------------------------------------------------+mkRTyConInv :: [(Maybe Var, F.Located SpecType)] -> RTyConInv+--------------------------------------------------------------------------------+mkRTyConInv tss = group [ (c, RInv (go ts) t v) | (v, t@(RApp c ts _ _)) <- strip <$> tss]+ where+ strip = mapSnd (thrd3 . bkUniv . val)+ go ts | generic (toRSort <$> ts) = []+ | otherwise = toRSort <$> ts++ generic ts = let ts' = L.nub ts in+ all isRVar ts' && length ts' == length ts++mkRTyConIAl :: [(a, F.Located SpecType)] -> RTyConInv+mkRTyConIAl = mkRTyConInv . fmap ((Nothing,) . snd)++addRTyConInv :: RTyConInv -> SpecType -> SpecType+addRTyConInv m t+ = case lookupRInv t m of+ Nothing -> t+ Just ts -> L.foldl' conjoinInvariantShift t ts++lookupRInv :: SpecType -> RTyConInv -> Maybe [SpecType]+lookupRInv (RApp c ts _ _) m+ = case M.lookup c m of+ Nothing -> Nothing+ Just invs -> Just (mapMaybe (goodInvs ts) invs)+lookupRInv _ _+ = Nothing++goodInvs :: [SpecType] -> RInv -> Maybe SpecType+goodInvs _ (RInv [] t _)+ = Just t+goodInvs ts (RInv ts' t _)+ | and (zipWith unifiable ts' (toRSort <$> ts))+ = Just t+ | otherwise+ = Nothing+++unifiable :: RSort -> RSort -> Bool+unifiable t1 t2 = isJust $ tcUnifyTy (toType False t1) (toType False t2)++addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType)+addRInv m (x, t)+ | x `elem` ids , Just invs <- lookupRInv (res t) m+ = (x, addInvCond t (mconcat $ mapMaybe stripRTypeBase invs))+ | otherwise+ = (x, t)+ where+ ids = [id' | tc <- M.keys m+ , dc <- Ghc.tyConDataCons $ rtc_tc tc+ , AnId id' <- Ghc.dataConImplicitTyThings dc]+ res = ty_res . toRTypeRep++conjoinInvariantShift :: SpecType -> SpecType -> SpecType+conjoinInvariantShift t1 t2+ = conjoinInvariant t1 (shiftVV t2 (rTypeValueVar t1))++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)++conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir)+ = t { rt_reft = r `F.meet` ir }++conjoinInvariant t@(RVar _ r) (RVar _ ir)+ = t { rt_reft = r `F.meet` ir }++conjoinInvariant t _+ = t++removeInvariant :: CGEnv -> CoreBind -> (CGEnv, RTyConInv)+removeInvariant γ cbs+ = (γ { invs = M.map (filter f) (invs γ)+ , rinvs = M.map (filter (not . f)) (invs γ)}+ , invs γ)+ where+ f i | Just v <- _rinv_name i, v `elem` binds cbs+ = False+ | otherwise+ = True+ binds (NonRec x _) = [x]+ binds (Rec xes) = map fst xes++restoreInvariant :: CGEnv -> RTyConInv -> CGEnv+restoreInvariant γ is = γ {invs = is}++makeRecInvariants :: CGEnv -> [Var] -> CGEnv+makeRecInvariants γ [x] = γ {invs = M.unionWith (++) (invs γ) is}+ where+ is = M.map (map g . filter (isJust . (varType x `tcUnifyTy`) . toType False . _rinv_type)) (rinvs γ)+ g i = i{_rinv_type = guard' $ _rinv_type i}++ guard' (RApp c ts rs r)+ | Just f <- szFun <$> sizeFunction (rtc_info c)+ = RApp c ts rs (MkUReft (ref f $ F.toReft r) mempty)+ | otherwise+ = RApp c ts rs mempty+ guard' t+ = t++ ref f (F.Reft(v, rr))+ = F.Reft (v, F.PImp (F.PAtom F.Lt (f v) (f $ F.symbol x)) rr)++makeRecInvariants γ _ = γ++--------------------------------------------------------------------------------+-- | Fixpoint Environment ------------------------------------------------------+--------------------------------------------------------------------------------++data FEnv = FE+ { feBinds :: !F.IBindEnv -- ^ Integer Keys for Fixpoint Environment+ , feEnv :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment+ , feIdEnv :: !(F.SEnv F.BindId) -- ^ Map from Symbol to current BindId+ }++insertFEnv :: FEnv -> ((F.Symbol, F.Sort), F.BindId) -> FEnv+insertFEnv (FE benv env ienv) ((x, t), i)+ = FE (F.insertsIBindEnv [i] benv)+ (F.insertSEnv x t env)+ (F.insertSEnv x i ienv)++insertsFEnv :: FEnv -> [((F.Symbol, F.Sort), F.BindId)] -> FEnv+insertsFEnv = L.foldl' insertFEnv++initFEnv :: [(F.Symbol, F.Sort)] -> FEnv+initFEnv xts = FE benv0 env0 ienv0+ where+ benv0 = F.emptyIBindEnv+ env0 = F.fromListSEnv (wiredSortedSyms ++ xts)+ ienv0 = F.emptySEnv++--------------------------------------------------------------------------------+-- | Forcing Strictness --------------------------------------------------------+--------------------------------------------------------------------------------+instance NFData RInv where+ 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+ `seq` rnf x55+ `seq` rnf x6+ `seq` x7+ `seq` rnf x8+ `seq` rnf x9+ `seq` rnf x10+ `seq` rnf x4++instance NFData FEnv where+ rnf (FE x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3++instance NFData SubC where+ rnf (SubC x1 x2 x3)+ = rnf x1 `seq` rnf x2 `seq` rnf x3+ rnf (SubR x1 _ x2)+ = rnf x1 `seq` rnf x2++instance NFData WfC where+ rnf (WfC x1 x2)+ = rnf x1 `seq` rnf x2++instance NFData CGInfo where+ rnf x = ({-# SCC "CGIrnf1" #-} rnf (hsCs x)) `seq`+ ({-# SCC "CGIrnf2" #-} rnf (hsWfs x)) `seq`+ ({-# SCC "CGIrnf3" #-} rnf (fixCs x)) `seq`+ ({-# SCC "CGIrnf4" #-} rnf (fixWfs x)) `seq`+ ({-# SCC "CGIrnf6" #-} rnf (freshIndex x)) `seq`+ ({-# SCC "CGIrnf7" #-} rnf (binds x)) `seq`+ ({-# SCC "CGIrnf8" #-} rnf (annotMap x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (kuts x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (kvPacks x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (cgLits x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (cgConsts x)) `seq`+ ({-# SCC "CGIrnf10" #-} rnf (kvProf x))
+ src/Language/Haskell/Liquid/GHC/Interface.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wwarn=deprecations #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.GHC.Interface (++ -- * Printer+ pprintCBs++ -- * predicates+ -- , isExportedVar+ -- , exportedVars++ -- * Internal exports (provisional)+ , extractSpecComments+ , extractSpecQuotes'+ , makeLogicMap+ , classCons+ , derivedVars+ , importVars+ , allImports+ , qualifiedImports+ , modSummaryHsFile+ , makeFamInstEnv+ , parseSpecFile+ , clearSpec+ , checkFilePragmas+ , keepRawTokenStream+ , ignoreInline+ , lookupTyThings+ , availableTyCons+ , availableVars+ , updLiftedSpec+ ) where++import Prelude hiding (error)++import Liquid.GHC.API as Ghc hiding ( text+ , (<+>)+ , panic+ , vcat+ , showPpr+ , mkStableModule+ , Located+ )+import qualified Liquid.GHC.API as Ghc++import Control.Exception+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 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.UX.Tidy++import qualified Debug.Trace as Debug+++--------------------------------------------------------------------------------+-- | Extract Ids ---------------------------------------------------------------+--------------------------------------------------------------------------------++classCons :: Maybe [ClsInst] -> [Id]+classCons Nothing = []+classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs++derivedVars :: Config -> MGIModGuts -> [Var]+derivedVars cfg mg = concatMap (dFunIdVars cbs . is_dfun) derInsts+ where+ derInsts+ | checkDer = insts+ | otherwise = filter isDerivedInstance insts+ insts = mgClsInstances mg+ checkDer = checkDerived cfg+ cbs = mgi_binds mg+++mgClsInstances :: MGIModGuts -> [ClsInst]+mgClsInstances = fromMaybe [] . mgi_cls_inst++dFunIdVars :: CoreProgram -> DFunId -> [Id]+dFunIdVars cbs fd = notracepp msg $ concatMap bindersOf cbs' ++ deps+ where+ msg = "DERIVED-VARS-OF: " ++ showpp fd+ cbs' = filter f cbs+ f (NonRec x _) = eqFd x+ f (Rec xes) = any eqFd (fst <$> xes)+ eqFd x = varName x == varName fd+ deps = concatMap unfoldDep unfolds+ unfolds = unfoldingInfo . idInfo <$> concatMap bindersOf cbs'++unfoldDep :: Unfolding -> [Id]+unfoldDep (DFunUnfolding _ _ e) = concatMap exprDep e+unfoldDep CoreUnfolding {uf_tmpl = e} = exprDep e+unfoldDep _ = []++exprDep :: CoreExpr -> [Id]+exprDep = freeVars S.empty++importVars :: CoreProgram -> [Id]+importVars = freeVars S.empty++_definedVars :: CoreProgram -> [Id]+_definedVars = concatMap defs+ where+ defs (NonRec x _) = [x]+ defs (Rec xes) = map fst xes++--------------------------------------------------------------------------------+-- | Per-Module Pipeline -------------------------------------------------------+--------------------------------------------------------------------------------++updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec+updLiftedSpec s1 Nothing = s1+updLiftedSpec s1 (Just s2) = clearSpec s1 `mappend` s2++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 -> ModSummary -> TcGblEnv -> IO [(Name, Maybe TyThing)]+lookupTyThings hscEnv modSum tcGblEnv = forM names (lookupTyThing hscEnv modSum tcGblEnv)+ where+ names :: [Ghc.Name]+ names = liftM2 (++)+ (fmap Ghc.greMangledName . 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 -> ModSummary -> TcGblEnv -> Name -> IO (Name, Maybe TyThing)+lookupTyThing hscEnv modSum tcGblEnv n = do+ mty <- runMaybeT $+ MaybeT (Ghc.hscTcRcLookupName hscEnv n)+ `mplus`+ MaybeT (+ do mi <- moduleInfoTc hscEnv modSum tcGblEnv+ modInfoLookupNameIO hscEnv mi n+ )+ return (n, mty)++availableTyThings :: HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> IO [TyThing]+availableTyThings hscEnv modSum tcGblEnv avails =+ fmap catMaybes $+ mapM (fmap snd . lookupTyThing hscEnv modSum tcGblEnv) $+ availableNames avails++-- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.+availableTyCons :: HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> IO [Ghc.TyCon]+availableTyCons hscEnv modSum tcGblEnv avails =+ fmap (\things -> [tyCon | (ATyCon tyCon) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)++-- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.+availableVars :: HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> IO [Ghc.Var]+availableVars hscEnv modSum tcGblEnv avails =+ fmap (\things -> [var | (AnId var) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)++availableNames :: [AvailInfo] -> [Name]+availableNames =+ concatMap $ \case+ Avail n -> [Ghc.greNameMangledName n]+ AvailTC n ns -> n : map Ghc.greNameMangledName ns++_dumpTypeEnv :: TypecheckedModule -> IO ()+_dumpTypeEnv tm = do+ print ("DUMP-TYPE-ENV" :: String)+ print (showpp <$> tcmTyThings tm)++tcmTyThings :: TypecheckedModule -> Maybe [Name]+tcmTyThings+ =+ -- typeEnvElts+ -- . tcg_type_env . fst+ -- . md_types . snd+ -- . tm_internals_+ modInfoTopLevelScope+ . tm_checked_module_info++modSummaryHsFile :: ModSummary -> FilePath+modSummaryHsFile modSummary =+ fromMaybe+ (panic Nothing $+ "modSummaryHsFile: missing .hs file for " +++ showPpr (ms_mod modSummary))+ (ml_hs_file $ ms_location modSummary)++checkFilePragmas :: [Located String] -> IO ()+checkFilePragmas = Misc.applyNonNull (return ()) throw . mapMaybe err+ where+ err pragma+ | check (val pragma) = Just (ErrFilePragma $ fSrcSpan pragma :: Error)+ | otherwise = Nothing+ check pragma = any (`isPrefixOf` pragma) bad+ bad =+ [ "-i", "--idirs"+ , "-g", "--ghc-option"+ , "--c-files", "--cfiles"+ ]++--------------------------------------------------------------------------------+-- | Family instance information+--------------------------------------------------------------------------------+makeFamInstEnv :: [FamInst] -> ([Ghc.TyCon], [(Symbol, DataCon)])+makeFamInstEnv famInsts =+ let fiTcs = [ tc | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]+ fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]+ in (fiTcs, fiDcs)++--------------------------------------------------------------------------------+-- | Extract Specifications from GHC -------------------------------------------+--------------------------------------------------------------------------------+extractSpecComments :: ParsedModule -> [(Maybe RealSrcLoc, String)]+extractSpecComments = mapMaybe extractSpecComment . apiComments++-- | 'extractSpecComment' pulls out the specification part from a full comment+-- string, i.e. if the string is of the form:+-- 1. '{-@ S @-}' then it returns the substring 'S',+-- 2. '{-@ ... -}' then it throws a malformed SPECIFICATION ERROR, and+-- 3. Otherwise it is just treated as a plain comment so we return Nothing.++extractSpecComment :: Ghc.Located ApiComment -> Maybe (Maybe RealSrcLoc, String)+extractSpecComment (Ghc.L sp (ApiBlockComment txt))+ | isPrefixOf "{-@" txt && isSuffixOf "@-}" txt -- valid specification+ = Just (offsetPos, take (length txt - 6) $ drop 3 txt)+ | isPrefixOf "{-@" txt -- invalid specification+ = uError $ ErrParseAnn sp "A valid specification must have a closing '@-}'."+ where+ offsetPos = offsetRealSrcLoc . realSrcSpanStart <$> srcSpanToRealSrcSpan sp+ offsetRealSrcLoc s =+ mkRealSrcLoc (srcLocFile s) (srcLocLine s) (srcLocCol s + 3)++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 ------------------------------------+--------------------------------------------------------------------------------++makeLogicMap :: IO LogicMap+makeLogicMap = do+ lg <- Misc.getCoreToLogicPath+ lspec <- Misc.sayReadFile lg+ case parseSymbolToLogic lg lspec 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])) ]+ where+ x = "x"+ xs = "xs"+ hNil = mkEApp (dcSym Ghc.nilDataCon ) []+ hCons = mkEApp (dcSym Ghc.consDataCon)+ dcSym = dummyLoc . dropModuleUnique . symbol++++--------------------------------------------------------------------------------+-- | Pretty Printing -----------------------------------------------------------+--------------------------------------------------------------------------------++instance PPrint TargetSpec where+ pprintTidy k spec = vcat+ [ "******* Target Variables ********************"+ , pprintTidy k $ gsTgtVars (gsVars spec)+ , "******* Type Signatures *********************"+ , pprintLongList k (gsTySigs (gsSig spec))+ , "******* Assumed Type Signatures *************"+ , pprintLongList k (gsAsmSigs (gsSig spec))+ , "******* DataCon Specifications (Measure) ****"+ , pprintLongList k (gsCtors (gsData spec))+ , "******* Measure Specifications **************"+ , pprintLongList k (gsMeas (gsData spec)) ]++instance PPrint TargetInfo where+ pprintTidy k info = vcat+ [ -- "*************** Imports *********************"+ -- , intersperse comma $ text <$> imports info+ -- , "*************** Includes ********************"+ -- , intersperse comma $ text <$> includes info+ "*************** Imported Variables **********"+ , pprDoc $ _giImpVars (fromTargetSrc $ giSrc info)+ , "*************** Defined Variables ***********"+ , pprDoc $ _giDefVars (fromTargetSrc $ giSrc info)+ , "*************** Specification ***************"+ , pprintTidy k $ giSpec info+ , "*************** Core Bindings ***************"+ , pprintCBs $ _giCbs (fromTargetSrc $ giSrc info) ]++pprintCBs :: [CoreBind] -> Doc+pprintCBs = pprDoc . tidyCBs+ -- To print verbosely+ -- = text . O.showSDocDebug unsafeGlobalDynFlags . O.ppr . tidyCBs++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 ---------------------------------------------------+------------------------------------------------------------------------++instance Result SourceError where+ result e = Crash ((, Nothing) <$> sourceErrors "" e) "Invalid Source"
+ src/Language/Haskell/Liquid/GHC/Logging.hs view
@@ -0,0 +1,49 @@+{- | This module exposes variations over the standard GHC's logging functions to work with the 'Doc'+ type from the \"pretty\" package. We would like LiquidHaskell to emit diagnostic messages using the very+ same GHC machinery, so that IDE-like programs (e.g. \"ghcid\", \"ghcide\" etc) would be able to+ correctly show errors and warnings to the users, in ther editors.++ Unfortunately, this is not possible to do out of the box because LiquidHaskell uses the 'Doc' type from+ the \"pretty\" package but GHC uses (for historical reasons) its own version. Due to the fact none of+ the constructors are exported, we simply cannot convert between the two types effortlessly, but we have+ to pay the price of a pretty-printing \"roundtrip\".+-}++module Language.Haskell.Liquid.GHC.Logging (+ fromPJDoc+ , putWarnMsg+ , mkLongErrAt+ ) where++import qualified Liquid.GHC.API as GHC+import qualified Text.PrettyPrint.HughesPJ as PJ++-- Unfortunately we need the import below to bring in scope 'PPrint' instances.+import Language.Haskell.Liquid.Types.Errors ()++fromPJDoc :: PJ.Doc -> GHC.SDoc+fromPJDoc = GHC.text . PJ.render++-- | Like the original 'putLogMsg', but internally converts the input 'Doc' (from the \"pretty\" library)+-- into GHC's internal 'SDoc'.+putLogMsg :: GHC.Logger+ -> GHC.DynFlags+ -> GHC.WarnReason+ -> GHC.Severity+ -> GHC.SrcSpan+ -> Maybe GHC.PprStyle+ -> PJ.Doc+ -> IO ()+putLogMsg logger dynFlags reason sev srcSpan _mbStyle =+ GHC.putLogMsg logger dynFlags reason sev srcSpan . GHC.text . PJ.render++defaultErrStyle :: GHC.DynFlags -> GHC.PprStyle+defaultErrStyle _dynFlags = GHC.defaultErrStyle++putWarnMsg :: GHC.Logger -> GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()+putWarnMsg logger dynFlags srcSpan doc =+ putLogMsg logger dynFlags GHC.NoReason GHC.SevWarning srcSpan (Just $ defaultErrStyle dynFlags) doc++-- | Like GHC's 'mkLongErrAt', but it builds the final 'ErrMsg' out of two \"HughesPJ\"'s 'Doc's.+mkLongErrAt :: GHC.SrcSpan -> PJ.Doc -> PJ.Doc -> GHC.TcRn (GHC.MsgEnvelope GHC.DecoratedSDoc)+mkLongErrAt srcSpan msg extra = GHC.mkLongErrAt srcSpan (fromPJDoc msg) (fromPJDoc extra)
+ src/Language/Haskell/Liquid/GHC/Misc.hs view
@@ -0,0 +1,1072 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module contains a wrappers and utility functions for+-- accessing GHC module information. It should NEVER depend on+-- ANY module inside the Language.Haskell.Liquid.* tree.++module Language.Haskell.Liquid.GHC.Misc where++import Data.String+import qualified Data.List as L+import Debug.Trace++import Prelude hiding (error)+import Liquid.GHC.API as Ghc hiding ( L+ , sourceName+ , showPpr+ , showSDocDump+ , panic+ , showSDoc+ )+import qualified Liquid.GHC.API as Ghc (GenLocated (L), showSDoc, panic, showSDocDump)+++import Data.Char (isLower, isSpace, isUpper)+import Data.Maybe (isJust, fromMaybe, fromJust, maybeToList)+import Data.Hashable+import qualified Data.HashSet as S+import qualified Data.Map.Strict as OM+import Control.Monad.State (evalState, get, modify)++import qualified Data.Text.Encoding.Error as TE+import qualified Data.Text.Encoding as T+import qualified Data.Text as T+import Control.Arrow (second)+import Control.Monad ((>=>), foldM)+import qualified Text.PrettyPrint.HughesPJ as PJ+import Language.Fixpoint.Types hiding (L, panic, Loc (..), SrcSpan, Constant, SESearch (..))+import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Misc (safeHead, safeLast, errorstar) -- , safeLast, safeInit)+import Language.Haskell.Liquid.Misc (keyDiff)+import Control.DeepSeq+import Language.Haskell.Liquid.Types.Errors+++isAnonBinder :: Ghc.TyConBinder -> Bool+isAnonBinder (Bndr _ (AnonTCB _)) = True+isAnonBinder (Bndr _ _) = False++mkAlive :: Var -> Id+mkAlive x+ | isId x && isDeadOcc (idOccInfo x)+ = setIdInfo x (setOccInfo (idInfo x) noOccInfo)+ | otherwise+ = x+++--------------------------------------------------------------------------------+-- | Encoding and Decoding Location --------------------------------------------+--------------------------------------------------------------------------------++tickSrcSpan :: CoreTickish -> SrcSpan+tickSrcSpan (ProfNote cc _ _) = cc_loc cc+tickSrcSpan (SourceNote ss _) = RealSrcSpan ss Nothing+tickSrcSpan _ = noSrcSpan++--------------------------------------------------------------------------------+-- | Generic Helpers for Accessing GHC Innards ---------------------------------+--------------------------------------------------------------------------------++-- FIXME: reusing uniques like this is really dangerous+stringTyVar :: String -> TyVar+stringTyVar s = mkTyVar name liftedTypeKind+ where+ name = mkInternalName (mkUnique 'x' 24) occ noSrcSpan+ occ = mkTyVarOcc s++-- FIXME: reusing uniques like this is really dangerous+stringVar :: String -> Type -> Var+stringVar s t = mkLocalVar VanillaId name Many t vanillaIdInfo+ where+ name = mkInternalName (mkUnique 'x' 25) occ noSrcSpan+ occ = mkVarOcc s++-- FIXME: plugging in dummy type like this is really dangerous+maybeAuxVar :: Symbol -> Maybe Var+maybeAuxVar s+ | isMethod sym = Just sv+ | otherwise = Nothing+ where (_, uid) = splitModuleUnique s+ sym = dropModuleNames s+ sv = mkExportedLocalId VanillaId name anyTy+ -- 'x' is chosen for no particular reason..+ name = mkInternalName (mkUnique 'x' uid) occ noSrcSpan+ occ = mkVarOcc (T.unpack (symbolText sym))++stringTyCon :: Char -> Int -> String -> TyCon+stringTyCon = stringTyConWithKind anyTy++-- FIXME: reusing uniques like this is really dangerous+stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon+stringTyConWithKind k c n s = Ghc.mkKindTyCon name [] k [] name+ where+ name = mkInternalName (mkUnique c n) occ noSrcSpan+ occ = mkTcOcc s++hasBaseTypeVar :: Var -> Bool+hasBaseTypeVar = isBaseType . varType++-- same as Constraint isBase+isBaseType :: Type -> Bool+isBaseType (ForAllTy _ _) = False+isBaseType (FunTy { ft_arg = t1, ft_res = t2}) = isBaseType t1 && isBaseType t2+isBaseType (TyVarTy _) = True+isBaseType (TyConApp _ ts) = all isBaseType ts+isBaseType (AppTy t1 t2) = isBaseType t1 && isBaseType t2+isBaseType _ = False++isTmpVar :: Var -> Bool+isTmpVar = isTmpSymbol . dropModuleNamesAndUnique . symbol++isTmpSymbol :: Symbol -> Bool+isTmpSymbol x = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]++validTyVar :: String -> Bool+validTyVar s@(c:_) = isLower c && not (any isSpace s)+validTyVar _ = False++tvId :: TyVar -> String+tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)++tidyCBs :: [CoreBind] -> [CoreBind]+tidyCBs = map unTick++unTick :: CoreBind -> CoreBind+unTick (NonRec b e) = NonRec b (unTickExpr e)+unTick (Rec bs) = Rec $ map (second unTickExpr) bs++unTickExpr :: CoreExpr -> CoreExpr+unTickExpr (App e a) = App (unTickExpr e) (unTickExpr a)+unTickExpr (Lam b e) = Lam b (unTickExpr e)+unTickExpr (Let b e) = Let (unTick b) (unTickExpr e)+unTickExpr (Case e b t as) = Case (unTickExpr e) b t (map unTickAlt as)+ where unTickAlt (Alt a b' e') = Alt a b' (unTickExpr e')+unTickExpr (Cast e c) = Cast (unTickExpr e) c+unTickExpr (Tick _ e) = unTickExpr e+unTickExpr x = x++isFractionalClass :: Class -> Bool+isFractionalClass clas = classKey clas `elem` fractionalClassKeys++isOrdClass :: Class -> Bool+isOrdClass clas = classKey clas == ordClassKey++--------------------------------------------------------------------------------+-- | Pretty Printers -----------------------------------------------------------+--------------------------------------------------------------------------------+notracePpr :: Outputable a => String -> a -> a+notracePpr _ x = x++tracePpr :: Outputable a => String -> a -> a+tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x++pprShow :: Show a => a -> Ghc.SDoc+pprShow = text . show+++toFixSDoc :: Fixpoint a => a -> PJ.Doc+toFixSDoc = PJ.text . PJ.render . toFix++sDocDoc :: Ghc.SDoc -> PJ.Doc+sDocDoc = PJ.text . showSDoc++pprDoc :: Outputable a => a -> PJ.Doc+pprDoc = sDocDoc . ppr++-- Overriding Outputable functions because they now require DynFlags!+showPpr :: Outputable a => a -> String+showPpr = Ghc.showPprQualified++-- FIXME: somewhere we depend on this printing out all GHC entities with+-- fully-qualified names...+showSDoc :: Ghc.SDoc -> String+showSDoc = Ghc.showSDocQualified++myQualify :: Ghc.PrintUnqualified+myQualify = Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }+-- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }++showSDocDump :: Ghc.SDoc -> String+showSDocDump = Ghc.showSDocDump Ghc.defaultSDocContext++instance Outputable a => Outputable (S.HashSet a) where+ ppr = ppr . S.toList++typeUniqueString :: Outputable a => a -> String+typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr+++--------------------------------------------------------------------------------+-- | Manipulating Source Spans -------------------------------------------------+--------------------------------------------------------------------------------++newtype Loc = L (Int, Int) deriving (Eq, Ord, Show)++instance Hashable Loc where+ hashWithSalt i (L z) = hashWithSalt i z++--instance (Uniquable a) => Hashable a where++instance Hashable SrcSpan where+ hashWithSalt i (UnhelpfulSpan reason) = case reason of+ UnhelpfulNoLocationInfo -> hashWithSalt i (uniq $ fsLit "UnhelpfulNoLocationInfo")+ UnhelpfulWiredIn -> hashWithSalt i (uniq $ fsLit "UnhelpfulWiredIn")+ UnhelpfulInteractive -> hashWithSalt i (uniq $ fsLit "UnhelpfulInteractive")+ UnhelpfulGenerated -> hashWithSalt i (uniq $ fsLit "UnhelpfulGenerated")+ UnhelpfulOther fs -> hashWithSalt i (uniq fs)+ hashWithSalt i (RealSrcSpan s _) = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)++fSrcSpan :: (F.Loc a) => a -> SrcSpan+fSrcSpan = fSrcSpanSrcSpan . F.srcSpan++fSourcePos :: (F.Loc a) => a -> F.SourcePos+fSourcePos = F.sp_start . F.srcSpan++fSrcSpanSrcSpan :: F.SrcSpan -> SrcSpan+fSrcSpanSrcSpan (F.SS p p') = sourcePos2SrcSpan p p'++srcSpanFSrcSpan :: SrcSpan -> F.SrcSpan+srcSpanFSrcSpan sp = F.SS p p'+ where+ p = srcSpanSourcePos sp+ p' = srcSpanSourcePosE sp++sourcePos2SrcSpan :: SourcePos -> SourcePos -> SrcSpan+sourcePos2SrcSpan p p' = RealSrcSpan (packRealSrcSpan f (unPos l) (unPos c) (unPos l') (unPos c')) Nothing+ where+ (f, l, c) = F.sourcePosElts p+ (_, l', c') = F.sourcePosElts p'++sourcePosSrcSpan :: SourcePos -> SrcSpan+sourcePosSrcSpan p@(SourcePos file line col) = sourcePos2SrcSpan p (SourcePos file line (succPos col))++sourcePosSrcLoc :: SourcePos -> SrcLoc+sourcePosSrcLoc (SourcePos file line col) = mkSrcLoc (fsLit file) (unPos line) (unPos col)++srcSpanSourcePos :: SrcSpan -> SourcePos+srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "<no source information>"+srcSpanSourcePos (RealSrcSpan s _) = realSrcSpanSourcePos s++srcSpanSourcePosE :: SrcSpan -> SourcePos+srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "<no source information>"+srcSpanSourcePosE (RealSrcSpan s _) = realSrcSpanSourcePosE s++srcSpanFilename :: SrcSpan -> String+srcSpanFilename = maybe "" unpackFS . srcSpanFileName_maybe++srcSpanStartLoc :: RealSrcSpan -> Loc+srcSpanStartLoc l = L (srcSpanStartLine l, srcSpanStartCol l)++srcSpanEndLoc :: RealSrcSpan -> Loc+srcSpanEndLoc l = L (srcSpanEndLine l, srcSpanEndCol l)+++oneLine :: RealSrcSpan -> Bool+oneLine l = srcSpanStartLine l == srcSpanEndLine l++lineCol :: RealSrcSpan -> (Int, Int)+lineCol l = (srcSpanStartLine l, srcSpanStartCol l)++realSrcSpanSourcePos :: RealSrcSpan -> SourcePos+realSrcSpanSourcePos s = safeSourcePos file line col+ where+ file = unpackFS $ srcSpanFile s+ line = srcSpanStartLine s+ col = srcSpanStartCol s++realSrcLocSourcePos :: RealSrcLoc -> SourcePos+realSrcLocSourcePos s = safeSourcePos file line col+ where+ file = unpackFS $ srcLocFile s+ line = srcLocLine s+ col = srcLocCol s++realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos+realSrcSpanSourcePosE s = safeSourcePos file line col+ where+ file = unpackFS $ srcSpanFile s+ line = srcSpanEndLine s+ col = srcSpanEndCol s++getSourcePos :: NamedThing a => a -> SourcePos+getSourcePos = srcSpanSourcePos . getSrcSpan++getSourcePosE :: NamedThing a => a -> SourcePos+getSourcePosE = srcSpanSourcePosE . getSrcSpan++locNamedThing :: NamedThing a => a -> F.Located a+locNamedThing x = F.Loc l lE x+ where+ l = getSourcePos x+ lE = getSourcePosE x++instance F.Loc Var 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++varLocInfo :: (Type -> a) -> Var -> F.Located a+varLocInfo f x = f . varType <$> locNamedThing x++namedPanic :: (NamedThing a) => a -> String -> b+namedPanic x msg = panic (Just (getSrcSpan x)) msg++--------------------------------------------------------------------------------+-- | Manipulating CoreExpr -----------------------------------------------------+--------------------------------------------------------------------------------++collectArguments :: Int -> CoreExpr -> [Var]+collectArguments n e = if length xs > n then take n xs else xs+ where+ (vs', e') = collectValBinders' $ snd $ collectTyBinders e+ vs = fst $ collectBinders $ ignoreLetBinds e'+ xs = vs' ++ vs++{-+collectTyBinders :: CoreExpr -> ([Var], CoreExpr)+collectTyBinders expr+ = go [] expr+ where+ go tvs (Lam b e) | isTyVar b = go (b:tvs) e+ go tvs e = (reverse tvs, e)+-}++collectValBinders' :: Ghc.Expr Var -> ([Var], Ghc.Expr Var)+collectValBinders' = go []+ where+ go tvs (Lam b e) | isTyVar b = go tvs e+ go tvs (Lam b e) | isId b = go (b:tvs) e+ go tvs (Tick _ e) = go tvs e+ go tvs e = (reverse tvs, e)++ignoreLetBinds :: Ghc.Expr t -> Ghc.Expr t+ignoreLetBinds (Let (NonRec _ _) e')+ = ignoreLetBinds e'+ignoreLetBinds e+ = e++--------------------------------------------------------------------------------+-- | Predicates on CoreExpr and DataCons ---------------------------------------+--------------------------------------------------------------------------------++isExternalId :: Id -> Bool+isExternalId = isExternalName . getName++isTupleId :: Id -> Bool+isTupleId = maybe False Ghc.isTupleDataCon . idDataConM++idDataConM :: Id -> Maybe DataCon+idDataConM x = case idDetails x of+ DataConWorkId d -> Just d+ DataConWrapId d -> Just d+ _ -> Nothing++isDataConId :: Id -> Bool+isDataConId = isJust . idDataConM++getDataConVarUnique :: Var -> Unique+getDataConVarUnique v+ | isId v && isDataConId v = getUnique (idDataCon v)+ | otherwise = getUnique v++isDictionaryExpression :: Ghc.Expr Id -> Maybe Id+isDictionaryExpression (Tick _ e) = isDictionaryExpression e+isDictionaryExpression (Var x) | isDictionary x = Just x+isDictionaryExpression _ = Nothing++realTcArity :: TyCon -> Arity+realTcArity = tyConArity++{-+ tracePpr ("realTcArity of " ++ showPpr c+ ++ "\n tyConKind = " ++ showPpr (tyConKind c)+ ++ "\n kindArity = " ++ show (kindArity (tyConKind c))+ ++ "\n kindArity' = " ++ show (kindArity' (tyConKind c)) -- this works for TypeAlias+ ) $ kindArity' (tyConKind c)+-}++kindTCArity :: TyCon -> Arity+kindTCArity = go . tyConKind+ where+ go (FunTy { ft_res = res}) = 1 + go res+ go _ = 0+++kindArity :: Kind -> Arity+kindArity (ForAllTy _ res)+ = 1 + kindArity res+kindArity _+ = 0++uniqueHash :: Uniquable a => Int -> a -> Int+uniqueHash i = hashWithSalt i . getKey . getUnique++-- slightly modified version of DynamicLoading.lookupRdrNameInModule+lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)+lookupRdrName hsc_env mod_name rdr_name = do+ -- First find the package the module resides in by searching exposed packages and home modules+ found_module <- findImportedModule hsc_env mod_name Nothing+ case found_module of+ Found _ mod' -> do+ -- Find the exports of the module+ (_, mb_iface) <- getModuleInterface hsc_env mod'+ case mb_iface of+ Just iface -> do+ -- Try and find the required name in the exports+ let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name+ , is_qual = False, is_dloc = noSrcSpan }+ provenance = Just $ ImpSpec decl_spec ImpAll+ env = case mi_globals iface of+ Nothing -> mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))+ Just e -> e+ case lookupGRE_RdrName rdr_name env of+-- XXX [gre] -> return (Just (gre_name gre))+ [] -> return Nothing+ _ -> Ghc.panic "lookupRdrNameInModule"+ Nothing -> throwCmdLineErrorS dflags $ Ghc.hsep [Ghc.ptext (sLit "Could not determine the exports of the module"), ppr mod_name]+ err' -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err'+ where dflags = hsc_dflags hsc_env+ throwCmdLineErrorS dflags' = throwCmdLineError . Ghc.showSDoc dflags'+ throwCmdLineError = throwGhcException . CmdLineError++-- qualImportDecl :: ModuleName -> ImportDecl name+-- qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }++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 --------------------------------------------------------+--------------------------------------------------------------------------------++symbolTyConWithKind :: Kind -> Char -> Int -> Symbol -> TyCon+symbolTyConWithKind k x i n = stringTyConWithKind k x i (symbolString n)++symbolTyCon :: Char -> Int -> Symbol -> TyCon+symbolTyCon x i n = stringTyCon x i (symbolString n)++symbolTyVar :: Symbol -> TyVar+symbolTyVar = stringTyVar . symbolString++localVarSymbol :: Var -> Symbol+localVarSymbol v+ | us `isSuffixOfSym` vs = vs+ | otherwise = suffixSymbol vs us+ where+ us = symbol $ showPpr $ getDataConVarUnique v+ vs = exportedVarSymbol v++exportedVarSymbol :: Var -> Symbol+exportedVarSymbol x = notracepp msg . symbol . getName $ x+ where+ msg = "exportedVarSymbol: " ++ showPpr x++qualifiedNameSymbol :: Name -> Symbol+qualifiedNameSymbol = symbol . Ghc.qualifiedNameFS++instance Symbolic FastString where+ symbol = symbol . fastStringText++fastStringText :: FastString -> T.Text+fastStringText = T.decodeUtf8With TE.lenientDecode . bytesFS++tyConTyVarsDef :: TyCon -> [TyVar]+tyConTyVarsDef c+ | noTyVars c = []+ | otherwise = Ghc.tyConTyVars c+ --where+ -- none = tracepp ("tyConTyVarsDef: " ++ show c) (noTyVars c)++noTyVars :: TyCon -> Bool+noTyVars c = Ghc.isPrimTyCon c || isFunTyCon c || Ghc.isPromotedDataCon c++--------------------------------------------------------------------------------+-- | Symbol Instances+--------------------------------------------------------------------------------++instance Symbolic TyCon where+ symbol = symbol . getName++instance Symbolic Class where+ symbol = symbol . getName++instance Symbolic Name where+ symbol = symbol . qualifiedNameSymbol++-- | [NOTE:REFLECT-IMPORTS] we **eschew** the `unique` suffix for exported vars,+-- to make it possible to lookup names from symbols _across_ modules;+-- anyways exported names are top-level and you shouldn't have local binders+-- that shadow them. However, we **keep** the `unique` suffix for local variables,+-- as otherwise there are spurious, but extremely problematic, name collisions+-- in the fixpoint environment.++instance Symbolic Var where -- TODO:reflect-datacons varSymbol+ symbol v+ | isExternalId v = exportedVarSymbol v+ | otherwise = localVarSymbol v+++instance Hashable Var where+ hashWithSalt = uniqueHash++instance Hashable TyCon where+ hashWithSalt = uniqueHash++instance Hashable Class where+ hashWithSalt = uniqueHash++instance Hashable DataCon where+ hashWithSalt = uniqueHash++instance Fixpoint Var where+ toFix = pprDoc++instance Fixpoint Name where+ toFix = pprDoc++instance Fixpoint Type where+ toFix = pprDoc++instance Show Name where+ show = symbolString . symbol++instance Show Var where+ show = show . getName++instance Show Class where+ show = show . getName++instance Show TyCon where+ show = show . getName++instance NFData Class where+ rnf t = seq t ()++instance NFData TyCon where+ rnf t = seq t ()++instance NFData Type where+ rnf t = seq t ()++instance NFData Var where+ rnf t = seq t ()++--------------------------------------------------------------------------------+-- | Manipulating Symbols ------------------------------------------------------+--------------------------------------------------------------------------------++takeModuleUnique :: Symbol -> Symbol+takeModuleUnique = mungeNames tailName sepUnique "takeModuleUnique: "+ where+ tailName msg = symbol . safeLast msg++splitModuleUnique :: Symbol -> (Symbol, Int)+splitModuleUnique x = (dropModuleNamesAndUnique x, base62ToI (takeModuleUnique x))++base62ToI :: Symbol -> Int+base62ToI s = fromMaybe (errorstar "base62ToI Out Of Range") $ go (F.symbolText s)+ where+ digitToI :: OM.Map Char Int+ digitToI = OM.fromList $ zip (['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']) [0..]+ f acc (flip OM.lookup digitToI -> x) = (acc * 62 +) <$> x+ go = foldM f 0 . T.unpack+++splitModuleName :: Symbol -> (Symbol, Symbol)+splitModuleName x = (takeModuleNames x, dropModuleNamesAndUnique x)++dropModuleNamesAndUnique :: Symbol -> Symbol+dropModuleNamesAndUnique = dropModuleUnique . dropModuleNames++dropModuleNames :: Symbol -> Symbol+dropModuleNames = dropModuleNamesCorrect+{- +dropModuleNames = mungeNames lastName sepModNames "dropModuleNames: "+ where+ lastName msg = symbol . safeLast msg+-}++dropModuleNamesCorrect :: Symbol -> Symbol+dropModuleNamesCorrect = F.symbol . go . F.symbolText+ where+ go s = case T.uncons s of+ Just (c,tl) -> if isUpper c && T.any (== '.') tl+ then go $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s+ else s+ Nothing -> s++takeModuleNames :: Symbol -> Symbol+takeModuleNames = F.symbol . go [] . F.symbolText+ where+ go acc s = case T.uncons s of+ Just (c,tl) -> if isUpper c && T.any (== '.') tl+ then go (getModule' s:acc) $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s+ else T.intercalate "." (reverse acc)+ Nothing -> T.intercalate "." (reverse acc)+ getModule' = T.takeWhile (/= '.')++{- +takeModuleNamesOld = mungeNames initName sepModNames "takeModuleNames: "+ where+ initName msg = symbol . T.intercalate "." . safeInit msg+-}+dropModuleUnique :: Symbol -> Symbol+dropModuleUnique = mungeNames headName sepUnique "dropModuleUnique: "+ where+ headName msg = symbol . safeHead msg++cmpSymbol :: Symbol -> Symbol -> Bool+cmpSymbol coreSym logicSym+ = (dropModuleUnique coreSym == dropModuleNamesAndUnique logicSym)+ || (dropModuleUnique coreSym == dropModuleUnique logicSym)++sepModNames :: T.Text+sepModNames = "."++sepUnique :: T.Text+sepUnique = "#"++mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol+mungeNames _ _ _ "" = ""+mungeNames f d msg s'@(symbolText -> s)+ | s' == tupConName = tupConName+ | otherwise = f (msg ++ T.unpack s) $ T.splitOn d $ stripParens s++qualifySymbol :: Symbol -> Symbol -> Symbol+qualifySymbol (symbolText -> m) x'@(symbolText -> x)+ | isQualified x = x'+ | isParened x = symbol (wrapParens (m `mappend` "." `mappend` stripParens x))+ | otherwise = symbol (m `mappend` "." `mappend` x)++isQualifiedSym :: Symbol -> Bool+isQualifiedSym (symbolText -> x) = isQualified x++isQualified :: T.Text -> Bool+isQualified y = "." `T.isInfixOf` y++wrapParens :: (IsString a, Monoid a) => a -> a+wrapParens x = "(" `mappend` x `mappend` ")"++isParened :: T.Text -> Bool+isParened xs = xs /= stripParens xs++isDictionary :: Symbolic a => a -> Bool+isDictionary = isPrefixOfSym "$f" . dropModuleNames . symbol++isMethod :: Symbolic a => a -> Bool+isMethod = isPrefixOfSym "$c" . dropModuleNames . symbol++isInternal :: Symbolic a => a -> Bool+isInternal = isPrefixOfSym "$" . dropModuleNames . symbol++isWorker :: Symbolic a => a -> Bool+isWorker s = notracepp ("isWorkerSym: s = " ++ ss) $ "$W" `L.isInfixOf` ss+ where+ ss = symbolString (symbol s)++isSCSel :: Symbolic a => a -> Bool+isSCSel = isPrefixOfSym "$p" . dropModuleNames . symbol++stripParens :: T.Text -> T.Text+stripParens t = fromMaybe t (strip t)+ where+ strip = T.stripPrefix "(" >=> T.stripSuffix ")"++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 ---------------------------------------------------+--------------------------------------------------------------------------------++gHC_VERSION :: String+gHC_VERSION = show (__GLASGOW_HASKELL__ :: Int)++symbolFastString :: Symbol -> FastString+symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText++synTyConRhs_maybe :: TyCon -> Maybe Type+synTyConRhs_maybe = Ghc.synTyConRhs_maybe++tcRnLookupRdrName :: HscEnv -> Ghc.LocatedN RdrName -> IO (Messages DecoratedSDoc, Maybe [Name])+tcRnLookupRdrName = Ghc.tcRnLookupRdrName++showCBs :: Bool -> [CoreBind] -> String+showCBs untidy+ | untidy =+ Ghc.renderWithContext ctx . ppr . tidyCBs+ | otherwise = showPpr+ where+ ctx = Ghc.defaultSDocContext { sdocPprDebug = True }++ignoreCoreBinds :: S.HashSet Var -> [CoreBind] -> [CoreBind]+ignoreCoreBinds vs cbs+ | S.null vs = cbs+ | otherwise = concatMap go cbs+ where+ go :: CoreBind -> [CoreBind]+ go b@(NonRec x _)+ | S.member x vs = []+ | otherwise = [b]+ 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+ (NonRec v def : _ ) -> Just (v, def)+ (Rec [(v, def)] : _ ) -> Just (v, def)+ _ -> Nothing+ where+ rcbs | isMethod sym = mCbs+ | isDictionary (dropModuleNames sym) = dCbs+ | otherwise = xCbs+ xCbs = [ cb | cb <- concatMap unRec cbs, sym `elem` coreBindSymbols cb+ ]+ mCbs = [ cb | cb <- concatMap unRec cbs, sym `elem` methodSymbols cb]+ dCbs = [ cb | cb <- concatMap unRec cbs, sym `elem` dictionarySymbols cb]+ unRec (Rec xes) = [NonRec x es | (x,es) <- xes]+ unRec nonRec = [nonRec]++dictionarySymbols :: CoreBind -> [Symbol]+dictionarySymbols = filter isDictionary . map (dropModuleNames . symbol) . binders+++methodSymbols :: CoreBind -> [Symbol]+methodSymbols = filter isMethod . map (dropModuleNames . symbol) . binders++++coreBindSymbols :: CoreBind -> [Symbol]+coreBindSymbols = map (dropModuleNames . simplesymbol) . binders++simplesymbol :: (NamedThing t) => t -> Symbol+simplesymbol = symbol . getName++binders :: Bind a -> [a]+binders (NonRec z _) = [z]+binders (Rec xes) = fst <$> xes++expandVarType :: Var -> Type+expandVarType = expandTypeSynonyms . varType++--------------------------------------------------------------------------------+-- | The following functions test if a `CoreExpr` or `CoreVar` can be+-- embedded in logic. With type-class support, we can no longer erase+-- such expressions arbitrarily.+--------------------------------------------------------------------------------+isEmbeddedDictExpr :: CoreExpr -> Bool+isEmbeddedDictExpr = isEmbeddedDictType . exprType++isEmbeddedDictVar :: Var -> Bool+isEmbeddedDictVar v = F.notracepp msg . isEmbeddedDictType . varType $ v+ where+ msg = "isGoodCaseBind v = " ++ show v++isEmbeddedDictType :: Type -> Bool+isEmbeddedDictType = anyF [isOrdPred, isNumericPred, isEqPred, isPrelEqPred]++-- unlike isNumCls, isFracCls, these two don't check if the argument's+-- superclass is Ord or Num. I believe this is the more predictable behavior++isPrelEqPred :: Type -> Bool+isPrelEqPred ty = case tyConAppTyCon_maybe ty of+ Just tyCon -> isPrelEqTyCon tyCon+ _ -> False+++isPrelEqTyCon :: TyCon -> Bool+isPrelEqTyCon tc = tc `hasKey` eqClassKey++isOrdPred :: Type -> Bool+isOrdPred ty = case tyConAppTyCon_maybe ty of+ Just tyCon -> tyCon `hasKey` ordClassKey+ _ -> False++-- Not just Num, but Fractional, Integral as well+isNumericPred :: Type -> Bool+isNumericPred ty = case tyConAppTyCon_maybe ty of+ Just tyCon -> getUnique tyCon `elem` numericClassKeys+ _ -> False++++--------------------------------------------------------------------------------+-- | The following functions test if a `CoreExpr` or `CoreVar` are just types+-- in disguise, e.g. have `PredType` (in the GHC sense of the word), and so+-- shouldn't appear in refinements.+--------------------------------------------------------------------------------+isPredExpr :: CoreExpr -> Bool+isPredExpr = isPredType . Ghc.exprType++isPredVar :: Var -> Bool+isPredVar v = F.notracepp msg . isPredType . varType $ v+ where+ msg = "isGoodCaseBind v = " ++ show v++isPredType :: Type -> Bool+isPredType = anyF [ isClassPred, isEqPred, isEqPrimPred ]++anyF :: [a -> Bool] -> a -> Bool+anyF ps x = or [ p x | p <- ps ]+++-- | 'defaultDataCons t ds' returns the list of '(dc, types)' pairs,+-- corresponding to the _missing_ cases, i.e. _other_ than those in 'ds',+-- that are being handled by DEFAULT.+defaultDataCons :: Type -> [AltCon] -> Maybe [(DataCon, [TyVar], [Type])]+defaultDataCons (TyConApp tc argτs) ds = do+ allDs <- Ghc.tyConDataCons_maybe tc+ let seenDs = [d | DataAlt d <- ds ]+ let defDs = keyDiff showPpr allDs seenDs+ return [ (d, Ghc.dataConExTyCoVars d, map irrelevantMult $ Ghc.dataConInstArgTys d argτs) | d <- defDs ]++defaultDataCons _ _ =+ Nothing++++isEvVar :: Id -> Bool+isEvVar x = isPredVar x || isTyVar x || isCoVar x+++--------------------------------------------------------------------------------+-- | Elaboration+--------------------------------------------------------------------------------++-- FIXME: the handling of exceptions seems to be broken++-- partially stolen from GHC'sa exprType++-- elaborateHsExprInst+-- :: GhcMonad m => LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)+-- elaborateHsExprInst expr = elaborateHsExpr TM_Inst expr+++-- elaborateHsExpr+-- :: GhcMonad m => TcRnExprMode -> LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)+-- elaborateHsExpr mode expr =+-- withSession $ \hsc_env -> liftIO $ hscElabHsExpr hsc_env mode expr++-- hscElabHsExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe CoreExpr)+-- hscElabHsExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do+-- hsc_env <- Ghc.getHscEnv+-- liftIO $ elabRnExpr hsc_env mode expr++elabRnExpr :: LHsExpr GhcPs -> TcRn CoreExpr+elabRnExpr rdr_expr = do+ (rn_expr, _fvs) <- rnLExpr rdr_expr+ failIfErrsM++ -- Typecheck the expression+ ((tclvl, (tc_expr, res_ty)), lie)+ <- captureTopConstraints $+ pushTcLevelM $+ tcInferRho rn_expr++ -- Generalise+ uniq <- newUnique+ let { fresh_it = itName uniq (getLocA rdr_expr) }+ ((_qtvs, _dicts, evbs, _), residual)+ <- captureConstraints $+ simplifyInfer tclvl NoRestrictions+ [] {- No sig vars -}+ [(fresh_it, res_ty)]+ lie++ -- Ignore the dictionary bindings+ evbs' <- simplifyInteractive residual+ full_expr <- zonkTopLExpr (mkHsDictLet (EvBinds evbs') (mkHsDictLet evbs tc_expr))+ initDsTc $ dsLExpr full_expr++newtype HashableType = HashableType {getHType :: Type}++instance Eq HashableType where+ x == y = eqType (getHType x) (getHType y)++instance Ord HashableType where+ compare x y = nonDetCmpType (getHType x) (getHType y)++instance Outputable HashableType where+ ppr = ppr . getHType+++--------------------------------------------------------------------------------+-- | Superclass coherence+--------------------------------------------------------------------------------++canonSelectorChains :: PredType -> OM.Map HashableType [Id]+canonSelectorChains t = foldr (OM.unionWith const) mempty (zs : xs)+ where+ (cls, ts) = Ghc.getClassPredTys t+ scIdTys = classSCSelIds cls+ ys = fmap (\d -> (d, piResultTys (idType d) (ts ++ [t]))) scIdTys+ zs = OM.fromList $ fmap (\(x, y) -> (HashableType y, [x])) ys+ xs = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys++buildCoherenceOblig :: Class -> [[([Id], [Id])]]+buildCoherenceOblig cls = evalState (mapM f xs) OM.empty+ where+ (ts, _, selIds, _) = classBigSig cls+ tts = mkTyVarTy <$> ts+ t = mkClassPred cls tts+ ys = fmap (\d -> (d, piResultTys (idType d) (tts ++ [t]))) selIds+ xs = fmap (\(d, t') -> fmap (d:) (canonSelectorChains t')) ys+ f tid = do+ ctid' <- get+ modify (flip (OM.unionWith const) tid)+ pure . OM.elems $ OM.intersectionWith (,) ctid' (fmap tail tid)+++-- to be zipped onto the super class selectors+coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft+coherenceObligToRef d = coherenceObligToRefE (F.eVar $ F.symbol d)++coherenceObligToRefE :: F.Expr -> [Id] -> [Id] -> F.Reft+coherenceObligToRefE e rps0 rps1 = F.Reft (F.vv_, F.PAtom F.Eq lhs rhs)+ where lhs = L.foldr EApp e ps0+ rhs = L.foldr EApp (F.eVar F.vv_) ps1+ ps0 = F.eVar . F.symbol <$> L.reverse rps0+ ps1 = F.eVar . F.symbol <$> L.reverse rps1++data TcWiredIn = TcWiredIn {+ tcWiredInName :: Name+ , tcWiredInFixity :: Maybe (Int, FixityDirection)+ , tcWiredInType :: LHsType GhcRn+ }++-- | Run a computation in GHC's typechecking monad with wired in values locally bound in the typechecking environment.+withWiredIn :: TcM a -> TcM a+withWiredIn m = discardConstraints $ do+ -- undef <- lookupUndef+ wiredIns <- mkWiredIns+ -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m+ snd <$> tcValBinds Ghc.NotTopLevel [] (sigs wiredIns) m++ where+ -- lookupUndef = do+ -- lookupOrig gHC_ERR (Ghc.mkVarOcc "undefined")+ -- -- tcLookupGlobal undefName++ -- binds :: Name -> [TcWiredIn] -> [(Ghc.RecFlag, LHsBinds GhcRn)]+ -- binds undef wiredIns = map (\w -> + -- let ext = Ghc.unitNameSet undef in -- $ varName $ tyThingId undef in+ -- let co_fn = idHsWrapper in+ -- let matches = + -- let ctxt = LambdaExpr in+ -- let grhss = GRHSs Ghc.noExtField [Ghc.L locSpan (GRHS Ghc.noExtField [] (Ghc.L locSpan (HsVar Ghc.noExtField (Ghc.L locSpan undef))))] (Ghc.L locSpan emptyLocalBinds) in+ -- MG Ghc.noExtField (Ghc.L locSpan [Ghc.L locSpan (Match Ghc.noExtField ctxt [] grhss)]) Ghc.Generated + -- in+ -- let b = FunBind ext (Ghc.L locSpan $ tcWiredInName w) matches co_fn [] in+ -- (Ghc.NonRecursive, unitBag (Ghc.L locSpan b))+ -- ) wiredIns++ sigs wiredIns = concatMap (\w ->+ let inf = maybeToList $ (\(fPrec, fDir) -> Ghc.L locSpanAnn $ Ghc.FixSig Ghc.noAnn $ Ghc.FixitySig Ghc.noExtField [Ghc.L locSpanAnn (tcWiredInName w)] $ Ghc.Fixity Ghc.NoSourceText fPrec fDir) <$> tcWiredInFixity w in+ let t =+ let ext' = [] in+ [Ghc.L locSpanAnn $ TypeSig Ghc.noAnn [Ghc.L locSpanAnn (tcWiredInName w)] $ HsWC ext' $ Ghc.L locSpanAnn $ HsSig Ghc.noExtField (HsOuterImplicit ext') $ tcWiredInType w]+ in+ inf <> t+ ) wiredIns++ locSpan = UnhelpfulSpan (UnhelpfulOther "Liquid.GHC.Misc: WiredIn")+ locSpanAnn = noAnnSrcSpan locSpan++ mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn+ mkHsFunTy a b = nlHsFunTy a b++ mkWiredIns = sequence [impl, dimpl, eq, len]++ toName s = do+ u <- getUniqueM+ return $ Ghc.mkInternalName u (Ghc.mkVarOcc s) locSpan++ toLoc = Ghc.L locSpanAnn+ nameToTy = Ghc.L locSpanAnn . HsTyVar Ghc.noAnn Ghc.NotPromoted++ boolTy' :: LHsType GhcRn+ boolTy' = nameToTy $ toLoc boolTyConName+ -- boolName <- lookupOrig (Module (stringToUnitId "Data.Bool") (mkModuleName "Data.Bool")) (Ghc.mkVarOcc "Bool")+ -- return $ Ghc.L locSpan $ HsTyVar Ghc.noExtField Ghc.NotPromoted $ Ghc.L locSpan boolName+ intTy' = nameToTy $ toLoc intTyConName+ listTy lt = toLoc $ HsAppTy Ghc.noExtField (nameToTy $ toLoc listTyConName) lt++ -- infixr 1 ==> :: Bool -> Bool -> Bool+ impl = do+ n <- toName "==>"+ let ty = mkHsFunTy boolTy' (mkHsFunTy boolTy' boolTy')+ return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty++ -- infixr 1 <=> :: Bool -> Bool -> Bool+ dimpl = do+ n <- toName "<=>"+ let ty = mkHsFunTy boolTy' (mkHsFunTy boolTy' boolTy')+ return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty++ -- infix 4 == :: forall a . a -> a -> Bool+ eq = do+ n <- toName "=="+ aName <- toLoc <$> toName "a"+ let aTy = nameToTy aName+ let ty = toLoc $ HsForAllTy Ghc.noExtField+ (mkHsForAllInvisTele Ghc.noAnn [toLoc $ UserTyVar Ghc.noAnn SpecifiedSpec aName]) $ mkHsFunTy aTy (mkHsFunTy aTy boolTy')+ return $ TcWiredIn n (Just (4, Ghc.InfixN)) ty++ -- TODO: This is defined as a measure in liquidhaskell GHC.Base_LHAssumptions. We probably want to insert all measures to the environment.+ -- len :: forall a. [a] -> Int+ len = do+ n <- toName "len"+ aName <- toLoc <$> toName "a"+ let aTy = nameToTy aName+ let ty = toLoc $ HsForAllTy Ghc.noExtField+ (mkHsForAllInvisTele Ghc.noAnn [toLoc $ UserTyVar Ghc.noAnn SpecifiedSpec aName]) $ mkHsFunTy (listTy aTy) intTy'+ return $ TcWiredIn n Nothing ty++prependGHCRealQual :: FastString -> RdrName+prependGHCRealQual = varQual_RDR gHC_REAL++isFromGHCReal :: NamedThing a => a -> Bool+isFromGHCReal x = Ghc.nameModule (Ghc.getName x) == gHC_REAL
+ src/Language/Haskell/Liquid/GHC/Play.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.++module Language.Haskell.Liquid.GHC.Play where++import Prelude hiding (error)++import Control.Arrow ((***))+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import qualified Data.Maybe as Mb++import Liquid.GHC.API as Ghc hiding (panic, showPpr)+import Language.Haskell.Liquid.GHC.Misc ()+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.Variance++-------------------------------------------------------------------------------+-- | Positivity Checker -------------------------------------------------------+-------------------------------------------------------------------------------++-- If the type constructor T is in the input list and its data constructors Di, Dj+-- use T in non strictly positive positions, +-- then (T,(Di, Dj)) will appear in the result list. ++getNonPositivesTyCon :: [TyCon] -> [(TyCon, [DataCon])]+getNonPositivesTyCon tcs = Mb.mapMaybe go (M.toList $ makeOccurrences tcs)+ where+ go (tc,dcocs) = case filter (\(_,occ) -> elem tc (negOcc occ)) dcocs of+ [] -> Nothing+ xs -> Just (tc, fst <$> xs)+++-- OccurrenceMap maps type constructors to their TyConOccurrence. +-- for each of their data constructor. For example, for the below data definition+-- data T a = P (T a) | N (T a -> Int) | Both (T a -> T a) | None +-- the entry below should get generated+-- OccurrenceMap +-- = T |-> [(P, [+-- (P, TyConOcc [T] [])+-- (N, TyConOcc [Int] [T])+-- (Both, TyConOcc [T] [T])+-- (None, TyConOcc [] [])+-- ])] +-- For positivity check, ultimately we only care about self occurences, +-- but we keep track of all the TyCons for the mutually inductive data types. +-- We separate the occurences per data constructor only to provide better error messages. +type OccurrenceMap = M.HashMap TyCon [(DataCon, TyConOccurrence)]++data TyConOccurrence+ = TyConOcc { posOcc :: [TyCon] -- TyCons that occur in positive positions+ , negOcc :: [TyCon] -- TyCons that occur in negative positions+ }+ deriving Eq++instance Monoid TyConOccurrence where+ mempty = TyConOcc mempty mempty+instance Semigroup TyConOccurrence where+ TyConOcc p1 n1 <> TyConOcc p2 n2 = TyConOcc (L.nub (p1 <> p2)) (L.nub (n1 <> n2))+instance Outputable TyConOccurrence where+ ppr (TyConOcc pos neg) = text "pos" <+> ppr pos <+> text "neg" <+> ppr neg+++instance Outputable OccurrenceMap where+ ppr m = ppr (M.toList m)+++makeOccurrences :: [TyCon] -> OccurrenceMap+makeOccurrences tycons+ = let m0 = M.fromList [(tc, map (\dc -> (dc, makeOccurrence tcInfo (dctypes dc))) (tyConDataCons tc))+ | tc <- tycons']+ -- fixpoint to find occurrences of mutually recursive data definitons+ in fix (\m -> foldl merge m tycons') m0+ where+ fix f x = let x' = f x in if x == x' then x else fix f x'+ tcInfo = M.fromList $ zip tycons' (makeTyConVariance <$> tycons')+ merge m tc = M.update (mergeList m) tc m+ mergeList m xs = Just [(dc, mergeApp m am) | (dc,am) <- xs]+ mergeApp m (TyConOcc pos neg) =+ let TyConOcc pospos posneg = mconcat (findOccurrence m <$> pos)+ TyConOcc negpos negneg = mconcat (findOccurrence m <$> neg)+ -- Keep positive, flip negative + in TyConOcc (L.nub (pos <> pospos <> negneg)) (L.nub (neg <> negpos <> posneg))+++ tycontypes tc = concatMap dctypes $ tyConDataCons tc+ dctypes dc = irrelevantMult <$> dataConOrigArgTys dc++ -- Construct the map for all TyCons that appear in the definitions + tycons' = L.nub (concatMap tcs (concatMap tycontypes tycons) ++ tycons)++ tcs (TyConApp tc' ts) = tc': concatMap tcs ts+ tcs (AppTy t1 t2) = tcs t1 ++ tcs t2+ tcs (ForAllTy _ t) = tcs t+ tcs (FunTy _ _ t1 t2) = tcs t1 ++ tcs t2+ tcs (TyVarTy _ ) = []+ tcs (LitTy _) = []+ tcs (CastTy _ _) = []+ tcs (CoercionTy _) = []++makeOccurrence :: M.HashMap TyCon VarianceInfo -> [Type] -> TyConOccurrence+makeOccurrence tcInfo = foldl (go Covariant) mempty+ where+ go :: Variance -> TyConOccurrence -> Type -> TyConOccurrence+ go p m (TyConApp tc ts) = addOccurrence p tc+ $ foldl (\m' (t, v) -> go (v <> p) m' t) m+ (zip ts (M.lookupDefault (repeat Bivariant) tc tcInfo))+ go _ m (TyVarTy _ ) = m+ go _ m (AppTy t1 t2) = go Bivariant (go Bivariant m t1) t2+ go p m (ForAllTy _ t) = go p m t+ go p m (FunTy _ _ t1 t2) = go p (go (flipVariance p) m t1) t2+ go _ m (LitTy _) = m+ go _ m (CastTy _ _) = m+ go _ m (CoercionTy _) = m++ addOccurrence p tc (TyConOcc pos neg)+ = case p of+ Covariant -> TyConOcc (L.nub (tc:pos)) neg+ Contravariant -> TyConOcc pos (L.nub (tc:neg))+ Bivariant -> TyConOcc (L.nub (tc:pos)) (L.nub (tc:neg))+ Invariant -> TyConOcc pos neg++findOccurrence :: OccurrenceMap -> TyCon -> TyConOccurrence+findOccurrence m tc = mconcat (snd <$> M.lookupDefault mempty tc m)+++++isRecursivenewTyCon :: TyCon -> Bool+isRecursivenewTyCon c+ | not (isNewTyCon c)+ = False+isRecursivenewTyCon c+ = go t+ where+ t = snd $ newTyConRhs c+ go (AppTy t1 t2) = go t1 || go t2+ go (TyConApp c' ts) = c == c' || any go ts+ go (ForAllTy _ t1) = go t1+ go (FunTy _ _ t1 t2) = go t1 || go t2+ go (CastTy t1 _) = go t1+ go _ = False+++dataConImplicitIds :: DataCon -> [Id]+dataConImplicitIds dc = [ x | AnId x <- dataConImplicitTyThings dc]++class Subable a where+ sub :: M.HashMap CoreBndr CoreExpr -> a -> a+ subTy :: M.HashMap TyVar Type -> a -> a++instance Subable CoreExpr where+ sub s (Var v) = M.lookupDefault (Var v) v s+ sub _ (Lit l) = Lit l+ sub s (App e1 e2) = App (sub s e1) (sub s e2)+ sub s (Lam b e) = Lam b (sub s e)+ sub s (Let b e) = Let (sub s b) (sub s e)+ sub s (Case e b t a) = Case (sub s e) (sub s b) t (map (sub s) a)+ sub s (Cast e c) = Cast (sub s e) c+ sub s (Tick t e) = Tick t (sub s e)+ sub _ (Type t) = Type t+ sub _ (Coercion c) = Coercion c++ subTy s (Var v) = Var (subTy s v)+ subTy _ (Lit l) = Lit l+ subTy s (App e1 e2) = App (subTy s e1) (subTy s e2)+ subTy s (Lam b e) | isTyVar b = Lam v' (subTy s e)+ where v' = case M.lookup b s of+ Just (TyVarTy v) -> v+ _ -> b++ subTy s (Lam b e) = Lam (subTy s b) (subTy s e)+ subTy s (Let b e) = Let (subTy s b) (subTy s e)+ subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a)+ subTy s (Cast e c) = Cast (subTy s e) (subTy s c)+ subTy s (Tick t e) = Tick t (subTy s e)+ subTy s (Type t) = Type (subTy s t)+ subTy s (Coercion c) = Coercion (subTy s c)++instance Subable Coercion where+ sub _ c = c+ subTy _ _ = panic Nothing "subTy Coercion"++instance Subable (Alt Var) where+ sub s (Alt a b e) = Alt a (map (sub s) b) (sub s e)+ subTy s (Alt a b e) = Alt a (map (subTy s) b) (subTy s e)++instance Subable Var where+ sub s v | M.member v s = subVar $ s M.! v+ | otherwise = v+ subTy s v = setVarType v (subTy s (varType v))++subVar :: Expr t -> Id+subVar (Var x) = x+subVar _ = panic Nothing "sub Var"++instance Subable (Bind Var) where+ sub s (NonRec x e) = NonRec (sub s x) (sub s e)+ sub s (Rec xes) = Rec ((sub s *** sub s) <$> xes)++ subTy s (NonRec x e) = NonRec (subTy s x) (subTy s e)+ subTy s (Rec xes) = Rec ((subTy s *** subTy s) <$> xes)++instance Subable Type where+ sub _ e = e+ subTy = substTysWith++substTysWith :: M.HashMap Var Type -> Type -> Type+substTysWith s tv@(TyVarTy v) = M.lookupDefault tv v s+substTysWith s (FunTy aaf m t1 t2) = FunTy aaf m (substTysWith s t1) (substTysWith s t2)+substTysWith s (ForAllTy v t) = ForAllTy v (substTysWith (M.delete (binderVar v) s) t)+substTysWith s (TyConApp c ts) = TyConApp c (map (substTysWith s) ts)+substTysWith s (AppTy t1 t2) = AppTy (substTysWith s t1) (substTysWith s t2)+substTysWith _ (LitTy t) = LitTy t+substTysWith s (CastTy t c) = CastTy (substTysWith s t) c+substTysWith _ (CoercionTy c) = CoercionTy c++substExpr :: M.HashMap Var Var -> CoreExpr -> CoreExpr+substExpr s = go+ where+ subsVar v = M.lookupDefault v v s+ go (Var v) = Var $ subsVar v+ go (Lit l) = Lit l+ go (App e1 e2) = App (go e1) (go e2)+ go (Lam x e) = Lam (subsVar x) (go e)+ go (Let (NonRec x ex) e) = Let (NonRec (subsVar x) (go ex)) (go e)+ go (Let (Rec xes) e) = Let (Rec [(subsVar x', go e') | (x',e') <- xes]) (go e)+ go (Case e b t alts) = Case (go e) (subsVar b) t [Alt c (subsVar <$> xs) (go e') | Alt c xs e' <- alts]+ go (Cast e c) = Cast (go e) c+ go (Tick t e) = Tick t (go e)+ go (Type t) = Type t+ go (Coercion c) = Coercion c++mapType :: (Type -> Type) -> Type -> Type+mapType f = go+ where+ go t@(TyVarTy _) = f t+ go (AppTy t1 t2) = f $ AppTy (go t1) (go t2)+ go (TyConApp c ts) = f $ TyConApp c (go <$> ts)+ go (FunTy aaf m t1 t2) = f $ FunTy aaf m (go t1) (go t2)+ go (ForAllTy v t) = f $ ForAllTy v (go t)+ go t@(LitTy _) = f t+ go (CastTy t c) = CastTy (go t) c+ go (CoercionTy c) = f $ CoercionTy c+++stringClassArg :: Type -> Maybe Type+stringClassArg t | isFunTy t+ = Nothing+stringClassArg t+ = case (tyConAppTyCon_maybe t, tyConAppArgs_maybe t) of+ (Just c, Just [t']) | isStringClassName == tyConName c+ -> Just t'+ _ -> Nothing
+ src/Language/Haskell/Liquid/GHC/Plugin.hs view
@@ -0,0 +1,607 @@+-- | This module provides a GHC 'Plugin' that allows LiquidHaskell to be hooked directly into GHC's+-- compilation pipeline, facilitating its usage and adoption.++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Language.Haskell.Liquid.GHC.Plugin (++ plugin++ ) where++import qualified Liquid.GHC.API as O+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.UX.CmdLine as LH+import qualified Language.Haskell.Liquid.GHC.Interface as LH+import qualified Language.Haskell.Liquid.Liquid as LH+import qualified Language.Haskell.Liquid.Types.PrettyPrint as LH ( filterReportErrors+ , filterReportErrorsWith+ , defaultFilterReporter+ , reduceFilters )+import qualified Language.Haskell.Liquid.GHC.Logging as LH (fromPJDoc)++import Language.Haskell.Liquid.GHC.Plugin.Types+import Language.Haskell.Liquid.GHC.Plugin.Util as Util+import Language.Haskell.Liquid.GHC.Plugin.SpecFinder+ as SpecFinder++import Language.Haskell.Liquid.GHC.Types (MGIModGuts(..), miModGuts)+import GHC.LanguageExtensions++import Control.Monad+import qualified Control.Monad.Catch as Ex+import Control.Monad.IO.Class (MonadIO)++import Data.Coerce+import Data.Function ((&))+import Data.Kind ( Type )+import Data.List as L+ hiding ( intersperse )+import Data.IORef+import qualified Data.Set as S+import Data.Set ( Set )+++import qualified Data.HashSet as HS+import qualified Data.HashMap.Strict as HM++import System.IO.Unsafe ( unsafePerformIO )+import Language.Fixpoint.Types hiding ( errs+ , panic+ , Error+ , Result+ , Expr+ )++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.Bare+import Language.Haskell.Liquid.UX.CmdLine++-- | 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+-- in an `Either`'s `Left` case and handled at the top level of the plugin+-- function.+newtype LiquidCheckException = ErrorsOccurred [Filter] -- Unmatched expected errors+ deriving (Eq, Ord, Show)++---------------------------------------------------------------------------------+-- | 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++---------------------------------------------------------------------------------+-- | 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)++---------------------------------------------------------------------------------+-- | The Plugin entrypoint ------------------------------------------------------+---------------------------------------------------------------------------------++plugin :: GHC.Plugin+plugin = GHC.defaultPlugin {+ typeCheckResultAction = liquidPlugin+ , driverPlugin = customDynFlags+ , 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++ -- 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+ logger <- getLogger+ dynFlags <- getDynFlags+ withTiming logger dynFlags (text "LiquidHaskell" <+> brackets (ppr $ ms_mod_name summary)) (const ()) $ do+ if gopt Opt_Haddock dynFlags+ then do+ -- Warn the user+ let msg = PJ.vcat [ PJ.text "LH can't be run with Haddock."+ , PJ.nest 4 $ PJ.text "Documentation will still be created."+ ]+ let srcLoc = mkSrcLoc (mkFastString $ ms_hspp_file summary) 1 1+ let warning = mkWarning (mkSrcSpan srcLoc srcLoc) msg+ liftIO $ printWarning logger dynFlags warning+ pure gblEnv+ else do+ newGblEnv <- typecheckHook summary gblEnv+ case newGblEnv of+ -- Exit with success if all expected errors were found+ Left (ErrorsOccurred []) -> pure gblEnv+ -- Exit with error if there were unmatched expected errors+ Left (ErrorsOccurred errorFilters) -> do+ defaultFilterReporter (LH.modSummaryHsFile summary) errorFilters+ failM+ Right newGblEnv' ->+ pure newGblEnv'++--------------------------------------------------------------------------------+-- | GHC Configuration & Setup -------------------------------------------------+--------------------------------------------------------------------------------++-- | 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+ `xopt_set` MagicHash+ `xopt_set` DeriveGeneric+ `xopt_set` StandaloneDeriving++--------------------------------------------------------------------------------+-- | \"Unoptimising\" things ----------------------------------------------------+--------------------------------------------------------------------------------++-- | 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++instance Unoptimise DynFlags where+ type UnoptimisedTarget DynFlags = DynFlags+ unoptimise df = updOptLevel 0 df+ { debugLevel = 1+ , ghcLink = LinkInMemory+ , backend = Interpreter+ , ghcMode = CompManager+ }++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 }++--------------------------------------------------------------------------------+-- | Typechecking phase --------------------------------------------------------+--------------------------------------------------------------------------------++-- | We hook at this stage of the pipeline in order to call \"liquidhaskell\". This+-- might seems counterintuitive as LH works on a desugared module. However, there+-- are a bunch of reasons why we do this:+--+-- 1. Tools like \"ghcide\" works by running the compilation pipeline up until+-- this stage, which means that we won't be able to report errors and warnings+-- 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.+--+typecheckHook :: ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)+typecheckHook (unoptimise -> modSummary) tcGblEnv = 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 modSummary tcGblEnv+ availTyCons <- liftIO $ LH.availableTyCons env modSummary tcGblEnv (tcg_exports tcGblEnv)+ availVars <- liftIO $ LH.availableVars env modSummary tcGblEnv (tcg_exports tcGblEnv)++ unoptimisedGuts <- liftIO $ desugarModuleIO env modSummary typechecked++ let tcData = mkTcData (tcg_rn_imports tcGblEnv) resolvedNames availTyCons availVars+ let pipelineData = PipelineData unoptimisedGuts tcData (map mkSpecComment comments)++ liquidHaskellCheck pipelineData modSummary tcGblEnv++ where+ thisModule :: Module+ thisModule = tcg_mod tcGblEnv++ dropPlugins hsc_env = hsc_env { hsc_plugins = [], hsc_static_plugins = [] }++serialiseSpec :: Module -> TcGblEnv -> LiquidLib -> TcM TcGblEnv+serialiseSpec thisModule tcGblEnv liquidLib = do+ -- ---+ -- -- CAN WE 'IGNORE' THE BELOW? TODO:IGNORE -- issue use `emptyLiquidLib` instead of pmrClientLib+ -- ProcessModuleResult{..} <- processModule lhContext++ -- liftIO $ putStrLn "liquidHaskellCheck 7"++ -- -- Call into the existing Liquid interface+ -- out <- liftIO $ LH.checkTargetInfo pmrTargetInfo++ -- liftIO $ putStrLn "liquidHaskellCheck 8"++ -- -- Report the outcome of the checking+ -- LH.reportResult errorLogger cfg [giTarget (giSrc pmrTargetInfo)] out+ -- case o_result out of+ -- Safe _stats -> pure ()+ -- _ -> failM++ -- liftIO $ putStrLn "liquidHaskellCheck 9"+ -- ---++ let serialisedSpec = Util.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+ debugLog $ " Input spec: \n" ++ show inputSpec+ debugLog $ "Relevant ===> \n" ++ unlines (renderModule <$> S.toList (relevantModules modGuts))++ logicMap :: LogicMap <- liftIO LH.makeLogicMap++ -- 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 modGuts+ }++ -- 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++ -- 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++ 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)++ where+ thisFile :: FilePath+ thisFile = LH.modSummaryHsFile modSummary++ continue :: TcM (Either LiquidCheckException TcGblEnv)+ 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++checkLiquidHaskellContext :: LiquidHaskellContext -> TcM (Either LiquidCheckException LiquidLib)+checkLiquidHaskellContext lhContext = do+ pmr <- processModule lhContext+ case pmr of+ Left e -> pure $ Left e+ Right ProcessModuleResult{..} -> do+ -- Call into the existing Liquid interface+ out <- liftIO $ LH.checkTargetInfo pmrTargetInfo++ let bareSpec = lhInputSpec lhContext+ file = LH.modSummaryHsFile $ lhModuleSummary lhContext++ withPragmas (lhGlobalCfg lhContext) file (Ms.pragmas $ fromBareSpec bareSpec) $ \moduleCfg -> do+ let filters = getFilters moduleCfg+ -- Report the outcome of the checking+ LH.reportResult (errorLogger file filters) moduleCfg [giTarget (giSrc pmrTargetInfo)] out+ -- If there are unmatched filters or errors, and we are not reporting with+ -- json, we don't make it to this part of the code because errorLogger+ -- will throw an exception.+ --+ -- F.Crash is also handled by reportResult and errorLogger+ case o_result out of+ F.Safe _ -> return $ Right pmrClientLib+ _ | json moduleCfg -> failM+ | otherwise -> return $ Left $ ErrorsOccurred []++errorLogger :: FilePath -> [Filter] -> OutputResult -> TcM ()+errorLogger file filters outputResult = do+ LH.filterReportErrorsWith+ FilterReportErrorsArgs { msgReporter = GHC.reportErrors+ , filterReporter = LH.defaultFilterReporter file+ , failure = GHC.failM+ , continue = pure ()+ , pprinter = \(spn, e) -> mkLongErrAt spn (LH.fromPJDoc e) O.empty+ , matchingFilters = LH.reduceFilters (\(src, doc) -> PJ.render doc ++ " at " ++ LH.showPpr src) filters+ , filters = filters+ }+ (LH.orMessages outputResult)++isIgnore :: BareSpec -> Bool+isIgnore (MkBareSpec 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+ hscEnv <- env_top <$> getEnv+ results <- SpecFinder.findRelevantSpecs+ (excludeAutomaticAssumptionsFor currentModuleConfig) hscEnv mods+ deps <- foldM 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)+ }++data LiquidHaskellContext = LiquidHaskellContext {+ lhGlobalCfg :: Config+ , lhInputSpec :: BareSpec+ , lhModuleLogicMap :: LogicMap+ , lhModuleSummary :: ModSummary+ , lhModuleTcData :: TcData+ , lhModuleGuts :: ModGuts+ , lhRelevantModules :: Set Module+ }++--------------------------------------------------------------------------------+-- | Per-Module Pipeline -------------------------------------------------------+--------------------------------------------------------------------------------++data ProcessModuleResult = ProcessModuleResult {+ pmrClientLib :: LiquidLib+ -- ^ The \"client library\" we will serialise on disk into an interface's 'Annotation'.+ , pmrTargetInfo :: TargetInfo+ -- ^ 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+ debugLog ("Module ==> " ++ renderModule thisModule)+ hscEnv <- env_top <$> getEnv++ let bareSpec = 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)++ withPragmas lhGlobalCfg file (Ms.pragmas $ fromBareSpec bareSpec) $ \moduleCfg -> do+ dependencies <- loadDependencies moduleCfg+ thisModule+ (S.toList 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)++ targetSrc <- liftIO $ makeTargetSrc moduleCfg file lhModuleTcData modGuts hscEnv+ logger <- getLogger+ dynFlags <- getDynFlags++ -- 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.+++ result <-+ makeTargetSpec moduleCfg lhModuleLogicMap targetSrc bareSpec dependencies++ let continue = pure $ Left (ErrorsOccurred [])+ reportErrs :: (Show e, F.PPrint e) => [TError e] -> TcRn (Either LiquidCheckException ProcessModuleResult)+ reportErrs = LH.filterReportErrors file GHC.failM continue (getFilters moduleCfg) Full++ (case result of+ -- Print warnings and errors, aborting the compilation.+ Left diagnostics -> do+ liftIO $ mapM_ (printWarning logger dynFlags) (allWarnings diagnostics)+ reportErrs $ allErrors diagnostics+ Right (warnings, targetSpec, liftedSpec) -> do+ liftIO $ mapM_ (printWarning logger dynFlags) warnings+ let targetInfo = TargetInfo targetSrc targetSpec++ debugLog $ "bareSpec ==> " ++ show bareSpec+ debugLog $ "liftedSpec ==> " ++ show liftedSpec++ let clientLib = mkLiquidLib liftedSpec & addLibDependencies dependencies++ let result' = ProcessModuleResult {+ pmrClientLib = clientLib+ , pmrTargetInfo = targetInfo+ }++ pure $ Right result')+ `Ex.catch` (\(e :: UserError) -> reportErrs [e])+ `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++ -- 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 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+ debugLog $ "_gsFiTcs => " ++ show fiTcs+ debugLog $ "_gsFiDcs => " ++ show fiDcs+ 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)+ debugLog $ "gsTcs => " ++ (O.showSDocUnsafe . O.ppr $ allTcs)+ debugLog $ "gsCls => " ++ (O.showSDocUnsafe . O.ppr $ mgi_cls_inst mgiModGuts)+ 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+ , giUseVars = readVars coreBinds+ , giDerVars = HS.fromList (LH.derivedVars cfg mgiModGuts)+ , gsExports = mgi_exports mgiModGuts+ , gsTcs = allTcs+ , gsCls = mgi_cls_inst mgiModGuts+ , 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++getFamInstances :: ModGuts -> [FamInst]+getFamInstances guts = famInstEnvElts (mg_fam_inst_env guts)
+ src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs view
@@ -0,0 +1,180 @@+{-# 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 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 qualified Liquid.GHC.API as O+import Liquid.GHC.API as GHC++import Data.Bifunctor+import qualified Data.Char+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 = + 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++-- | Load any relevant spec for the input list of 'Module's, by querying both the 'ExternalPackageState'+-- and the 'HomePackageTable'.+--+-- Specs come from the interface files of the given modules or their matching+-- _LHAssumptions modules. A module @M@ only matches with a module named+-- @M_LHAssumptions@.+--+-- Assumptions are taken from _LHAssumptions modules only if the interface+-- file of the matching module contains no spec.+findRelevantSpecs :: [String] -- ^ Package to exclude for loading LHAssumptions+ -> HscEnv+ -> [Module]+ -- ^ Any relevant module fetched during dependency-discovery.+ -> TcM [SpecFinderResult]+findRelevantSpecs lhAssmPkgExcludes hscEnv mods = do+ eps <- liftIO $ readIORef (hsc_EPS hscEnv)+ foldM (loadRelevantSpec eps) mempty mods+ where++ loadRelevantSpec :: ExternalPackageState -> [SpecFinderResult] -> Module -> TcM [SpecFinderResult]+ loadRelevantSpec eps !acc currentModule = do+ res <- liftIO $ runMaybeT $+ lookupInterfaceAnnotations eps (hsc_HPT hscEnv) currentModule+ case res of+ Nothing -> do+ mAssm <- loadModuleLHAssumptionsIfAny currentModule+ return $ fromMaybe (SpecNotFound currentModule) mAssm : acc+ Just specResult ->+ return (specResult : acc)++ loadModuleLHAssumptionsIfAny m | isImportExcluded m = return Nothing+ | otherwise = do+ let assModName = assumptionsModuleName m+ -- loadInterface might mutate the EPS if the module is+ -- not already loaded+ res <- liftIO $ findImportedModule hscEnv assModName Nothing+ case res of+ Found _ assMod -> do+ _ <- initIfaceTcRn $ loadInterface "liquidhaskell assumptions" assMod ImportBySystem+ -- read the EPS again+ eps2 <- liftIO $ readIORef (hsc_EPS hscEnv)+ -- now look up the assumptions+ liftIO $ runMaybeT $ lookupInterfaceAnnotationsEPS eps2 assMod+ FoundMultiple{} -> failWithTc $ cannotFindModule hscEnv assModName res+ _ -> return Nothing++ isImportExcluded m =+ let s = takeWhile Data.Char.isAlphaNum $ unitString (moduleUnit m)+ in elem s lhAssmPkgExcludes++ 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++ 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++-- | 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+-- /per module/.+configToRedundantDependencies :: HscEnv -> Config -> IO [StableModule]+configToRedundantDependencies env cfg = do+ catMaybes <$> mapM (lookupModule' . first ($ cfg)) configSensitiveDependencies+ where+ lookupModule' :: (Bool, ModuleName) -> IO (Maybe StableModule)+ lookupModule' (fetchModule, modName)+ | fetchModule = lookupLiquidBaseModule modName+ | otherwise = pure Nothing++ lookupLiquidBaseModule :: ModuleName -> IO (Maybe StableModule)+ lookupLiquidBaseModule mn = do+ res <- findExposedPackageModule env mn (Just "liquidhaskell")+ case res of+ Found _ mdl -> pure $ Just (toStableModule mdl)+ _ -> pure Nothing++-- | Static associative map of the 'ModuleName' that needs to be filtered from the final 'TargetDependencies'+-- due to some particular configuration options.+--+-- Modify this map to add any extra special case. Remember that the semantic is not which module will be+-- /added/, but rather which one will be /removed/ from the final list of dependencies.+--+configSensitiveDependencies :: [(Config -> Bool, ModuleName)]+configSensitiveDependencies = [+ (not . totalityCheck, mkModuleName "Liquid.Prelude.Totality_LHAssumptions")+ , (linear, mkModuleName "Liquid.Prelude.Real_LHAssumptions")+ ]
+ src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs view
@@ -0,0 +1,233 @@++module Language.Haskell.Liquid.GHC.Plugin.Tutorial (++ -- * Introduction and Requirements+ -- $introduction++ -- * Your first package+ -- $firstPackage++ -- * Using GHCi+ -- $usingGHCi++ -- * Passing options+ -- $passingOptions++ -- * Understanding LiquidHaskell Spec resolution strategies+ -- $specResolutionStrategies++ -- * Providing specifications for existing packages+ -- $specForExisting++) where++{- $introduction++This tutorial describes the general approach of using LiquidHaskell using the new compiler plugin. Due+to some recent changes and improvements to the compiler plugin API (which LiquidHaskell requires) the+__minimum supported version of GHC is 8.10.1.__++-}++{- $firstPackage++Generally speaking, in order to integrate LiquidHaskell (/LH/ for brevity from now on) with your existing+(or brand new) project, we need to tell GHC that we want to __use the LH plugin__, and it can be done+by adding the @-fplugin=LiquidHaskell@ option in the @ghc-options@ of your Cabal manifest.++If we do the above, our Cabal manifest should look similar to this:++@+cabal-version: 1.12++name: toy-package-a+version: 0.1.0.0+description: This is a toy example.+homepage:+bug-reports:+author: Author name here+maintainer: example@example.com+copyright: 2019 Author name here+license: BSD3+license-file: LICENSE+build-type: Simple++library+ exposed-modules:+ Toy.A+ hs-source-dirs:+ src+ build-depends:+ base+ , liquidhaskell -- Add this!+ default-language: Haskell2010+ ghc-options: -fplugin=LiquidHaskell -- Add this!+@++Let's now define a very simple module called 'Toy.A':++@+module Toy.A ( notThree, one, two) where++\{\-\@ one :: {v:Int | v = 1 } \@\-\}+one :: Int+one = 1++\{\-\@ assume notThree :: {v : Nat | v != 3 } \@\-\}+notThree :: Int+notThree = 4++\{\-\@ two :: Nat \@\-\}+two :: Int+two = one + one+@++Now, if we build the package with (for example) @cabal v2-build toy-package-a@, we should see something+like this:++@+Resolving dependencies...+Build profile: -w ghc-8.10.1 -O1+In order, the following will be built (use -v for more details):+ - toy-package-a-0.1.0.0 (lib) (configuration changed)+Configuring library for toy-package-a-0.1.0.0..+Warning: The 'license-file' field refers to the file 'LICENSE' which does not+exist.+Preprocessing library for toy-package-a-0.1.0.0..+Building library for toy-package-a-0.1.0.0..++[3 of 3] Compiling Toy.A ( src\/Toy\/A.hs, ... )++**** LIQUID: SAFE (7 constraints checked) **************************************+@++The \"SAFE\" banner here is LH's way of saying "all is well". What happens if we try to violate a+refinement? Let's find out. If change @one@ to look like this:++@+{-@ one :: {v:Int | v = 1 } @-}+one :: Int+one = 2+@++Upon next recompilation, GHC (or rather, /LH/) will bark at us:++@+Building library for toy-package-a-0.1.0.0..+[3 of 3] Compiling Toy.A ( src\/Toy\/A.hs, ... )++**** LIQUID: UNSAFE ************************************************************++src\/Toy\/A.hs:36:1: error:+ Liquid Type Mismatch+ .+ The inferred type+ VV : {v : GHC.Types.Int | v == 2}+ .+ is not a subtype of the required type+ VV : {VV : GHC.Types.Int | VV == 1}+ .+ |+36 | one = 2+ | ^^^^^^^+@++-}++{- $passingOptions++Passing options to /LH/ is possible and works using the standard mechanism the plugin system already provides.+For example let's image we want to skip verification of our 'Toy.A' module. At this point, we have two options:++1. We can add the option directly in the module, as a \"pragma\":++ @+ \{\-\@ LIQUID "--compilespec" \@\-\}+ module Toy.A ( notThree, one, two) where+ ...+ @++2. We can add this \"globally\" (if that's really what we want), like this:++ @+ cabal-version: 1.12+ name: toy-package-a+ ..+ default-language: Haskell2010+ ghc-options: -fplugin=LiquidHaskell -fplugin-opt=LiquidHaskell:--compilespec+ @++-}++{- $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.++-}++{- $specForExisting++If you have control over the package or project you would like to annotate with /LH/ refinements, all is well.+But what about packages you don't own or maintain? Typically, one solution would be to convince the+project's maintainers to get on board and to add /LH/ annotations to the code themselves, but this might not+be so easy, for a number of reasons:++* The package you are trying to \"refine\" is not maintained anymore, or the maintainer is very difficult+ to reach;++* The package is fairly important in the Haskell ecosystem and making changes to it might not be so easy,+ especially for packages which come as part of a GHC installation (think @base@, for example).++The designed workflow in these cases is to create a __brand new package__ (that we can call an \"assumptions\" package),+which would contain the required /LH/ annotations. This is what we have done for things like @vector@ and @parallel@,+for example, by providing @liquid-vector@ and @liquid-parallel@.++There are some guidelines to drive this process:++1. Typically you want to clearly identify this package as part of the /LH ecosystem/ by using an+ appropriate prefix for your package name, something like @liquid-foo@ where @foo@ is the original+ package you are adding annotations for;++2. If you want to have Liquid Haskell load the specs automatically when finding+ an import of a module @A.B.C@, put the specs in a module named+ @A.B.C_LHAssumptions@.++3. You need to abide to a set of PVP rules, like tracking the version of the upstream package first and+ in case of changes to either the LH language or the specs in the mirror package, bump the last two+ digits of the version scheme, in a format like this:++ @liquid-\<package-name\>-A.B.C.D.X.Y@++ Where @A.B.C.D@ would be used to track the upstream package version and @X.Y@ would enumerate the+ versions of this mirror package. Bumping @X@ would signify there was a breaking change in the /LH/+ language that required a new release of this plugin, whereas bumping @Y@ would mean something changed+ in the __specs__ provided as part of this assumptions package (e.g. more refinements were added,+ bugs were fixed etc).+-}
+ src/Language/Haskell/Liquid/GHC/Plugin/Types.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}++module Language.Haskell.Liquid.GHC.Plugin.Types+ ( SpecComment(..)++ -- * Dealing with specs and their dependencies+ , LiquidLib+ , mkLiquidLib+ , mkSpecComment+ , libTarget+ , libDeps+ , allDeps+ , addLibDependencies++ -- * Carrying data across stages of the compilation pipeline+ , PipelineData(..)++ -- * Acquiring and manipulating data from the typechecking phase+ , TcData+ , tcAllImports+ , tcQualifiedImports+ , tcResolvedNames+ , tcAvailableTyCons+ , tcAvailableVars+ , mkTcData+ ) where++import Data.Binary as B+import Data.Foldable+import GHC.Generics hiding ( moduleName )++import qualified Data.HashSet as HS++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 )+++data LiquidLib = LiquidLib+ { llTarget :: LiftedSpec+ -- ^ The target /LiftedSpec/.+ , llDeps :: TargetDependencies+ -- ^ The specs which were necessary to produce the target 'BareSpec'.+ } deriving (Show, Generic)++instance B.Binary LiquidLib++-- | Creates a new 'LiquidLib' with no dependencies.+mkLiquidLib :: LiftedSpec -> LiquidLib+mkLiquidLib s = LiquidLib s mempty++-- | Adds a set of dependencies to the input 'LiquidLib'.+addLibDependencies :: TargetDependencies -> LiquidLib -> LiquidLib+addLibDependencies deps lib = lib { llDeps = deps <> llDeps lib }++-- | Returns the target 'LiftedSpec' of this 'LiquidLib'.+libTarget :: LiquidLib -> LiftedSpec+libTarget = llTarget++-- | Returns all the dependencies of this 'LiquidLib'.+libDeps :: LiquidLib -> TargetDependencies+libDeps = llDeps++-- | Extracts all the dependencies from a collection of 'LiquidLib's.+allDeps :: Foldable f => f LiquidLib -> TargetDependencies+allDeps = foldl' (\acc lib -> acc <> llDeps lib) mempty++-- | Just a small wrapper around the 'SourcePos' and the text fragment of a LH spec comment.+newtype SpecComment =+ SpecComment (SourcePos, String)+ deriving Show++mkSpecComment :: (Maybe RealSrcLoc, String) -> SpecComment+mkSpecComment (m, s) = SpecComment (sourcePos m, s)+ where+ sourcePos Nothing = dummyPos "<no source information>"+ sourcePos (Just sp) = realSrcLocSourcePos sp++--+-- Passing data between stages of the pipeline+--+-- The plugin architecture doesn't provide a default system to \"thread\" data across stages of the+-- compilation pipeline, which means that plugin implementors have two choices:+--+-- 1. Serialise any data they want to carry around inside annotations, but this can be potentially costly;+-- 2. Pass data inside IORefs.++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+ }
+ src/Language/Haskell/Liquid/GHC/Plugin/Util.hs view
@@ -0,0 +1,77 @@+{-# 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/Resugar.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module contains functions for "resugaring" low-level GHC `CoreExpr`+-- into high-level patterns, that can receive special case handling in+-- different phases (e.g. ANF, Constraint Generation, etc.)++module Language.Haskell.Liquid.GHC.Resugar (+ -- * High-level Source Patterns+ Pattern (..)++ -- * Lift a CoreExpr into a Pattern+ , lift++ -- * Lower a pattern back into a CoreExpr+ , lower+ ) where++import qualified Data.List as L+import Liquid.GHC.API as Ghc+import qualified Language.Haskell.Liquid.GHC.Misc as GM+import qualified Language.Fixpoint.Types as F +import qualified Text.PrettyPrint.HughesPJ as PJ +-- import Debug.Trace++--------------------------------------------------------------------------------+-- | Data type for high-level patterns -----------------------------------------+--------------------------------------------------------------------------------++data Pattern+ = PatBind+ { patE1 :: !CoreExpr+ , patX :: !Var+ , patE2 :: !CoreExpr+ , patM :: !Type+ , patDct :: !CoreExpr+ , patTyA :: !Type+ , patTyB :: !Type+ , patFF :: !Var+ } -- ^ e1 >>= \x -> e2++ | PatReturn -- return @ m @ t @ $dT @ e+ { patE :: !CoreExpr -- ^ e+ , patM :: !Type -- ^ m+ , patDct :: !CoreExpr -- ^ $dT+ , patTy :: !Type -- ^ t+ , patRet :: !Var -- ^ "return"+ }++ | PatProject -- (case xe as x of C [x1,...,xn] -> xi) : ty+ { patXE :: !Var -- ^ xe+ , patX :: !Var -- ^ x+ , patTy :: !Type -- ^ ty+ , patCtor :: !DataCon -- ^ C+ , patBinds :: ![Var] -- ^ [x1,...,xn]+ , patIdx :: !Int -- ^ i :: NatLT {len patBinds}+ }++ | PatSelfBind -- let x = e in x+ { patX :: !Var -- ^ x+ , patE :: !CoreExpr -- ^ e+ }++ | PatSelfRecBind -- letrec x = e in x+ { patX :: !Var -- ^ x+ , patE :: !CoreExpr -- ^ e+ }++instance F.PPrint Pattern where + pprintTidy = ppPat++ppPat :: F.Tidy -> Pattern -> PJ.Doc +ppPat k (PatReturn e m d t rv) = + "PatReturn: " + PJ.$+$ + F.pprintKVs k+ [ ("rv" :: PJ.Doc, GM.pprDoc rv) + , ("e " :: PJ.Doc, GM.pprDoc e) + , ("m " :: PJ.Doc, GM.pprDoc m) + , ("$d" :: PJ.Doc, GM.pprDoc d) + , ("t " :: PJ.Doc, GM.pprDoc t) + ] +ppPat _ _ = "TODO: PATTERN" + ++_mbId :: CoreExpr -> Maybe Var+_mbId (Var x) = Just x+_mbId (Tick _ e) = _mbId e+_mbId _ = Nothing++--------------------------------------------------------------------------------+-- | Lift expressions into High-level patterns ---------------------------------+--------------------------------------------------------------------------------+lift :: CoreExpr -> Maybe Pattern+--------------------------------------------------------------------------------+lift e = exprArgs e (collectArgs e)++exprArgs :: CoreExpr -> (CoreExpr, [CoreExpr]) -> Maybe Pattern+exprArgs _e (Var op, [Type m, d, Type a, Type b, e1, Lam x e2])+ | op `is` Ghc.bindMName+ = Just (PatBind e1 x e2 m d a b op)++exprArgs (Case (Var xe) x t [Alt (DataAlt c) ys (Var y)]) _+ | Just i <- y `L.elemIndex` ys+ = Just (PatProject xe x t c ys i)+++{- TEMPORARILY DISABLED: TODO-REBARE; in reality it hasn't been working AT ALL + since at least the GHC 8.2.1 port (?) because the TICKs get in the way + of recognizing the pattern? Anyways, messes up ++ tests/pattern/pos/Return00.hs ++ because we treat _all_ types of the form `m a` as "invariant" in the parameter `a`.+ Looks like the above tests only pass in earlier LH versions because this pattern + was NOT getting tickled!++exprArgs _e (Var op, [Type m, d, Type t, e])+ | op `is` PN.returnMName+ = Just (PatReturn e m d t op)+-}++{- TEMPORARILY DISBLED++exprArgs (Let (NonRec x e) e') _+ | Just y <- _mbId e', x == y+ = Just (PatSelfBind x e)++exprArgs (Let (Rec [(x, e)]) e') _+ | Just y <- _mbId e', x == y+ = Just (PatSelfRecBind x e)++-}+exprArgs _ _+ = Nothing++is :: Var -> Name -> Bool+is v n = n == getName v++--------------------------------------------------------------------------------+-- | Lower patterns back into expressions --------------------------------------+--------------------------------------------------------------------------------+lower :: Pattern -> CoreExpr+--------------------------------------------------------------------------------+lower (PatBind e1 x e2 m d a b op)+ = Ghc.mkCoreApps (Var op) [Type m, d, Type a, Type b, e1, Lam x e2]++lower (PatReturn e m d t op)+ = Ghc.mkCoreApps (Var op) [Type m, d, Type t, e]++lower (PatProject xe x t c ys i)+ = Case (Var xe) x t [Alt (DataAlt c) ys (Var yi)] where yi = ys !! i++lower (PatSelfBind x e)+ = Let (NonRec x e) (Var x)++lower (PatSelfRecBind x e)+ = Let (Rec [(x, e)]) (Var x)
+ src/Language/Haskell/Liquid/GHC/SpanStack.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}++module Language.Haskell.Liquid.GHC.SpanStack+ ( -- * Stack of positions+ Span (..)+ , SpanStack++ -- * Creating Stacks+ , empty, push++ -- * Using Stacks+ , srcSpan++ -- * Creating general spans+ , showSpan+ ) where++import Prelude hiding (error)+import Data.Maybe (listToMaybe, fromMaybe)+import Language.Haskell.Liquid.GHC.Misc (tickSrcSpan, showPpr)+import qualified Liquid.GHC.API as Ghc+import Liquid.GHC.API ( SrcSpan+ , fsLit+ , getSrcSpan+ , isGoodSrcSpan+ , mkGeneralSrcSpan+ )++-- | Opaque type for a stack of spans+newtype SpanStack = SpanStack { unStack :: [(Span, SrcSpan)] }++--------------------------------------------------------------------------------+empty :: SpanStack+--------------------------------------------------------------------------------+empty = SpanStack []++--------------------------------------------------------------------------------+push :: Span -> SpanStack -> SpanStack+--------------------------------------------------------------------------------+push !s stk -- @(SpanStack stk)+ | Just sp <- spanSrcSpan s = SpanStack ((s, sp) : unStack stk)+ | otherwise = stk++-- | A single span+data Span+ = Var !Ghc.Var -- ^ binder for whom we are generating constraint+ | Tick !Ghc.CoreTickish -- ^ nearest known Source Span+ | Span SrcSpan++instance Show Span where+ show (Var x) = show x+ show (Tick tt) = showPpr tt+ show (Span s) = show s ++--------------------------------------------------------------------------------+srcSpan :: SpanStack -> SrcSpan+--------------------------------------------------------------------------------+srcSpan s = fromMaybe noSpan (mbSrcSpan s)+ where+ noSpan = showSpan "Yikes! No source information"++mbSrcSpan :: SpanStack -> Maybe SrcSpan+mbSrcSpan = fmap snd . listToMaybe . unStack++spanSrcSpan :: Span -> Maybe SrcSpan+spanSrcSpan = maybeSpan Nothing . go+ where+ go (Var x) = getSrcSpan x+ go (Tick tt) = tickSrcSpan tt+ go (Span s) = s ++maybeSpan :: Maybe SrcSpan -> SrcSpan -> Maybe SrcSpan+maybeSpan d sp+ | isGoodSrcSpan sp = Just sp+ | otherwise = d++--------------------------------------------------------------------------------+showSpan :: (Show a) => a -> SrcSpan+--------------------------------------------------------------------------------+showSpan = mkGeneralSrcSpan . fsLit . show
+ src/Language/Haskell/Liquid/GHC/TypeRep.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Haskell.Liquid.GHC.TypeRep (+ mkTyArg, ++ showTy+ ) where++import Language.Haskell.Liquid.GHC.Misc (showPpr)+import Liquid.GHC.API as Ghc hiding (mkTyArg, showPpr, panic)+import Language.Fixpoint.Types (symbol)++-- e368f3265b80aeb337fbac3f6a70ee54ab14edfd++mkTyArg :: TyVar -> TyVarBinder+mkTyArg v = Bndr v Required++instance Eq Type where+ t1 == t2 = eqType' t1 t2++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' (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' (TyVarTy v1) (TyVarTy v2) + = v1 == v2 +eqType' (AppTy t11 t12) (AppTy t21 t22) + = eqType' t11 t21 && eqType' t12 t22 +eqType' (TyConApp c1 ts1) (TyConApp c2 ts2) + = c1 == c2 && and (zipWith eqType' ts1 ts2) +eqType' _ _ + = False +++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) ++ ")" +showTy (TyVarTy v) = "(RVar " ++ show (symbol v) ++ ")" +showTy (ForAllTy (Bndr v _) t) = "ForAllTy " ++ show (symbol v) ++ ". (" ++ showTy t ++ ")"+showTy (FunTy af _m1 t1 t2) = "FunTy " ++ showPpr af ++ " " ++ showTy t1 ++ ". (" ++ showTy t2 ++ ")"+showTy (CastTy _ _) = "CastTy"+showTy (CoercionTy _) = "CoercionTy"+showTy (LitTy _) = "LitTy"++sep' :: String -> [String] -> String+sep' _ [x] = x+sep' _ [] = []+sep' s (x:xs) = x ++ s ++ sep' s xs ++++-------------------------------------------------------------------------------+-- | 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)+substType x tx (AppTy t1 t2) + = AppTy (subst x tx t1) (subst 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)+substType x tx f@(ForAllTy b@(Bndr y _) t) + | symbol x == symbol y + = f+ | otherwise + = ForAllTy b (subst x tx t)+substType x tx (CastTy t c) + = CastTy (subst x tx t) (subst x tx c)+substType x tx (CoercionTy c) + = CoercionTy $ subst x tx 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 cN c1 c2)+ = FunCo r cN (subst x tx c1) (subst x tx c2) -- TODO(adinapoli) Is this the correct substitution?+substCoercion x tx (ForAllCo y c1 c2)+ | symbol x == symbol y + = ForAllCo y c1 c2+ | otherwise + = ForAllCo y (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 (NthCo r i c)+ = NthCo r 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)++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/GHC/Types.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveGeneric #-}+module Language.Haskell.Liquid.GHC.Types where++import Data.HashSet (HashSet, fromList)+import Data.Hashable+import GHC.Generics (Generic)+import Liquid.GHC.API+ ( AvailInfo+ , ClsInst+ , CoreProgram+ , ModGuts(mg_binds, mg_exports, mg_module, mg_tcs)+ , Module+ , Name+ , TyCon+ , availNames+ , moduleName+ , moduleNameString+ , nameModule+ , nameOccName+ , nameSrcLoc+ , nameSrcSpan+ , nameStableString+ , occNameString+ )++-- | A 'StableName' is virtually isomorphic to a GHC's 'Name' but crucially we don't use+-- the 'Eq' instance defined on a 'Name' because it's 'Unique'-based. In particular, GHC+-- doesn't guarantee that if we load an interface multiple times we would get the same 'Unique' for the+-- same 'Name', and this is a problem when we rely on 'Name's to be the same when we call 'isExportedVar',+-- which used to use a 'NameSet' derived from the '[AvailInfo]'. As the name implies, a 'NameSet' uses a+-- 'Name's 'Unique' for duplicate detection and indexing, and this would lead to 'Var's being resolved to+-- a 'Name' which is basically the same, but it has a /different/ 'Unique', and that would cause the lookup+-- inside the 'NameSet' to fail.+newtype StableName =+ MkStableName { unStableName :: Name }+ deriving Generic++instance Show StableName where+ show (MkStableName n) = nameStableString n++instance Hashable StableName where+ hashWithSalt s (MkStableName n) = hashWithSalt s (nameStableString n)++instance Eq StableName where+ (MkStableName n1) == (MkStableName n2) = -- n1 `stableNameCmp` n2 == EQ+ let sameOccName = occNameString (nameOccName n1) == occNameString (nameOccName n2)+ sameModule = nameModule n1 == nameModule n2+ sameSrcLoc = nameSrcLoc n1 == nameSrcLoc n2+ sameSrcSpan = nameSrcSpan n1 == nameSrcSpan n2+ in sameOccName && sameModule && sameSrcLoc && sameSrcSpan++-- | Creates a new 'StableName' out of a 'Name'.+mkStableName :: Name -> StableName+mkStableName = MkStableName++-- | Converts a list of 'AvailInfo' into a \"StableNameSet\", similarly to what 'availsToNameSet' would do.+availsToStableNameSet :: [AvailInfo] -> HashSet StableName+availsToStableNameSet avails = foldr add mempty avails+ where add av acc = acc <> fromList (map mkStableName (availNames av))++--------------------------------------------------------------------------------+-- | Datatype For Holding GHC ModGuts ------------------------------------------+--------------------------------------------------------------------------------+data MGIModGuts = MI+ { mgi_binds :: !CoreProgram+ , mgi_module :: !Module+ , mgi_tcs :: ![TyCon]+ , mgi_exports :: !(HashSet StableName)+ , mgi_cls_inst :: !(Maybe [ClsInst])+ }++miModGuts :: Maybe [ClsInst] -> ModGuts -> MGIModGuts+miModGuts cls mg = MI+ { mgi_binds = mg_binds mg+ , mgi_module = mg_module mg+ , mgi_tcs = mg_tcs mg+ , mgi_exports = availsToStableNameSet $ mg_exports mg+ , mgi_cls_inst = cls+ }++mgiNamestring :: MGIModGuts -> String+mgiNamestring = moduleNameString . moduleName . mgi_module
+ src/Language/Haskell/Liquid/LawInstances.hs view
@@ -0,0 +1,101 @@+{-# 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
@@ -0,0 +1,197 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-@ LIQUID "--diff" @-}++module Language.Haskell.Liquid.Liquid (+ -- * Checking a single module+ checkTargetInfo+ ) where++import Prelude hiding (error)+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 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 Language.Fixpoint.Solver+import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.UX.Errors+import Language.Haskell.Liquid.UX.CmdLine+import Language.Haskell.Liquid.UX.Tidy+import Language.Haskell.Liquid.GHC.Misc (showCBs, ignoreCoreBinds) -- howPpr)+import Language.Haskell.Liquid.Constraint.Generate+import Language.Haskell.Liquid.Constraint.ToFixpoint+import Language.Haskell.Liquid.Constraint.Types+import Language.Haskell.Liquid.UX.Annotate (mkOutput)+import qualified Language.Haskell.Liquid.Termination.Structural as ST+import qualified Language.Haskell.Liquid.GHC.Misc as GM+import Liquid.GHC.API as GHC hiding (text, vcat, ($+$), (<+>))++--------------------------------------------------------------------------------+checkTargetInfo :: TargetInfo -> IO (Output Doc)+--------------------------------------------------------------------------------+checkTargetInfo info = do+ out <- check+ unless (compileSpec cfg) $ DC.saveResult tgt out+ pure out+ where+ check :: IO (Output Doc)+ check+ | compileSpec cfg = do+ -- 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'+ edcs <- newPrune cfg cbs' tgt info+ liquidQueries cfg tgt info edcs++ cfg :: Config+ cfg = getConfig info++ tgt :: FilePath+ tgt = giTarget (giSrc info)++ cbs' :: [CoreBind]+ cbs' = giCbs (giSrc info)++newPrune :: Config -> [CoreBind] -> FilePath -> TargetInfo -> IO (Either [CoreBind] [DC.DiffCheck])+newPrune cfg cbs tgt info+ | not (null vs) = return . Right $ [DC.thin cbs sp vs]+ | timeBinds cfg = return . Right $ [DC.thin cbs sp [v] | v <- expVars]+ | diffcheck cfg = maybeEither cbs <$> DC.slice tgt cbs sp+ | otherwise = return $ Left (ignoreCoreBinds ignores cbs)+ where+ ignores = gsIgnoreVars (gsVars sp)+ vs = gsTgtVars (gsVars sp)+ sp = giSpec info+ expVars = exportedVars (giSrc info)++exportedVars :: TargetSrc -> [Var]+exportedVars src = filter (isExportedVar src) (giDefVars src)++maybeEither :: a -> Maybe b -> Either a [b]+maybeEither d Nothing = Left d+maybeEither _ (Just x) = Right [x]++liquidQueries :: Config -> FilePath -> TargetInfo -> Either [CoreBind] [DC.DiffCheck] -> IO (Output Doc)+liquidQueries cfg tgt info (Left cbs')+ = liquidQuery cfg tgt info (Left cbs')+liquidQueries cfg tgt info (Right dcs)+ = mconcat <$> mapM (liquidQuery cfg tgt info . Right) dcs++liquidQuery :: Config -> FilePath -> TargetInfo -> Either [CoreBind] DC.DiffCheck -> IO (Output Doc)+liquidQuery cfg tgt info edc = do+ let names = either (const Nothing) (Just . map show . DC.checkedVars) edc+ let oldOut = either (const mempty) DC.oldOutput edc+ let info1 = either (const info) (\z -> info {giSpec = DC.newSpec z}) edc+ let cbs'' = either id DC.newBinds edc+ let info2 = info1 { giSrc = (giSrc info1) {giCbs = cbs''}}+ let info3 = updTargetInfoTermVars info2 + let cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info3 + when False (dumpCs cgi)+ -- whenLoud $ mapM_ putStrLn [ "****************** CGInfo ********************"+ -- , render (pprint cgi) ]+ out <- timedAction names $ solveCs cfg tgt cgi info3 names+ return $ mconcat [oldOut, out]++updTargetInfoTermVars :: TargetInfo -> TargetInfo +updTargetInfoTermVars i = updInfo i (ST.terminationVars i) + where + updInfo info vs = info { giSpec = updSpec (giSpec info) vs }+ updSpec sp vs = sp { gsTerm = updSpTerm (gsTerm sp) vs }+ updSpTerm gsT vs = gsT { gsNonStTerm = S.fromList vs } + +dumpCs :: CGInfo -> IO ()+dumpCs cgi = do+ putStrLn "***************************** SubCs *******************************"+ putStrLn $ render $ pprintMany (hsCs cgi)+ putStrLn "***************************** FixCs *******************************"+ putStrLn $ render $ pprintMany (fixCs cgi)+ putStrLn "***************************** WfCs ********************************"+ putStrLn $ render $ pprintMany (hsWfs cgi)++pprintMany :: (PPrint a) => [a] -> Doc+pprintMany xs = vcat [ F.pprint x $+$ text " " | x <- xs ]++solveCs :: Config -> FilePath -> CGInfo -> TargetInfo -> Maybe [String] -> IO (Output Doc)+solveCs cfg tgt cgi info names = do+ finfo <- cgInfoFInfo info cgi+ let fcfg = fixConfig tgt cfg+ F.Result {resStatus=r0, resSolution=sol} <- solve fcfg finfo+ let failBs = gsFail $ gsTerm $ giSpec info+ let (r,rf) = splitFails (S.map val failBs) r0 + let resErr = second (applySolution sol . cinfoError) <$> r+ -- resModel_ <- fmap (e2u cfg sol) <$> getModels info cfg resErr+ let resModel_ = cidE2u cfg sol <$> resErr+ let resModel' = resModel_ `addErrors` (e2u cfg sol <$> logErrors cgi)+ `addErrors` makeFailErrors (S.toList failBs) rf + `addErrors` makeFailUseErrors (S.toList failBs) (giCbs $ giSrc info)+ let lErrors = applySolution sol <$> logErrors cgi+ let resModel = resModel' `addErrors` (e2u cfg sol <$> lErrors)+ let out0 = mkOutput cfg resModel sol (annotMap cgi)+ return $ out0 { o_vars = names }+ { o_result = resModel }+++e2u :: Config -> F.FixSolution -> Error -> UserError+e2u cfg s = fmap F.pprint . tidyError cfg s++cidE2u :: Config -> F.FixSolution -> (Integer, Error) -> UserError+cidE2u cfg s (subcId, e) =+ let e' = attachSubcId e+ in fmap F.pprint (tidyError cfg s e')+ where+ attachSubcId es@ErrSubType{} = es { cid = Just subcId }+ attachSubcId es@ErrSubTypeModel{} = es { cid = Just subcId }+ attachSubcId es = es++-- writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str+-- where+-- str = {-# SCC "PPcgi" #-} showpp cgi+++makeFailUseErrors :: [F.Located Var] -> [CoreBind] -> [UserError]+makeFailUseErrors fbs cbs = [ mkError x bs | x <- fbs+ , let bs = clients (val x)+ , not (null bs) ] + where + mkError x bs = ErrFailUsed (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (pprint <$> bs)+ clients x = map fst $ filter (elem x . snd) allClients++ allClients = concatMap go cbs ++ go :: CoreBind -> [(Var,[Var])]+ go (NonRec x e) = [(x, readVars e)] + go (Rec xes) = [(x,cls) | x <- map fst xes] where cls = concatMap readVars (snd <$> xes)++makeFailErrors :: [F.Located Var] -> [Cinfo] -> [UserError]+makeFailErrors bs cis = [ mkError x | x <- bs, notElem (val x) vs ] + where + mkError x = ErrFail (GM.sourcePosSrcSpan $ loc x) (pprint $ val x)+ vs = Mb.mapMaybe ci_var cis++splitFails :: S.HashSet Var -> F.FixResult (a, Cinfo) -> (F.FixResult (a, Cinfo), [Cinfo])+splitFails _ r@(F.Crash _ _) = (r,mempty)+splitFails _ r@(F.Safe _) = (r,mempty)+splitFails fs (F.Unsafe s xs) = (mkRes r, snd <$> rfails)+ where + (rfails,r) = L.partition (Mb.maybe False (`S.member` fs) . ci_var . snd) xs + mkRes [] = F.Safe s+ mkRes ys = F.Unsafe s ys ++
+ src/Language/Haskell/Liquid/Measure.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Measure (+ -- * Specifications+ Spec (..)+ , MSpec (..)++ -- * Type Aliases+ , BareSpec+ , BareMeasure+ , SpecMeasure++ -- * Constructors+ , mkM, mkMSpec, mkMSpec'+ , dataConTypes+ , defRefType+ , bodyPred+ ) where++import GHC hiding (Located)+import Prelude hiding (error)+import Text.PrettyPrint.HughesPJ hiding ((<>))+-- import Data.Binary as B+-- import GHC.Generics+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import qualified Data.Maybe as Mb -- (fromMaybe, isNothing)++import Language.Fixpoint.Misc+import Language.Fixpoint.Types 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.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.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 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' ms = MSpec cm mm M.empty []+ where+ cm = groupMap (symbol . 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+ 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+++checkDuplicateMeasure :: [Measure ty ctor] -> [Measure ty ctor]+checkDuplicateMeasure measures+ = case M.toList dups of+ [] -> measures+ (m,ms):_ -> uError $ mkError m (msName <$> ms)+ where+ gms = group [(msName m , m) | m <- measures]+ dups = M.filter ((1 <) . length) gms+ mkError m ms = ErrDupMeas (fSrcSpan m) (pprint (val m)) (fSrcSpan <$> ms)+++dataConTypes :: Bool -> MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)])+dataConTypes allowTC s = (ctorTys, measTys)+ where+ measTys = [(msName m, msSort m) | m <- M.elems (measMap s) ++ imeas s]+ ctorTys = concatMap (makeDataConType allowTC) (notracepp "HOHOH" . snd <$> M.toList (ctorMap s))++makeDataConType :: Bool -> [Def (RRType Reft) DataCon] -> [(Var, RRType Reft)]+makeDataConType _ []+ = []+makeDataConType allowTC ds | Mb.isNothing (dataConWrapId_maybe dc)+ = notracepp _msg [(woId, notracepp _msg $ combineDCTypes "cdc0" t ts)]+ where+ dc = ctor (head ds)+ woId = dataConWorkId dc+ t = varType woId+ ts = defRefType allowTC t <$> ds+ _msg = "makeDataConType0" ++ showpp (woId, t, ts)++makeDataConType allowTC ds+ = [(woId, extend allowTC loci woRType wrRType), (wrId, extend allowTC loci wrRType woRType)]+ where+ (wo, wr) = L.partition isWorkerDef ds+ dc = ctor $ head ds+ loci = loc $ measure $ head ds+ woId = dataConWorkId dc+ wot = varType woId+ wrId = dataConWrapId dc+ wrt = varType wrId+ wots = defRefType allowTC wot <$> wo+ wrts = defRefType allowTC wrt <$> wr++ wrRType = combineDCTypes "cdc1" wrt wrts+ woRType = combineDCTypes "cdc2" wot wots+++ isWorkerDef def+ -- types are missing for arguments, so definition came from a logical measure+ -- and it is for the worker datacon+ | any Mb.isNothing (snd <$> binds def)+ = True+ | otherwise+ = length (binds def) == length (fst $ splitFunTys $ snd $ splitForAllTyCoVars wot)+++extend :: Bool+ -> SourcePos+ -> RType RTyCon RTyVar Reft+ -> RRType Reft+ -> RType RTyCon RTyVar Reft+extend allowTC lc t1' t2+ | Just su <- mapArgumens allowTC lc t1 t2+ = t1 `strengthenResult` subst su (Mb.fromMaybe mempty (stripRTypeBase $ resultTy t2))+ | otherwise+ = t1+ where+ t1 = noDummySyms t1'+++resultTy :: RType c tv r -> RType c tv r+resultTy = ty_res . toRTypeRep++strengthenResult :: Reftable r => RType c tv r -> r -> RType c tv r+strengthenResult t r = fromRTypeRep $ rep {ty_res = ty_res rep `strengthen` r}+ where+ rep = toRTypeRep t+++noDummySyms :: (OkRT c tv r) => RType c tv r -> RType c tv r+noDummySyms t+ | any isDummy (ty_binds rep)+ = subst su $ fromRTypeRep $ rep{ty_binds = xs'}+ | otherwise+ = t+ where+ rep = toRTypeRep t+ xs' = zipWith (\_ i -> symbol ("x" ++ show i)) (ty_binds rep) [(1::Int)..]+ su = mkSubst $ zip (ty_binds rep) (EVar <$> xs')++combineDCTypes :: String -> Type -> [RRType Reft] -> RRType Reft+combineDCTypes _msg t ts = L.foldl' strengthenRefTypeGen (ofType t) ts++mapArgumens :: Bool -> SourcePos -> RRType Reft -> RRType Reft -> Maybe Subst+mapArgumens allowTC lc t1 t2 = go xts1' xts2'+ where+ xts1 = zip (ty_binds rep1) (ty_args rep1)+ xts2 = zip (ty_binds rep2) (ty_args rep2)+ rep1 = toRTypeRep t1+ rep2 = toRTypeRep t2++ xts1' = dropWhile canDrop xts1+ xts2' = dropWhile canDrop xts2++ canDrop (_, t) = if allowTC then isEmbeddedClass t else isClassType t || isEqType t++ go xs ys+ | length xs == length ys && and (zipWith (==) (toRSort . snd <$> xts1') (toRSort . snd <$> xts2'))+ = Just $ mkSubst $ zipWith (\y x -> (fst x, EVar $ fst y)) xts1' xts2'+ | otherwise+ = panic (Just $ sourcePosSrcSpan lc) ("The types for the wrapper and worker data constructors cannot be merged\n"+ ++ show t1 ++ "\n" ++ show t2 )++-- should constructors have implicits? probably not+defRefType :: Bool -> Type -> Def (RRType Reft) DataCon -> RRType Reft+defRefType allowTC tdc (Def f dc mt xs body)+ = generalize $ mkArrow as' [] xts t'+ where+ xts = stitchArgs allowTC (fSrcSpan f) dc xs ts+ t' = refineWithCtorBody dc f body t+ t = Mb.fromMaybe (ofType tr) mt+ (αs, ts, tr) = splitType tdc+ as = if Mb.isJust mt then [] else makeRTVar . rTyVar <$> αs+ as' = map (, mempty) as++splitType :: Type -> ([TyVar],[Type], Type)+splitType t = (αs, map irrelevantMult ts, tr)+ where+ (αs, tb) = splitForAllTyCoVars t+ (ts, tr) = splitFunTys tb++stitchArgs :: (Monoid t1, PPrint a)+ => Bool+ -> SrcSpan+ -> a+ -> [(Symbol, Maybe (RRType Reft))]+ -> [Type]+ -> [(Symbol, RFInfo, RRType Reft, t1)]+stitchArgs allowTC sp dc allXs allTs+ | nXs == nTs = (g (dummySymbol, Nothing) . ofType <$> pts)+ ++ zipWith g xs (ofType <$> ts)+ | otherwise = panicFieldNumMismatch sp dc nXs nTs+ where+ (pts, ts) = L.partition (\t -> notracepp ("isPredTy: " ++ showpp t) $ (if allowTC then isEmbeddedDictType else Ghc.isEvVarType ) t) allTs+ (_ , xs) = L.partition (coArg . snd) allXs+ nXs = length xs+ nTs = length ts+ g (x, Just t) _ = (x, classRFInfo allowTC, t, mempty)+ g (x, _) t = (x, classRFInfo allowTC, t, mempty)+ coArg Nothing = False+ coArg (Just t) = (if allowTC then isEmbeddedDictType else Ghc.isEvVarType ). toType False $ t++panicFieldNumMismatch :: (PPrint a, PPrint a1, PPrint a3)+ => SrcSpan -> a3 -> a1 -> a -> a2+panicFieldNumMismatch sp dc nXs nTs = panicDataCon sp dc msg+ where+ msg = "Requires" <+> pprint nTs <+> "fields but given" <+> pprint nXs++panicDataCon :: PPrint a1 => SrcSpan -> a1 -> Doc -> a+panicDataCon sp dc d+ = panicError $ ErrDataCon sp (pprint dc) d++refineWithCtorBody :: Outputable a+ => a+ -> LocSymbol+ -> 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)+ Nothing ->+ panic Nothing $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc+++bodyPred :: Expr -> Body -> Expr+bodyPred fv (E e) = PAtom Eq fv e+bodyPred fv (P p) = PIff fv p+bodyPred fv (R v' p) = subst1 p (v', fv)
+ src/Language/Haskell/Liquid/Misc.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DoAndIfThenElse #-}++module Language.Haskell.Liquid.Misc where++import Prelude hiding (error)+import Control.Monad.State++import Control.Arrow (first)+import System.FilePath+import System.Directory (getModificationTime, doesFileExist)+import System.Environment (getExecutablePath)++import qualified Control.Exception as Ex --(evaluate, catch, IOException)+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import Data.Maybe+import Data.Tuple+import Data.Hashable+import Data.Time+import Data.Function (on)+import qualified Data.ByteString as B+import Data.ByteString.Char8 (pack, unpack)+import qualified Text.PrettyPrint.HughesPJ as PJ -- (char, Doc)+import Text.Printf+import Language.Fixpoint.Misc+import Paths_liquidhaskell_boot++type Nat = Int++(.&&.), (.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool+(.&&.) = up (&&)+(.||.) = up (||)++up :: (b -> c -> d) -> (a -> b) -> (a -> c) -> (a -> d)+up o f g x = f x `o` g x++timedAction :: (Show msg) => Maybe msg -> IO a -> IO a+timedAction label io = do+ t0 <- getCurrentTime+ a <- io+ t1 <- getCurrentTime+ let time = realToFrac (t1 `diffUTCTime` t0) :: Double+ case label of+ Just x -> printf "Time (%.2fs) for action %s \n" time (show x)+ Nothing -> return ()+ return a++(!?) :: [a] -> Int -> Maybe a+[] !? _ = Nothing+(x:_) !? 0 = Just x+(_:xs) !? n = xs !? (n-1)++safeFromJust :: String -> Maybe t -> t+safeFromJust _ (Just x) = x+safeFromJust err _ = errorstar err++safeFromLeft :: String -> Either a b -> a+safeFromLeft _ (Left l) = l+safeFromLeft err _ = errorstar err+++takeLast :: Int -> [a] -> [a]+takeLast n xs = drop (m - n) xs+ where+ m = length xs++getNth :: Int -> [a] -> Maybe a+getNth 0 (x:_) = Just x+getNth n (_:xs) = getNth (n-1) xs+getNth _ _ = Nothing++fst4 :: (t, t1, t2, t3) -> t+fst4 (a,_,_,_) = a++snd4 :: (t, t1, t2, t3) -> t1+snd4 (_,b,_,_) = b++thd4 :: (t1, t2, t3, t4) -> t3+thd4 (_,_,b,_) = b+++thrd3 :: (t1, t2, t3) -> t3+thrd3 (_,_,c) = c++mapFifth5 :: (t -> t4) -> (t0, t1, t2, t3, t) -> (t0, t1, t2, t3, t4)+mapFifth5 f (a, x, y, z, w) = (a, x, y, z, f w)++mapFourth4 :: (t -> t4) -> (t1, t2, t3, t) -> (t1, t2, t3, t4)+mapFourth4 f (x, y, z, w) = (x, y, z, f w)++addFst3 :: t -> (t1, t2) -> (t, t1, t2)+addFst3 a (b, c) = (a, b, c)++addThd3 :: t2 -> (t, t1) -> (t, t1, t2)+addThd3 c (a, b) = (a, b, c)++dropFst3 :: (t, t1, t2) -> (t1, t2)+dropFst3 (_, x, y) = (x, y)++dropThd3 :: (t1, t2, t) -> (t1, t2)+dropThd3 (x, y, _) = (x, y)++replaceN :: (Enum a, Eq a, Num a) => a -> t -> [t] -> [t]+replaceN n y ls = [if i == n then y else x | (x, i) <- zip ls [0..]]+++thd5 :: (t0, t1, t2, t3, t4) -> t2+thd5 (_,_,x,_,_) = x++snd5 :: (t0, t1, t2, t3, t4) -> t1+snd5 (_,x,_,_,_) = x++fst5 :: (t0, t1, t2, t3, t4) -> t0+fst5 (x,_,_,_,_) = x++fourth4 :: (t, t1, t2, t3) -> t3+fourth4 (_,_,_,x) = x++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++secondM :: Functor f => (t -> f a) -> (t1, t) -> f (t1, a)+secondM f (a,b) = (a,) <$> f b++first3M :: Functor f => (t -> f a) -> (t, t1, t2) -> f (a, t1, t2)+first3M f (a,b,c) = (,b,c) <$> f a++second3M :: Functor f => (t -> f a) -> (t1, t, t2) -> f (t1, a, t2)+second3M f (a,b,c) = (a,,c) <$> f b++third3M :: Functor f => (t -> f a) -> (t1, t2, t) -> f (t1, t2, a)+third3M f (a,b,c) = (a,b,) <$> f c++third3 :: (t -> t3) -> (t1, t2, t) -> (t1, t2, t3)+third3 f (a,b,c) = (a,b,f c)++zip4 :: [t] -> [t1] -> [t2] -> [t3] -> [(t, t1, t2, t3)]+zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : zip4 xs1 xs2 xs3 xs4+zip4 _ _ _ _ = []++zip5 :: [t] -> [t1] -> [t2] -> [t3] -> [t4] -> [(t, t1, t2, t3, t4)]+zip5 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) (x5:xs5) = (x1, x2, x3, x4,x5) : zip5 xs1 xs2 xs3 xs4 xs5+zip5 _ _ _ _ _ = []++++unzip4 :: [(t, t1, t2, t3)] -> ([t],[t1],[t2],[t3])+unzip4 = go [] [] [] []+ where go a1 a2 a3 a4 ((x1,x2,x3,x4):xs) = go (x1:a1) (x2:a2) (x3:a3) (x4:a4) xs+ go a1 a2 a3 a4 [] = (reverse a1, reverse a2, reverse a3, reverse a4)+++getCssPath :: IO FilePath+getCssPath = getDataFileName $ "syntax" </> "liquid.css"++getCoreToLogicPath :: IO FilePath+getCoreToLogicPath = do+ let fileName = "CoreToLogic.lg"++ -- Try to find it first at executable path+ exePath <- dropFileName <$> getExecutablePath+ let atExe = exePath </> fileName+ exists <- doesFileExist atExe++ if exists then+ return atExe+ else+ getDataFileName ("include" </> fileName)++{-@ type ListN a N = {v:[a] | len v = N} @-}+{-@ type ListL a L = ListN a (len L) @-}++zipMaybe :: [a] -> [b] -> Maybe [(a, b)]+zipMaybe xs ys+ | length xs == length ys = Just (zip xs ys)+ | otherwise = Nothing++{-@ safeZipWithError :: _ -> xs:[a] -> ListL b xs -> ListL (a,b) xs / [xs] @-}+safeZipWithError :: String -> [t] -> [t1] -> [(t, t1)]+safeZipWithError msg (x:xs) (y:ys) = (x,y) : safeZipWithError msg xs ys+safeZipWithError _ [] [] = []+safeZipWithError msg _ _ = errorstar msg++safeZip3WithError :: String -> [t] -> [t1] -> [t2] -> [(t, t1, t2)]+safeZip3WithError msg (x:xs) (y:ys) (z:zs) = (x,y,z) : safeZip3WithError msg xs ys zs+safeZip3WithError _ [] [] [] = []+safeZip3WithError msg _ _ _ = errorstar msg++safeZip4WithError :: String -> [t1] -> [t2] -> [t3] -> [t4] -> [(t1, t2, t3, t4)]+safeZip4WithError msg (x:xs) (y:ys) (z:zs) (w:ws) = (x,y,z,w) : safeZip4WithError msg xs ys zs ws+safeZip4WithError _ [] [] [] [] = []+safeZip4WithError msg _ _ _ _ = errorstar msg+++mapNs :: (Eq a, Num a, Foldable t) => t a -> (a1 -> a1) -> [a1] -> [a1]+mapNs ns f xs = foldl (\ys n -> mapN n f ys) xs ns++mapN :: (Eq a, Num a) => a -> (a1 -> a1) -> [a1] -> [a1]+mapN 0 f (x:xs) = f x : xs+mapN n f (x:xs) = x : mapN (n-1) f xs+mapN _ _ [] = []++zipWithDefM :: Monad m => (a -> a -> m a) -> [a] -> [a] -> m [a]+zipWithDefM _ [] [] = return []+zipWithDefM _ xs [] = return xs+zipWithDefM _ [] ys = return ys+zipWithDefM f (x:xs) (y:ys) = (:) <$> f x y <*> zipWithDefM f xs ys++zipWithDef :: (a -> a -> a) -> [a] -> [a] -> [a]+zipWithDef _ [] [] = []+zipWithDef _ xs [] = xs+zipWithDef _ [] ys = ys+zipWithDef f (x:xs) (y:ys) = f x y : zipWithDef f xs ys+++--------------------------------------------------------------------------------+-- Originally part of Fixpoint's Misc:+--------------------------------------------------------------------------------++single :: t -> [t]+single x = [x]++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)++hashMapMapWithKey :: (k -> v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2+hashMapMapWithKey f = fromJust . M.traverseWithKey (\k v -> Just (f k v))++hashMapMapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> M.HashMap k1 v -> M.HashMap k2 v+hashMapMapKeys f = M.fromList . fmap (first f) . M.toList++concatMapM :: (Monad m, Traversable t) => (a -> m [b]) -> t a -> m [b]+concatMapM f = fmap concat . mapM f++replaceSubset :: (Eq k, Hashable k) => [(k, a)] -> [(k, a)] -> [(k, a)]+replaceSubset kvs kvs' = M.toList (L.foldl' upd m0 kvs')+ where+ m0 = M.fromList kvs+ upd m (k, v')+ | M.member k m = M.insert k v' m+ | otherwise = m++replaceWith :: (Eq a, Hashable a) => (b -> a) -> [b] -> [b] -> [b]+replaceWith f xs ys = snd <$> replaceSubset xs' ys'+ where+ xs' = [ (f x, x) | x <- xs ]+ ys' = [ (f y, y) | y <- ys ]+++++firstElems :: [(B.ByteString, B.ByteString)] -> B.ByteString -> Maybe (Int, B.ByteString, (B.ByteString, B.ByteString))+firstElems seps str+ = case splitters seps str of+ [] -> Nothing+ is -> Just $ L.minimumBy (compare `on` fst3) is++splitters :: [(B.ByteString, t)]+ -> B.ByteString -> [(Int, t, (B.ByteString, B.ByteString))]+splitters seps str+ = [(i, c', z) | (c, c') <- seps+ , let z = B.breakSubstring c str+ , let i = B.length (fst z)+ , i < B.length str ]++bchopAlts :: [(B.ByteString, B.ByteString)] -> B.ByteString -> [B.ByteString]+bchopAlts seps = go+ where+ go s = maybe [s] go' (firstElems seps s)+ go' (_,c',(s0, s1)) = if B.length s2 == B.length s1 then [B.concat [s0,s1]] else s0 : s2' : go s3'+ where (s2, s3) = B.breakSubstring c' s1+ s2' = B.append s2 c'+ s3' = B.drop (B.length c') s3++chopAlts :: [(String, String)] -> String -> [String]+chopAlts seps str = unpack <$> bchopAlts [(pack c, pack c') | (c, c') <- seps] (pack str)++sortDiff :: (Ord a) => [a] -> [a] -> [a]+sortDiff x1s x2s = go (sortNub x1s) (sortNub x2s)+ where+ go xs@(x:xs') ys@(y:ys')+ | x < y = x : go xs' ys+ | x == y = go xs' ys'+ | otherwise = go xs ys'+ go xs [] = xs+ go [] _ = []++(<->) :: PJ.Doc -> PJ.Doc -> PJ.Doc+x <-> y = x PJ.<> y++angleBrackets :: PJ.Doc -> PJ.Doc+angleBrackets p = PJ.char '<' <-> p <-> PJ.char '>'++mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> M.HashMap a (S.HashSet b)+mkGraph = fmap S.fromList . group++tryIgnore :: String -> IO () -> IO ()+tryIgnore s a =+ Ex.catch a $ \e -> do+ let err = show (e :: Ex.IOException)+ writeLoud ("Warning: Couldn't do " ++ s ++ ": " ++ err)+ return ()+++condNull :: Monoid m => Bool -> m -> m+condNull c xs = if c then xs else mempty++firstJust :: (a -> Maybe b) -> [a] -> Maybe b+firstJust f xs = listToMaybe $ mapMaybe f xs++intToString :: Int -> String+intToString 1 = "1st"+intToString 2 = "2nd"+intToString 3 = "3rd"+intToString n = show n ++ "th"++mapAccumM :: (Monad m, Traversable t) => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c)+mapAccumM f acc0 xs =+ swap <$> runStateT (traverse (StateT . (\x acc -> swap <$> f acc x)) xs) acc0++ifM :: (Monad m) => m Bool -> m b -> m b -> m b+ifM b x y = b >>= \z -> if z then x else y++nubHashOn :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a]+nubHashOn f = map head . M.elems . groupMap f++nubHashLast :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a]+nubHashLast f xs = M.elems $ M.fromList [ (f x, x) | x <- xs ]++nubHashLastM :: (Eq k, Hashable k, Monad m) => (a -> m k) -> [a] -> m [a]+nubHashLastM f xs = M.elems . M.fromList . (`zip` xs) <$> mapM f xs++uniqueByKey :: (Eq k, Hashable k) => [(k, v)] -> Either (k, [v]) [v]+uniqueByKey = uniqueByKey' tx+ where+ tx (_, [v]) = Right v+ tx (k, vs) = Left (k, vs)++uniqueByKey' :: (Eq k, Hashable k) => ((k, [v]) -> Either e v) -> [(k, v)] -> Either e [v]+uniqueByKey' tx = mapM tx . groupList+++join :: (Eq b, Hashable b) => [(a, b)] -> [(b, c)] -> [(a, c)]+join aBs bCs = [ (a, c) | (a, b) <- aBs, c <- b2cs b ]+ where+ bM = M.fromList bCs+ b2cs b = maybeToList (M.lookup b bM)+++fstByRank :: (Ord r, Hashable k, Eq k) => [(r, k, v)] -> [(r, k, v)]+fstByRank rkvs = [ (r, k, v) | (k, rvs) <- krvss, let (r, v) = getFst rvs ]+ where+ getFst = head . sortOn fst+ krvss = groupList [ (k, (r, v)) | (r, k, v) <- rkvs ]++sortOn :: (Ord b) => (a -> b) -> [a] -> [a]+sortOn f = L.sortBy (compare `on` f)++firstGroup :: (Eq k, Ord k, Hashable k) => [(k, a)] -> [a]+firstGroup kvs = case groupList kvs of+ [] -> []+ kvss -> snd . head . sortOn fst $ kvss++{- mapEither :: (a -> Either b c) -> [a] -> ([b], [c])+mapEither f [] = ([], [])+mapEither f (x:xs) = case f x of+ Left y -> (y:ys, zs)+ Right z -> (ys, z:zs)+ where+ (ys, zs) = mapEither f xs+-}+mapErr :: (a -> Either e b) -> [a] -> Either [e] [b]+mapErr f xs = catEithers (map f xs)++catEithers :: [ Either a b ] -> Either [a] [b]+catEithers zs = case ls of+ [] -> Right rs+ _ -> Left ls+ where+ ls = [ l | Left l <- zs ]+ rs = [ r | Right r <- zs ]+++keyDiff :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a] -> [a]+keyDiff f x1s x2s = M.elems (M.difference (m x1s) (m x2s))+ where+ m xs = M.fromList [(f x, x) | x <- xs]++concatUnzip :: [([a], [b])] -> ([a], [b])+concatUnzip xsyss = (concatMap fst xsyss, concatMap snd xsyss)+++sayReadFile :: FilePath -> IO String+sayReadFile f = do+ -- print ("SAY-READ-FILE: " ++ f)+ res <- readFile f+ Ex.evaluate res++lastModified :: FilePath -> IO (Maybe UTCTime)+lastModified f = do+ ex <- doesFileExist f+ if ex then Just <$> getModificationTime f+ else return Nothing+++data Validate e a = Err e | Val a++instance Functor (Validate e) where+ fmap _ (Err e) = Err e+ fmap f (Val v) = Val (f v)++instance Monoid e => Applicative (Validate e) where+ pure = Val+ (Err e1) <*> Err e2 = Err (e1 <> e2)+ (Err e1) <*> _ = Err e1+ _ <*> Err e2 = Err e2+ (Val f) <*> Val x = Val (f x)
+ src/Language/Haskell/Liquid/Parse.hs view
@@ -0,0 +1,1742 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Haskell.Liquid.Parse+ ( hsSpecificationP+ , specSpecificationP+ , singleSpecP+ , BPspec+ , Pspec(..)+ , parseSymbolToLogic+ , parseTest'+ )+ where++import Control.Arrow (second)+import Control.Monad+import Control.Monad.Identity+import qualified Data.Foldable as F+import Data.String+import Data.Void+import Prelude hiding (error)+import Text.Megaparsec hiding (ParseError)+import Text.Megaparsec.Char+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.Data+import qualified Data.Maybe as Mb -- (isNothing, fromMaybe)+import Data.Char (isSpace, isAlphaNum)+import Data.List (foldl', 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 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 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 =+ case go ([], []) initPStateWithList specComments of+ ([], specs) ->+ Right $ mkSpec (ModName SrcImport modName) (specs ++ specQuotes)+ (errors, _) ->+ Left errors+ where+ go :: ([Error], [BPspec]) -- accumulated errors and parsed specs (in reverse order)+ -> PState -- parser state (primarily infix operator priorities)+ -> [(SourcePos, String)] -- remaining unparsed spec comments+ -> ([Error], [BPspec]) -- final errors and parsed specs+ go (errors, specs) _ []+ = (reverse errors, reverse specs)+ go (errors, specs) pstate ((pos, specComment):xs)+ = -- 'specP' parses a single spec comment, i.e., a single LH directive+ -- we allow a "block" of specs now+ case parseWithError pstate (block specP) pos specComment of+ Left err' -> go (parseErrorBundleToErrors err' ++ errors, specs) pstate xs+ Right (st,spec) -> go (errors,spec ++ specs) st xs++initPStateWithList :: PState+initPStateWithList+ = (initPState composeFun)+ { empList = Just (EVar ("GHC.Types.[]" :: Symbol))+ , singList = Just (\e -> EApp (EApp (EVar ("GHC.Types.:" :: Symbol)) e) (EVar ("GHC.Types.[]" :: Symbol)))+ }+ 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)++-------------------------------------------------------------------------------+singleSpecP :: SourcePos -> String -> Either (ParseErrorBundle String Void) BPspec+-------------------------------------------------------------------------------+singleSpecP pos = mapRight snd . parseWithError initPStateWithList specP pos++mapRight :: (a -> b) -> Either l a -> Either l b+mapRight f (Right x) = Right $ f x+mapRight _ (Left x) = Left x++-- Note [PState in parser]+--+-- In the original parsec parser, 'PState' did not contain the supply counter.+-- The supply counter was separately initialised to 0 on every parser call, e.g.+-- in 'parseWithError'.+--+-- Now, the supply counter is a part of 'PState' and would normally be threaded+-- between subsequent parsing calls within s single file, as for example issued+-- by 'hsSpecificationP'. This threading seems correct to me (Andres). It sounds+-- like we would want to have the same behaviour of the counter whether we are+-- parsing several separate specs or a single combined spec.+--+-- However, I am getting one test failure due to the threading change, namely+-- Tests.Micro.class-laws-pos.FreeVar.hs, because in a unification call two+-- variables occurring in a binding position do not match. This seems like a bug+-- in the unifier. I'm nevertheless reproucing the "old" supply behaviour for+-- now. This should be revisited later. TODO.++-- | Entry point for parsers.+--+-- Resets the supply in the given state to 0, see Note [PState in parser].+-- Also resets the layout stack, as different spec comments in a file can+-- 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 pstate parser p s =+ case snd (runIdentity (runParserT' (runStateT doParse pstate{supply = 0, layoutStack = Empty}) internalParserState)) of+ Left peb -> Left peb+ Right (r, st) -> Right (st, r)+ where+ doParse :: Parser a+ doParse = spaces *> parser <* eof+ internalParserState =+ State+ { stateInput = s+ , stateOffset = 0+ , statePosState =+ PosState+ { pstateInput = s+ , pstateOffset = 0+ , pstateSourcePos = p+ , pstateTabWidth = defaultTabWidth+ , pstateLinePrefix = ""+ }+ , stateParseErrors = []+ }++-- | Function to test parsers interactively.+parseTest' :: Show a => Parser a -> String -> IO ()+parseTest' parser input =+ parseTest (evalStateT parser initPStateWithList) input++parseErrorBundleToErrors :: ParseErrorBundle String Void -> [Error]+parseErrorBundleToErrors (ParseErrorBundle errors posState) =+ let+ (es, _) = attachSourcePos errorOffset errors posState+ in+ parseErrorError <$> F.toList es++---------------------------------------------------------------------------+parseErrorError :: (ParseError, SourcePos) -> Error+---------------------------------------------------------------------------+parseErrorError (e, pos) = ErrParse sp msg e+ where+ sp = sourcePosSrcSpan pos+ 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 -----------------------------------------------------------------+--------------------------------------------------------------------------------++{- | [NOTE:BARETYPE-PARSE] Fundamentally, a type is of the form++ comp -> comp -> ... -> comp++So++ bt = comp+ | comp '->' bt++ comp = circle+ | '(' bt ')'++ circle = the ground component of a baretype, sans parens or "->" at the top level++Each 'comp' should have a variable to refer to it,+either a parser-assigned one or given explicitly. e.g.++ xs : [Int]++-}++data ParamComp = PC { _pci :: PcScope+ , _pct :: BareType }+ deriving (Show)++data PcScope = PcImplicit Symbol+ | PcExplicit Symbol+ | PcNoSymbol+ deriving (Eq,Show)++nullPC :: BareType -> ParamComp+nullPC bt = PC PcNoSymbol bt++btP :: Parser ParamComp+btP = do+ c@(PC sb _) <- compP+ case sb of+ PcNoSymbol -> return c+ PcImplicit b -> parseFun c b+ PcExplicit b -> parseFun c b+ <?> "btP"+ where+ parseFun c@(PC sb t1) sym =+ (do+ reservedOp "->"+ PC _ t2 <- btP+ return (PC sb (rFun sym t1 t2)))+ <|>+ (do+ reservedOp "=>"+ PC _ t2 <- btP+ -- TODO:AZ return an error if s == PcExplicit+ return $ PC sb $ foldr (rFun dummySymbol) t2 (getClasses t1))+ <|>+ (do+ b <- locInfixSymbolP+ PC _ t2 <- btP+ return $ PC sb $ RApp (mkBTyCon b) [t1,t2] [] mempty)+ <|> return c+++compP :: Parser ParamComp+compP = circleP <|> parens btP <?> "compP"++circleP :: Parser ParamComp+circleP+ = nullPC <$> (reserved "forall" >> bareAllP)+ <|> holePC -- starts with '_'+ <|> namedCircleP -- starts with lower+ <|> bareTypeBracesP -- starts with '{'+ <|> unnamedCircleP+ <|> anglesCircleP -- starts with '<'+ <|> nullPC <$> dummyP bbaseP -- starts with '_' or '[' or '(' or lower or "'" or upper+ <?> "circleP"++anglesCircleP :: Parser ParamComp+anglesCircleP+ = angles $ do+ PC sb t <- parens btP+ p <- monoPredicateP+ return $ PC sb (t `strengthen` MkUReft mempty p)++holePC :: Parser ParamComp+holePC = do+ h <- holeP+ b <- dummyBindP+ return (PC (PcImplicit b) h)++namedCircleP :: Parser ParamComp+namedCircleP = do+ lb <- locLowerIdP+ do _ <- reservedOp ":"+ let b = val lb+ PC (PcExplicit b) <$> bareArgP b+ <|> do+ b <- dummyBindP+ PC (PcImplicit b) <$> dummyP (lowerIdTail (val lb))++unnamedCircleP :: Parser ParamComp+unnamedCircleP = do+ lb <- located dummyBindP+ let b = val lb+ t1 <- bareArgP b+ return $ PC (PcImplicit b) t1++-- ---------------------------------------------------------------------++-- | The top-level parser for "bare" refinement types. If refinements are+-- not supplied, then the default "top" refinement is used.++bareTypeP :: Parser BareType+bareTypeP = do+ PC _ v <- btP+ return v++bareTypeBracesP :: Parser ParamComp+bareTypeBracesP = do+ t <- try (braces (+ try (Right <$> constraintP)+ <|>+ (do+ x <- symbolP+ _ <- reservedOp ":"+ -- NOSUBST i <- freshIntP+ t <- bbaseP+ reservedOp "|"+ ra <- refasHoleP+ -- xi is a unique var based on the name in x.+ -- su replaces any use of x in the balance of the expression with the unique val+ -- NOSUBST let xi = intSymbol x i+ -- NOSUBST let su v = if v == x then xi else v+ return $ Left $ PC (PcExplicit x) $ t (Reft (x, ra)) )+ )) <|> try (helper holeOrPredsP) <|> helper predP+ case t of+ Left l -> return l+ Right ct -> do+ PC _sb tt <- btP+ return $ nullPC $ rrTy ct tt+ where+ holeOrPredsP+ = (reserved "_" >> return hole)+ <|> try (pAnd <$> brackets (sepBy predP semi))+ helper p = braces $ do+ t <- RHole . uTop . Reft . ("VV",) <$> p+ return (Left $ nullPC t)+++bareArgP :: Symbol -> Parser BareType+bareArgP vvv+ = refDefP vvv refasHoleP bbaseP -- starts with '{'+ <|> holeP -- starts with '_'+ <|> dummyP bbaseP+ <|> parens bareTypeP -- starts with '('+ -- starts with '_', '[', '(', lower, upper+ <?> "bareArgP"++bareAtomP :: (Parser Expr -> Parser (Reft -> BareType) -> Parser BareType)+ -> Parser BareType+bareAtomP ref+ = ref refasHoleP bbaseP+ <|> holeP+ <|> dummyP bbaseP+ <?> "bareAtomP"++bareAtomBindP :: Parser BareType+bareAtomBindP = bareAtomP refBindBindP+++-- Either+-- { x : t | ra }+-- or+-- { ra }+refBindBindP :: Parser Expr+ -> Parser (Reft -> BareType)+ -> Parser BareType+refBindBindP rp kindP'+ = braces (+ (do+ x <- symbolP+ _ <- reservedOp ":"+ -- NOSUBST i <- freshIntP+ t <- kindP'+ reservedOp "|"+ ra <- rp+ -- xi is a unique var based on the name in x.+ -- su replaces any use of x in the balance of the expression with the unique val+ -- NOSUBST let xi = intSymbol x i+ -- NOSUBST let su v = if v == x then xi else v+ return $ {- substa su $ NOSUBST -} t (Reft (x, ra)) )+ <|> (RHole . uTop . Reft . ("VV",) <$> rp)+ <?> "refBindBindP"+ )+++refDefP :: Symbol+ -> Parser Expr+ -> Parser (Reft -> BareType)+ -> Parser BareType+refDefP sym rp kindP' = braces $ do+ x <- optBindP sym+ -- NOSUBST i <- freshIntP+ t <- try (kindP' <* reservedOp "|") <|> return (RHole . uTop) <?> "refDefP"+ ra <- rp+ -- xi is a unique var based on the name in x.+ -- su replaces any use of x in the balance of the expression with the unique val+ -- NOSUBST let xi = intSymbol x i+ -- NOSUBST let su v = if v == x then xi else v+ return $ {- substa su $ NOSUBST -} t (Reft (x, ra))+ -- substa su . t . Reft . (x,) <$> (rp <* spaces))+ -- <|> ((RHole . uTop . Reft . ("VV",)) <$> (rp <* spaces))++refP :: Parser (Reft -> BareType) -> Parser BareType+refP = refBindBindP refaP++relrefaP :: Parser RelExpr+relrefaP =+ try (ERUnChecked <$> refaP <* reserved ":=>" <*> relrefaP)+ <|> try (ERChecked <$> refaP <* reserved "!=>" <*> relrefaP)+ <|> ERBasic <$> refaP++-- "sym :" or return the devault sym+optBindP :: Symbol -> Parser Symbol+optBindP x = try bindP <|> return x++holeP :: Parser BareType+holeP = reserved "_" >> return (RHole $ uTop $ Reft ("VV", hole))++holeRefP :: Parser (Reft -> BareType)+holeRefP = reserved "_" >> return (RHole . uTop)++-- NOPROP refasHoleP :: Parser Expr+-- NOPROP refasHoleP = try refaP+-- NOPROP <|> (reserved "_" >> return hole)++refasHoleP :: Parser Expr+refasHoleP+ = (reserved "_" >> return hole)+ <|> refaP+ <?> "refasHoleP"++bbaseP :: Parser (Reft -> BareType)+bbaseP+ = holeRefP -- Starts with '_'+ <|> liftM2 bLst (brackets (optional bareTypeP)) predicatesP+ <|> liftM2 bTup (parens $ sepBy (maybeBind bareTypeP) comma) predicatesP+ <|> try parseHelper -- starts with lower+ <|> liftM4 bCon bTyConP predicatesP (many bareTyArgP) mmonoPredicateP+ -- starts with "'" or upper case char+ <?> "bbaseP"+ where+ parseHelper = do+ l <- lowerIdP+ lowerIdTail l++maybeBind :: Parser a -> Parser (Maybe Symbol, a)+maybeBind parser = do {bd <- maybeP' bbindP; ty <- parser ; return (bd, ty)}+ where+ maybeP' p = try (Just <$> p)+ <|> return Nothing++lowerIdTail :: Symbol -> Parser (Reft -> BareType)+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))))+ <?> "bTyConP"++mkPromotedBTyCon :: LocSymbol -> BTyCon+mkPromotedBTyCon x = BTyCon x False True -- (consSym '\'' <$> x) False True++classBTyConP :: Parser BTyCon+classBTyConP = mkClassBTyCon <$> locUpperIdP++mkClassBTyCon :: LocSymbol -> BTyCon+mkClassBTyCon x = BTyCon x True False++bbaseNoAppP :: Parser (Reft -> BareType)+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+ <?> "bbaseNoAppP"++bareTyArgP :: Parser BareType+bareTyArgP+ = (RExprArg . fmap expr <$> locNatural)+ <|> try (braces $ RExprArg <$> located exprP)+ <|> try bareAtomNoAppP+ <|> try (parens bareTypeP)+ <?> "bareTyArgP"++bareAtomNoAppP :: Parser BareType+bareAtomNoAppP+ = refP bbaseNoAppP+ <|> dummyP bbaseNoAppP+ <?> "bareAtomNoAppP"+++constraintP :: Parser BareType+constraintP+ = do xts <- constraintEnvP+ t1 <- bareTypeP+ reservedOp "<:"+ fromRTypeRep . RTypeRep [] []+ ((val . fst <$> xts) ++ [dummySymbol])+ (replicate (length xts + 1) defRFInfo)+ (replicate (length xts + 1) mempty)+ ((snd <$> xts) ++ [t1]) <$> bareTypeP++constraintEnvP :: Parser [(LocSymbol, BareType)]+constraintEnvP+ = try (do xts <- sepBy tyBindNoLocP comma+ reservedOp "|-"+ return xts)+ <|> 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+ where+ tr = ty_res trep+ xts = zip (ty_binds trep) (ty_args trep)+ trep = toRTypeRep ct++-- "forall <z w> . TYPE"+-- or+-- "forall x y <z :: Nat, w :: Int> . TYPE"+bareAllP :: Parser BareType+bareAllP = do+ sp <- getSourcePos+ as <- tyVarDefsP+ ps <- angles inAngles+ <|> return []+ _ <- dot+ t <- bareTypeP+ return $ foldr rAllT (foldr (rAllP sp) t ps) (makeRTVar <$> as)+ where+ rAllT a t = RAllT a t mempty+ inAngles = try (sepBy predVarDefP comma)++-- See #1907 for why we have to alpha-rename pvar binders+rAllP :: SourcePos -> PVar BSort -> BareType -> BareType+rAllP sp p t = RAllP p' ({- F.tracepp "rAllP" $ -} substPVar p p' t)+ where+ p' = p { pname = pn' }+ pn' = pname p `intSymbol` lin `intSymbol` col+ lin = unPos (sourceLine sp)+ col = unPos (sourceColumn sp)++tyVarDefsP :: Parser [BTyVar]+tyVarDefsP+ = parens (many (bTyVar <$> tyKindVarIdP))+ <|> many (bTyVar <$> tyVarIdP)+ <?> "tyVarDefsP"++tyKindVarIdP :: Parser Symbol+tyKindVarIdP = do+ tv <- tyVarIdP+ do reservedOp "::"; _ <- kindP; return tv <|> return tv++kindP :: Parser BareType+kindP = bareAtomBindP++predVarDefsP :: Parser [PVar BSort]+predVarDefsP+ = angles (sepBy1 predVarDefP comma)+ <|> return []+ <?> "predVarDefP"++predVarDefP :: Parser (PVar BSort)+predVarDefP+ = bPVar <$> predVarIdP <*> reservedOp "::" <*> propositionSortP++predVarIdP :: Parser Symbol+predVarIdP+ = symbol <$> tyVarIdP++bPVar :: Symbol -> t -> [(Symbol, t1)] -> PVar t1+bPVar p _ xts = PV p (PVProp τ) dummySymbol τxs+ where+ (_, τ) = safeLast "bPVar last" xts+ τxs = [ (τ', x, EVar 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++propositionTypeP :: Parser [(Symbol, BareType)]+propositionTypeP = either fail return . mkPropositionType =<< bareTypeP++mkPropositionType :: BareType -> Either String [(Symbol, BareType)]+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++xyP :: Parser x -> Parser a -> Parser y -> Parser (x, y)+xyP lP sepP rP =+ (,) <$> lP <* sepP <*> rP++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++getClasses :: RType BTyCon t t1 -> [RType BTyCon t t1]+getClasses (RApp tc ts ps r)+ | isTuple tc+ = concatMap getClasses ts+ | otherwise+ = [RApp (tc { btc_class = True }) ts ps r]+getClasses t+ = [t]++dummyP :: Monad m => m (Reft -> b) -> m b+dummyP fm+ = fm `ap` return dummyReft++symsP :: (IsString tv, Monoid r)+ => Parser [(Symbol, RType c tv r)]+symsP+ = do reservedOp "\\"+ ss <- many symbolP+ reservedOp "->"+ return $ (, dummyRSort) <$> ss+ <|> return []+ <?> "symsP"++dummyRSort :: (IsString tv, Monoid r) => RType c tv r+dummyRSort+ = RVar "dummy" mempty++predicatesP :: (IsString tv, Monoid r)+ => Parser [Ref (RType c tv r) BareType]+predicatesP+ = angles (sepBy1 predicate1P comma)+ <|> return []+ <?> "predicatesP"++predicate1P :: (IsString tv, Monoid r)+ => Parser (Ref (RType c tv r) BareType)+predicate1P+ = try (RProp <$> symsP <*> refP bbaseP)+ <|> (rPropP [] . predUReft <$> monoPredicate1P)+ <|> braces (bRProp <$> symsP' <*> refaP)+ <?> "predicate1P"+ where+ symsP' = do ss <- symsP+ fs <- mapM refreshSym (fst <$> ss)+ return $ zip ss fs+ refreshSym s = intSymbol s <$> freshIntP++mmonoPredicateP :: Parser Predicate+mmonoPredicateP+ = try (angles $ angles monoPredicate1P)+ <|> return mempty+ <?> "mmonoPredicateP"++monoPredicateP :: Parser Predicate+monoPredicateP+ = try (angles monoPredicate1P)+ <|> return mempty+ <?> "monoPredicateP"++monoPredicate1P :: Parser Predicate+monoPredicate1P+ = (reserved "True" >> return mempty)+ <|> (pdVar <$> parens predVarUseP)+ <|> (pdVar <$> predVarUseP)+ <?> "monoPredicate1P"++predVarUseP :: Parser (PVar String)+predVarUseP+ = do (p, xs) <- funArgsP+ return $ PV p (PVProp dummyTyId) dummySymbol [ (dummyTyId, dummySymbol, x) | x <- xs ]++funArgsP :: Parser (Symbol, [Expr])+funArgsP = try realP <|> empP <?> "funArgsP"+ where+ empP = (,[]) <$> predVarIdP+ realP = do (EVar lp, xs) <- splitEApp <$> funAppP+ return (lp, xs)++boundP :: Parser (Bound (Located BareType) Expr)+boundP = do+ name <- locUpperIdP+ reservedOp "="+ vs <- bvsP+ params' <- many (parens tyBindP)+ args <- bargsP+ Bound name vs params' args <$> predP+ where+ bargsP = ( do reservedOp "\\"+ xs <- many (parens tyBindP)+ reservedOp "->"+ return xs+ )+ <|> return []+ <?> "bargsP"+ bvsP = ( do reserved "forall"+ xs <- many (fmap bTyVar <$> locSymbolP)+ reservedOp "."+ return (fmap (`RVar` mempty) <$> xs)+ )+ <|> return []+++infixGenP :: Assoc -> Parser ()+infixGenP assoc = do+ p <- maybeDigit+ s <- infixIdP -- TODO: Andres: infixIdP was defined as many (satisfy (`notElem` [' ', '.'])) which does not make sense at all+ -- Andres: going via Symbol seems unnecessary and wasteful here+ addOperatorP (FInfix p (symbolString s) Nothing assoc)++infixP :: Parser ()+infixP = infixGenP AssocLeft++infixlP :: Parser ()+infixlP = infixGenP AssocLeft++infixrP :: Parser ()+infixrP = infixGenP AssocRight++maybeDigit :: Parser (Maybe Int)+maybeDigit+ = optional (lexeme (read . pure <$> digitChar))++------------------------------------------------------------------------+----------------------- Wrapped Constructors ---------------------------+------------------------------------------------------------------------++bRProp :: [((Symbol, τ), Symbol)]+ -> Expr -> Ref τ (RType c BTyVar (UReft Reft))+bRProp [] _ = panic Nothing "Parse.bRProp empty list"+bRProp syms' epr = RProp ss $ bRVar (BTV dummyName) mempty 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)++bRVar :: tv -> Predicate -> r -> RType c tv (UReft r)+bRVar α p r = RVar α (MkUReft r p)++bLst :: Maybe (RType BTyCon tv (UReft r))+ -> [RTProp BTyCon tv (UReft 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)++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 [(_,t)] _ r+ | isTauto r = t+ | otherwise = t `strengthen` reftUReft r+bTup ts rs r+ | all Mb.isNothing (fst <$> ts) || length ts < 2+ = RApp (mkBTyCon $ dummyLoc tupConName) (snd <$> ts) rs (reftUReft r)+ | otherwise+ = RApp (mkBTyCon $ dummyLoc tupConName) (top . 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)+ rs' = makeProp <$> [1..(length ts-1)]+++-- Temporarily restore this hack benchmarks/esop2013-submission/Array.hs fails+-- w/o it+-- 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+ -> r+ -> RType c tv (UReft 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+ where+ ts' = foldl' (\a b -> RAppTy a b mempty) (RVar v mempty) ts++reftUReft :: r -> UReft r+reftUReft r = MkUReft r mempty++predUReft :: Monoid r => Predicate -> UReft r+predUReft p = MkUReft dummyReft p++dummyReft :: Monoid a => a+dummyReft = mempty++dummyTyId :: IsString a => a+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)+ | 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+ | 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+ | BFix () -- ^ fixity annotation+ | Define (LocSymbol, Symbol) -- ^ 'define' annotation for specifying aliases c.f. `include-CoreToLogic.lg`+ deriving (Data, Show, Typeable)++instance (PPrint ty, PPrint ctor) => PPrint (Pspec ty ctor) 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 k lxs t mles+ = PJ.hcat [ splice ", " (pprintTidy k <$> (val <$> lxs))+ , " :: "+ , pprintTidy k t+ , ppLes mles+ ]+ where+ ppLes Nothing = ""+ ppLes (Just les) = "/" <+> pprintTidy k (val <$> les)++ppPspec :: (PPrint t, PPrint c) => Tidy -> Pspec t c -> PJ.Doc+ppPspec k (Meas m)+ = "measure" <+> pprintTidy k m+ppPspec k (Assm (lx, t))+ = "assume" <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t+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+ppPspec k (Asrts (lxs, (t, les)))+ = ppAsserts k lxs t les+ppPspec k (Impt x)+ = "import" <+> pprintTidy k x+ppPspec k (DDecl d)+ = pprintTidy k d+ppPspec k (NTDecl d)+ = "newtype" <+> pprintTidy k d+ppPspec _ (Incl f)+ = "include" <+> "<" PJ.<> PJ.text f PJ.<> ">"+ppPspec k (Invt t)+ = "invariant" <+> pprintTidy k t+ppPspec k (Using (t1, t2))+ = "using" <+> pprintTidy k t1 <+> "as" <+> pprintTidy k t2+ppPspec k (Alias (Loc _ _ rta))+ = "type" <+> pprintTidy k rta+ppPspec k (EAlias (Loc _ _ rte))+ = "predicate" <+> pprintTidy k rte+ppPspec k (Embed (lx, tc, NoArgs))+ = "embed" <+> pprintTidy k (val lx) <+> "as" <+> pprintTidy k tc+ppPspec k (Embed (lx, tc, WithArgs))+ = "embed" <+> pprintTidy k (val lx) <+> "*" <+> "as" <+> pprintTidy k tc+ppPspec k (Qualif q)+ = pprintTidy k q+ppPspec k (LVars lx)+ = "lazyvar" <+> pprintTidy k (val lx)+ppPspec k (Lazy lx)+ = "lazy" <+> pprintTidy k (val lx)+ppPspec k (Rewrite lx)+ = "rewrite" <+> pprintTidy k (val lx)+ppPspec k (Rewritewith (lx, lxs))+ = "rewriteWith" <+> pprintTidy k (val lx) <+> PJ.hsep (map go lxs)+ where+ 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 (HMeas lx)+ = "measure" <+> pprintTidy k (val lx)+ppPspec k (Reflect lx)+ = "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+ppPspec _ (Pragma (Loc _ _ s))+ = "LIQUID" <+> PJ.text s+ppPspec k (CMeas m)+ = "class measure" <+> pprintTidy k m+ppPspec k (IMeas m)+ = "instance measure" <+> pprintTidy k m+ppPspec k (Class cls)+ = pprintTidy k cls+ppPspec k (CLaws cls)+ = pprintTidy k cls+ppPspec k (RInst inst)+ = pprintTidy k 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)+ppPspec _ (BFix _) --+ = "fixity"+ppPspec k (Define (lx, y))+ = "define" <+> pprintTidy k (val lx) <+> "=" <+> pprintTidy k y+ppPspec _ ILaws{}+ = "TBD-INSTANCE-LAWS"+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+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+++-- | 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"+ show (EAlias _) = "EAlias"+ show (Embed _) = "Embed"+ show (Qualif _) = "Qualif"+ show (Decr _) = "Decr"+ 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"+ show (IMeas _) = "IMeas"+ show (Class _) = "Class"+ show (Varia _) = "Varia"+ show (PBound _) = "Bound"+ show (RInst _) = "RInst"+ show (ASize _) = "ASize"+ 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+-- different kinds of spec directives in different positions, whereas the input+-- list is a mixed list.+--+-- In addition, the sigs of the spec (these are asserted/checked LH type+-- 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+ { Measure.measures = [m | Meas m <- xs]+ , Measure.asmSigs = [a | Assm a <- 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.pragmas = [s | Pragma s <- xs]+ , Measure.cmeasures = [m | CMeas m <- xs]+ , Measure.imeasures = [m | IMeas m <- xs]+ , 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]+ , Measure.rewrites = S.fromList [s | Rewrite s <- xs]+ , 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.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 = []+ }++-- | Parse a single top level liquid specification+specP :: Parser BPspec+specP+ = fallbackSpecP "assume"+ ((reserved "relational" >> fmap AssmRel relationalP)+ <|> fmap Assm tyBindP )+ <|> fallbackSpecP "assert" (fmap Asrt tyBindP )+ <|> fallbackSpecP "autosize" (fmap ASize asizeP )+ <|> (reserved "local" >> fmap LAsrt tyBindP )++ -- TODO: These next two are synonyms, kill one+ <|> fallbackSpecP "axiomatize" (fmap Reflect axiomP )+ <|> fallbackSpecP "reflect" (fmap Reflect axiomP )++ <|> 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 "bound" (fmap PBound boundP+ <|> fmap HBound hboundP )+ <|> (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 )++ -- TODO: Next two are basically synonyms+ <|> fallbackSpecP "predicate" (fmap EAlias ealiasP )+ <|> fallbackSpecP "expression" (fmap EAlias ealiasP )++ <|> fallbackSpecP "embed" (fmap Embed embedP )+ <|> fallbackSpecP "qualif" (fmap Qualif (qualifierP sortP))+ <|> (reserved "lazyvar" >> fmap LVars lazyVarP )++ <|> (reserved "lazy" >> fmap Lazy lazyVarP )+ <|> (reserved "rewrite" >> fmap Rewrite rewriteVarP )+ <|> (reserved "rewriteWith" >> fmap Rewritewith rewriteWithP )+ <|> (reserved "fail" >> fmap Fail failVarP )+ <|> (reserved "ple" >> fmap Insts autoinstP )+ <|> (reserved "automatic-instances" >> fmap Insts autoinstP )+ <|> (reserved "LIQUID" >> fmap Pragma pragmaP )+ <|> (reserved "liquid" >> fmap Pragma pragmaP )+ <|> {- DEFAULT -} fmap Asrts tyBindsP+ <?> "specP"++-- | Try the given parser on the tail after matching the reserved word, and if+-- it fails fall back to parsing it as a haskell signature for a function with+-- the same name.+fallbackSpecP :: String -> Parser BPspec -> Parser BPspec+fallbackSpecP kw p = do+ (Loc l1 l2 _) <- locReserved kw+ p <|> fmap Asrts (tyBindsRemP (Loc l1 l2 (symbol kw)) )++-- | Same as tyBindsP, except the single initial symbol has already been matched+tyBindsRemP :: LocSymbol -> Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))+tyBindsRemP sym = do+ reservedOp "::"+ tb <- termBareTypeP+ return ([sym],tb)++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++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)++dsizeP :: Parser ([Located BareType], Located Symbol)+dsizeP = liftM2 (,) (parens $ sepBy (located genBareTypeP) comma) locBinderP+++varianceP :: Parser Variance+varianceP = (reserved "bivariant" >> return Bivariant)+ <|> (reserved "invariant" >> return Invariant)+ <|> (reserved "covariant" >> return Covariant)+ <|> (reserved "contravariant" >> return Contravariant)+ <?> "Invalid variance annotation\t Use one of bivariant, invariant, covariant, contravariant"++tyBindsP :: Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))+tyBindsP =+ xyP (sepBy1 locBinderP comma) (reservedOp "::") termBareTypeP++tyBindNoLocP :: Parser (LocSymbol, BareType)+tyBindNoLocP = second val <$> tyBindP++-- | Parses a type signature as it occurs in "assume" and "assert" directives.+tyBindP :: Parser (LocSymbol, Located BareType)+tyBindP =+ (,) <$> locBinderP <* reservedOp "::" <*> located genBareTypeP++termBareTypeP :: Parser (Located BareType, Maybe [Located Expr])+termBareTypeP = do+ t <- located genBareTypeP+ termTypeP t <|> return (t, Nothing)++termTypeP :: Located BareType ->Parser (Located BareType, Maybe [Located Expr])+termTypeP t+ = do+ reservedOp "/"+ es <- brackets $ sepBy (located exprP) comma+ return (t, Just es)++-- -------------------------------------++invariantP :: Parser (Located BareType)+invariantP = located genBareTypeP++invaliasP :: Parser (Located BareType, Located BareType)+invaliasP+ = do t <- located genBareTypeP+ reserved "as"+ ta <- located genBareTypeP+ return (t, ta)++genBareTypeP :: Parser BareType+genBareTypeP = bareTypeP++embedP :: Parser (Located Symbol, FTycon, TCArgs)+embedP = do+ x <- locUpperIdP+ a <- try (reserved "*" >> return WithArgs) <|> return NoArgs -- TODO: reserved "*" looks suspicious+ _ <- reserved "as"+ t <- fTyConP+ return (x, t, a)+ -- = xyP locUpperIdP symbolTCArgs (reserved "as") fTyConP+++aliasP :: Parser (Located (RTAlias Symbol BareType))+aliasP = rtAliasP id bareTypeP <?> "aliasP"++ealiasP :: Parser (Located (RTAlias Symbol Expr))+ealiasP = try (rtAliasP symbol predP)+ <|> rtAliasP symbol exprP+ <?> "ealiasP"++-- | Parser for a LH type synonym.+rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (Located (RTAlias tv ty))+rtAliasP f bodyP+ = do pos <- getSourcePos+ name <- upperIdP+ args <- many aliasIdP+ reservedOp "="+ body <- bodyP+ posE <- getSourcePos+ let (tArgs, vArgs) = partition (isSmall . headSym) args+ return $ Loc pos posE (RTA name (f <$> tArgs) vArgs body)++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))++measureP :: Parser (Measure (Located BareType) LocSymbol)+measureP = do+ (x, ty) <- indentedLine tyBindP+ _ <- optional semi+ eqns <- block $ measureDefP (rawBodyP <|> tyBodyP ty)+ return $ Measure.mkM x ty eqns MsMeasure mempty++-- | class measure+cMeasureP :: Parser (Measure (Located BareType) ())+cMeasureP+ = do (x, ty) <- tyBindP+ return $ Measure.mkM x ty [] MsClass mempty++iMeasureP :: Parser (Measure (Located BareType) LocSymbol)+iMeasureP = measureP+++oneClassArg :: Parser [Located BareType]+oneClassArg+ = sing <$> located (rit <$> classBTyConP <*> (map val <$> classParams))+ where+ rit t as = RApp t ((`RVar` mempty) <$> as) [] mempty+ classParams = (reserved "where" >> return [])+ <|> ((:) <$> (fmap bTyVar <$> locLowerIdP) <*> classParams)+ sing x = [x]+++superP :: Parser (Located BareType)+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+ = do _ <- supersP+ c <- classBTyConP+ tvs <- try oneClassArg <|> manyTill iargsP (try $ reserved "where")+ ms <- block riMethodSigP+ return $ RI c tvs ms+ where+ supersP = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)+ <* reservedOp "=>")+ <|> return []++ iargsP = (mkVar . bTyVar <$> tyVarIdP)+ <|> parens (located bareTypeP)+++ mkVar v = dummyLoc $ RVar v mempty+++riMethodSigP :: Parser (LocSymbol, RISig (Located BareType))+riMethodSigP+ = try (do reserved "assume"+ (x, t) <- tyBindP+ return (x, RIAssumed t) )+ <|> do (x, t) <- tyBindP+ return (x, RISig t)+ <?> "riMethodSigP"++classP :: Parser (RClass (Located BareType))+classP+ = do sups <- supersP+ c <- classBTyConP+ tvs <- manyTill (bTyVar <$> tyVarIdP) (try $ reserved "where")+ ms <- block tyBindP -- <|> 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+ = braces $ do+ v <- symbolP+ reservedOp "|"+ R v <$> predP++tyBodyP :: Located BareType -> Parser Body+tyBodyP ty+ = case outTy (val ty) of+ Just bt | isPropBareType bt+ -> P <$> predP+ _ -> E <$> exprP+ where outTy (RAllT _ t _) = outTy t+ outTy (RAllP _ t) = outTy t+ outTy (RFun _ _ _ t _) = Just t+ outTy _ = Nothing++locUpperOrInfixIdP :: Parser (Located Symbol)+locUpperOrInfixIdP = locUpperIdP' <|> locInfixCondIdP++locBinderP :: Parser (Located Symbol)+locBinderP =+ located binderP -- TODO++-- | LHS of the thing being defined+--+-- TODO, Andres: this is still very broken+--+{-+binderP :: Parser Symbol+binderP = pwr <$> parens (idP bad)+ <|> symbol <$> idP badc+ where+ idP p = takeWhile1P Nothing (not . p)+ badc c = (c == ':') || (c == ',') || bad c+ bad c = isSpace c || c `elem` ("(,)[]" :: String)+ pwr s = symbol $ "(" `mappend` s `mappend` ")"+-}+binderP :: Parser Symbol+binderP =+ symbol . (\ x -> "(" <> x <> ")") . symbolText <$> 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+ (c, xs) <- measurePatP+ reservedOp "="+ body <- bodyP+ let xs' = symbol . val <$> xs+ return $ Def mname (symbol <$> c) Nothing ((, Nothing) <$> xs') body++measurePatP :: Parser (LocSymbol, [LocSymbol])+measurePatP+ = parens (try conPatP <|> try consPatP <|> nilPatP <|> tupPatP)+ <|> nullaryConPatP+ <?> "measurePatP"++tupPatP :: Parser (Located Symbol, [Located Symbol])+tupPatP = mkTupPat <$> sepBy1 locLowerIdP comma++conPatP :: Parser (Located Symbol, [Located Symbol])+conPatP = (,) <$> dataConNameP <*> many locLowerIdP++consPatP :: IsString a+ => Parser (Located a, [Located Symbol])+consPatP = mkConsPat <$> locLowerIdP <*> reservedOp ":" <*> locLowerIdP++nilPatP :: IsString a+ => Parser (Located a, [t])+nilPatP = mkNilPat <$> brackets (pure ())++nullaryConPatP :: Parser (Located Symbol, [t])+nullaryConPatP = nilPatP <|> ((,[]) <$> dataConNameP)+ <?> "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])++tupDataCon :: Int -> Located Symbol+tupDataCon n = dummyLoc $ symbol $ "(" <> replicate (n - 1) ',' <> ")"+++-------------------------------------------------------------------------------+--------------------------------- Predicates ----------------------------------+-------------------------------------------------------------------------------++dataConFieldsP :: Parser [(Symbol, BareType)]+dataConFieldsP+ = explicitCommaBlock predTypeDDP -- braces (sepBy predTypeDDP comma)+ <|> many dataConFieldP+ <?> "dataConFieldP"++dataConFieldP :: Parser (Symbol, BareType)+dataConFieldP+ = parens (try predTypeDDP <|> dbTypeP)+ <|> dbTyArgP -- unparenthesised constructor fields must be "atomic"+ <?> "dataConFieldP"+ where+ dbTypeP = (,) <$> dummyBindP <*> bareTypeP+ dbTyArgP = (,) <$> dummyBindP <*> bareTyArgP++predTypeDDP :: Parser (Symbol, BareType)+predTypeDDP = (,) <$> bbindP <*> bareTypeP++bbindP :: Parser Symbol+bbindP = lowerIdP <* reservedOp "::"++dataConP :: [Symbol] -> Parser DataCtor+dataConP as = do+ x <- dataConNameP+ xts <- dataConFieldsP+ return $ DataCtor x as [] xts Nothing++adtDataConP :: [Symbol] -> Parser DataCtor+adtDataConP as = do+ x <- dataConNameP+ 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 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)++-- TODO: fix Located+dataConNameP :: Parser (Located Symbol)+dataConNameP+ = located+ ( try upperIdP+ <|> pwr <$> parens (idP bad)+ <?> "dataConNameP"+ )+ where+ idP p = takeWhile1P Nothing (not . p)+ bad c = isSpace c || c `elem` ("(,)" :: String)+ pwr s = symbol $ "(" <> s <> ")"++dataSizeP :: Parser (Maybe SizeFun)+dataSizeP+ = brackets (Just . SymSizeFun <$> locLowerIdP)+ <|> return Nothing++relationalP :: Parser (LocSymbol, LocSymbol, LocBareType, LocBareType, RelExpr, RelExpr)+relationalP = do+ x <- locBinderP+ reserved "~"+ y <- locBinderP+ reserved "::"+ braces $ do+ tx <- located genBareTypeP+ reserved "~"+ ty <- located genBareTypeP+ reserved "|"+ assm <- try (relrefaP <* reserved "|-") <|> return (ERBasic PTrue)+ ex <- relrefaP+ return (x,y,tx,ty,assm,ex)++dataDeclP :: Parser DataDecl+dataDeclP = do+ pos <- getSourcePos+ x <- locUpperOrInfixIdP+ fsize <- dataSizeP+ dataDeclBodyP pos x fsize <|> return (emptyDecl x pos fsize)++emptyDecl :: LocSymbol -> SourcePos -> Maybe SizeFun -> DataDecl+emptyDecl x pos fsize@(Just _)+ = DataDecl (DnName 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 pos x fsize = do+ vanilla <- null <$> many locUpperIdP+ as <- many noWhere -- TODO: check this again+ ps <- predVarDefsP+ (pTy, dcs) <- dataCtorsP as+ 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 p x _ _ = uError (ErrBadData (sourcePosSrcSpan p) (pprint (val x)) msg)+ where+ msg = "You should specify at least one data constructor for a family instance"++-- | Parse the constructors of a datatype, allowing both classic and GADT-style syntax.+--+-- Note that as of 2020-10-14, we changed the syntax of GADT-style datatype declarations+-- 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 as = do+ (pTy, dcs) <- (reservedOp "=" >> ((Nothing, ) <$> sepBy (dataConP as) (reservedOp "|")))+ <|> (reserved "where" >> ((Nothing, ) <$> block (adtDataConP as) ))+ <|> ((,) <$> dataPropTyP <*> block (adtDataConP as) )+ return (pTy, Misc.sortOn (val . dcName) dcs)++noWhere :: Parser Symbol+noWhere =+ try $ do+ s <- tyVarIdP+ guard (s /= "where")+ return s++dataPropTyP :: Parser (Maybe BareType)+dataPropTyP = Just <$> between (reservedOp "::") (reserved "where") bareTypeP++---------------------------------------------------------------------+-- | Parsing Qualifiers ---------------------------------------------+---------------------------------------------------------------------++fTyConP :: Parser FTycon+fTyConP+ = (reserved "int" >> return intFTyCon)+ <|> (reserved "Integer" >> return intFTyCon)+ <|> (reserved "Int" >> return intFTyCon)+ <|> (reserved "real" >> return realFTyCon)+ <|> (reserved "bool" >> return boolFTyCon)+ <|> (symbolFTycon <$> locUpperIdP)+ <?> "fTyConP"++---------------------------------------------------------------------+-- Identifiers ------------------------------------------------------+---------------------------------------------------------------------++-- Andres, TODO: Fix all the rules for identifiers. This was limited to all lowercase letters before.+tyVarIdR :: Parser Symbol+tyVarIdR =+ condIdR (lowerChar <|> char '_') isAlphaNum isNotReserved "unexpected reserved name"++tyVarIdP :: Parser Symbol+tyVarIdP =+ lexeme tyVarIdR++aliasIdR :: Parser Symbol+aliasIdR =+ condIdR (letterChar <|> char '_') isAlphaNum (const True) "unexpected"++aliasIdP :: Parser Symbol+aliasIdP =+ lexeme aliasIdR++-- | Andres, TODO: This must be liberal with respect to reserved words (LH reserved words are+-- not Haskell reserved words, and we want to redefine all sorts of internal stuff).+--+-- Also, this currently accepts qualified names by allowing '.' ...+-- Moreover, it seems that it is currently allowed to use qualified symbolic names in+-- unparenthesised form. Oh, the parser is also used for reflect, where apparently+-- symbolic names appear in unqualified and unparenthesised form.+-- Furthermore, : is explicitly excluded because a : can directly, without whitespace,+-- follow a binder ...+--+binderIdR :: Parser Symbol+binderIdR =+ condIdR (letterChar <|> char '_' <|> satisfy isHaskellOpStartChar) (\ c -> isAlphaNum c || isHaskellOpStartChar c || c `elem` ("_'" :: String)) (const True) "unexpected"++binderIdP :: Parser Symbol+binderIdP =+ lexeme binderIdR++infixBinderIdR :: Parser Symbol+infixBinderIdR =+ condIdR (letterChar <|> char '_' <|> satisfy isHaskellOpChar) (\ c -> isAlphaNum c || isHaskellOpChar c || c `elem` ("_'" :: String)) (const True) "unexpected"++infixBinderIdP :: Parser Symbol+infixBinderIdP =+ lexeme infixBinderIdR++upperIdR' :: Parser Symbol+upperIdR' =+ condIdR upperChar (\ c -> isAlphaNum c || c == '\'') (const True) "unexpected"++locUpperIdP' :: Parser (Located Symbol)+locUpperIdP' =+ locLexeme upperIdR'++-- Andres, TODO: This used to force a colon at the end. Also, it used to not+-- allow colons in the middle. Finally, it should probably exclude all reserved+-- operators. I'm just excluding :: because I'm pretty sure that would be+-- undesired.+--+infixCondIdR :: Parser Symbol+infixCondIdR =+ condIdR (char ':') isHaskellOpChar (/= "::") "unexpected double colon"++-- Andres, TODO: This used to be completely ad-hoc. It's still not good though.+infixIdR :: Parser Symbol+infixIdR =+ condIdR (satisfy isHaskellOpChar) isHaskellOpChar (/= "::") "unexpected double colon"++infixIdP :: Parser Symbol+infixIdP =+ lexeme infixIdR++{-+infixVarIdR :: Parser Symbol+infixVarIdR =+ condIdR (satisfy isHaskellOpStartChar) isHaskellOpChar (const True)++infixVarIdP :: Parser Symbol+infixVarIdP =+ lexeme infixVarIdR+-}++isHaskellOpChar :: Char -> Bool+isHaskellOpChar c+ = c `elem` (":!#$%&*+./<=>?@\\^|~-" :: String)++isHaskellOpStartChar :: Char -> Bool+isHaskellOpStartChar c+ = c `elem` ("!#$%&*+./<=>?@\\^|~-" :: String)++locInfixCondIdP :: Parser (Located Symbol)+locInfixCondIdP =+ locLexeme infixCondIdR
+ src/Language/Haskell/Liquid/Termination/Structural.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Language.Haskell.Liquid.Termination.Structural (terminationVars) where++import Language.Haskell.Liquid.Types hiding (isDecreasing)+import Language.Haskell.Liquid.GHC.Misc (showPpr)+import Liquid.GHC.API as GHC hiding ( showPpr+ , Env+ , text+ )++import Text.PrettyPrint.HughesPJ hiding ((<>))++import qualified Data.HashSet as HS+import Data.HashSet (HashSet)+import qualified Data.Map.Strict as M+import Data.Map.Strict (Map)+import qualified Data.List as L++import Control.Monad (liftM, ap)+import Data.Foldable (fold)++terminationVars :: TargetInfo -> [Var]+terminationVars info = failingBinds info >>= allBoundVars++failingBinds :: TargetInfo -> [CoreBind]+failingBinds info = filter (hasErrors . checkBind) structBinds+ where+ structCheckWholeProgram = structuralTerm info+ program = giCbs . giSrc $ info+ structFuns = gsStTerm . gsTerm . giSpec $ info+ structBinds+ | structCheckWholeProgram = program+ | otherwise = findStructBinds structFuns program++checkBind :: CoreBind -> Result ()+checkBind bind = do+ srcCallInfo <- getCallInfoBind emptyEnv (deShadowBind bind)+ let structCallInfo = fmap toStructCall <$> srcCallInfo+ fold $ mapWithFun structDecreasing structCallInfo++deShadowBind :: CoreBind -> CoreBind+deShadowBind bind = head $ deShadowBinds [bind]++findStructBinds :: HashSet Var -> CoreProgram -> [CoreBind]+findStructBinds structFuns program = filter isStructBind program+ where+ isStructBind (NonRec f _) = f `HS.member` structFuns+ isStructBind (Rec []) = False+ isStructBind (Rec ((f,_):xs)) = f `HS.member` structFuns || isStructBind (Rec xs)++allBoundVars :: CoreBind -> [Var]+allBoundVars (NonRec v e) = v : (nextBinds e >>= allBoundVars)+allBoundVars (Rec binds) = map fst binds ++ (map snd binds >>= nextBinds >>= allBoundVars)++nextBinds :: CoreExpr -> [CoreBind]+nextBinds = \case+ App e a -> nextBinds e ++ nextBinds a+ Lam _ e -> nextBinds e+ Let b e -> b : nextBinds e+ Case scrut _ _ alts -> nextBinds scrut ++ ([body | Alt _ _ body <- alts] >>= nextBinds)+ Cast e _ -> nextBinds e+ Tick _ e -> nextBinds e+ Var{} -> []+ Lit{} -> []+ Coercion{} -> []+ Type{} -> []++------------------------------------------------------------------------------------------++-- Note that this is *not* the Either/Maybe monad, since it's important that we+-- collect all errors, not just the first error.+data Result a = Result+ { resultVal :: a+ , resultErrors :: [TermError]+ } deriving (Show)++data TermError = TE+ { teVar :: Var+ , teError :: UserError+ } deriving (Show)++hasErrors :: Result a -> Bool+hasErrors = not . null . resultErrors++addError :: Var -> Doc -> Result a -> Result a+addError fun expl (Result x errs) = Result x (mkTermError fun expl : errs)++mkTermError :: Var -> Doc -> TermError+mkTermError fun expl = TE+ { teVar = fun+ , teError = ErrStTerm (getSrcSpan fun) (text $ showPpr fun) expl+ }++instance Monoid a => Monoid (Result a) where+ mempty = Result mempty []++instance Semigroup a => Semigroup (Result a) where+ Result x e1 <> Result y e2 = Result (x <> y) (e1 ++ e2)++instance Monad Result where+ Result x e1 >>= f =+ let Result y e2 = f x in+ Result y (e2 ++ e1)++instance Applicative Result where+ pure x = Result x []+ (<*>) = ap++instance Functor Result where+ fmap = liftM++--------------------------------------------------------------------------------++data Env = Env+ { envCurrentFun :: Maybe Var+ , envCurrentArgs :: [CoreArg]+ , envCheckedFuns :: [Fun]+ }++data Fun = Fun+ { funName :: Var+ , funParams :: [Param]+ }++data Param = Param+ { paramNames :: VarSet+ , paramSubterms :: VarSet+ } deriving (Eq)++emptyEnv :: Env+emptyEnv = Env+ { envCurrentFun = Nothing+ , envCurrentArgs = []+ , envCheckedFuns = []+ }++mkFun :: Var -> Fun+mkFun name = Fun+ { funName = name+ , funParams = []+ }++mkParam :: Var -> Param+mkParam name = Param+ { paramNames = unitVarSet name+ , paramSubterms = emptyVarSet+ }++lookupFun :: Env -> Var -> Maybe Fun+lookupFun env name = L.find (\fun -> funName fun == name) $ envCheckedFuns env++clearCurrentArgs :: Env -> Env+clearCurrentArgs env = env { envCurrentArgs = [] }++setCurrentFun :: Var -> Env -> Env+setCurrentFun fun env = env { envCurrentFun = Just fun }++clearCurrentFun :: Env -> Env+clearCurrentFun env = env { envCurrentFun = Nothing }++addArg :: CoreArg -> Env -> Env+addArg arg env = env { envCurrentArgs = arg:envCurrentArgs env }++addParam :: Var -> Env -> Env+addParam param env = case envCurrentFun env of+ Nothing -> env+ Just name -> env { envCheckedFuns = updateFunNamed name <$> envCheckedFuns env }+ where+ updateFunNamed name fun+ | funName fun == name = fun { funParams = mkParam param : funParams fun }+ | otherwise = fun++addSynonym :: Var -> Var -> Env -> Env+addSynonym oldName newName' env = env { envCheckedFuns = updateFun <$> envCheckedFuns env }+ where+ updateFun fun = fun { funParams = updateParam <$> funParams fun }+ updateParam param+ | oldName `elemVarSet` paramNames param = param { paramNames = paramNames param `extendVarSet` newName' }+ | oldName `elemVarSet` paramSubterms param = param { paramSubterms = paramSubterms param `extendVarSet` newName' }+ | otherwise = param++addSubterms :: Var -> [Var] -> Env -> Env+addSubterms var subterms env = env { envCheckedFuns = updateFun <$> envCheckedFuns env }+ where+ updateFun fun = fun { funParams = updateParam <$> funParams fun }+ updateParam param+ | var `elemVarSet` paramNames param || var `elemVarSet` paramSubterms param = param { paramSubterms = paramSubterms param `extendVarSetList` subterms }+ | otherwise = param++addCheckedFun :: Var -> Env -> Env+addCheckedFun name env = env { envCheckedFuns = mkFun name : envCheckedFuns env }++isParam :: Var -> Param -> Bool+var `isParam` param = var `elemVarSet` paramNames param++isParamSubterm :: Var -> Param -> Bool+var `isParamSubterm` param = var `elemVarSet` paramSubterms param++--------------------------------------------------------------------------------++newtype FunInfo a = FunInfo (Map Var a)++data SrcCall = SrcCall+ { srcCallFun :: Var+ , srcCallArgs :: [(Param, CoreArg)]+ }++instance Semigroup a => Semigroup (FunInfo a) where+ FunInfo xs <> FunInfo ys = FunInfo $ M.unionWith (<>) xs ys++instance Semigroup a => Monoid (FunInfo a) where+ mempty = FunInfo M.empty++instance Functor FunInfo where+ fmap f (FunInfo xs) = FunInfo (fmap f xs)++instance Foldable FunInfo where+ foldMap f (FunInfo m) = foldMap f m++mapWithFun :: (Var -> a -> b) -> FunInfo a -> FunInfo b+mapWithFun f (FunInfo x) = FunInfo (M.mapWithKey f x)++mkFunInfo :: Var -> a -> FunInfo a+mkFunInfo fun x = FunInfo $ M.singleton fun x++mkSrcCall :: Var -> [(Param, CoreArg)] -> SrcCall+mkSrcCall fun args = SrcCall+ { srcCallFun = fun+ , srcCallArgs = args+ }++toVar :: CoreExpr -> Maybe Var+toVar (Var x) = Just x+toVar (Cast e _) = toVar e+toVar (Tick _ e) = toVar e+toVar _ = Nothing++zipExact :: [a] -> [b] -> Maybe [(a, b)]+zipExact [] [] = Just []+zipExact (x:xs) (y:ys) = ((x, y):) <$> zipExact xs ys+zipExact _ _ = Nothing++-- Collect information about all of the recursive calls in a function+-- definition which will be needed to check for structural termination.+getCallInfoExpr :: Env -> CoreExpr -> Result (FunInfo [SrcCall])+getCallInfoExpr env = \case+ Var (lookupFun env -> Just fun) ->+ case zipExact (funParams fun) (reverse $ envCurrentArgs env) of+ Just args -> pure $ mkFunInfo (funName fun) [mkSrcCall (funName fun) args]+ Nothing -> addError (funName fun) "Unsaturated call to function" mempty++ App e a+ | isTypeArg a -> getCallInfoExpr env e+ | otherwise -> getCallInfoExpr argEnv a <> getCallInfoExpr appEnv e+ where+ argEnv = clearCurrentFun . clearCurrentArgs $ env+ appEnv = clearCurrentFun . addArg a $ env++ Lam x e+ | isTyVar x -> getCallInfoExpr env e+ | otherwise -> getCallInfoExpr (addParam x env) e++ Let bind e -> getCallInfoBind env bind <> getCallInfoExpr env e++ Case (toVar -> Just var) bndr _ alts -> foldMap getCallInfoAlt alts+ where+ getCallInfoAlt (Alt _ subterms body) = getCallInfoExpr (branchEnv subterms) body+ branchEnv subterms = addSubterms var subterms . addSynonym var bndr $ env++ Case scrut _ _ alts -> getCallInfoExpr env scrut <> foldMap getCallInfoAlt alts+ where+ getCallInfoAlt (Alt _ _ body) = getCallInfoExpr env body++ Cast e _ -> getCallInfoExpr env e+ Tick _ e -> getCallInfoExpr env e++ Var{} -> pure mempty+ Lit{} -> pure mempty+ Coercion{} -> pure mempty+ Type{} -> pure mempty++getCallInfoBind :: Env -> CoreBind -> Result (FunInfo [SrcCall])+getCallInfoBind env = \case+ NonRec _ e -> getCallInfoExpr (clearCurrentFun env) e+ Rec [] -> pure mempty+ Rec [(f, e)] -> getCallInfoExpr (addCheckedFun f . setCurrentFun f $ env) e+ Rec binds -> foldMap failBind binds+ where failBind (f, e) =+ addError f "Structural checking of mutually-recursive functions is not supported" $+ getCallInfoExpr (clearCurrentFun env) e++--------------------------------------------------------------------------------++data StructInfo = Unchanged Int | Decreasing Int++unStructInfo :: StructInfo -> Int+unStructInfo (Unchanged p) = p+unStructInfo (Decreasing p) = p++isDecreasing :: StructInfo -> Bool+isDecreasing (Decreasing _) = True+isDecreasing (Unchanged _) = False++data StructCall = StructCall+ { structCallFun :: Var+ , structCallArgs :: [Int]+ , structCallDecArgs :: [Int]+ }++mkStructCall :: Var -> [StructInfo] -> StructCall+mkStructCall fun sis = StructCall+ { structCallFun = fun+ , structCallArgs = map unStructInfo sis+ , structCallDecArgs = map unStructInfo . filter isDecreasing $ sis+ }++-- This is where we check a function call. We go through the list of arguments+-- and find the indices of those which are decreasing. Note that this approach+-- is only guaranteed to work when the arguments to the function are named, so+-- e.g.+-- foo (x:xs) (y:ys) = foo xs (y:ys)+-- won't necessarily work, but+-- foo (x:xs) yys@(y:ys) = foo xs yys+-- will.+toStructCall :: SrcCall -> StructCall+toStructCall srcCall = mkStructCall (srcCallFun srcCall) $ toStructArgs 0 (srcCallArgs srcCall)+ where+ toStructArgs _ [] = []+ toStructArgs index ((param, toVar -> Just v):args)+ | v `isParam` param = Unchanged index : toStructArgs (index + 1) args+ | v `isParamSubterm` param = Decreasing index : toStructArgs (index + 1) args+ toStructArgs index (_:args) = toStructArgs (index + 1) args++-- Check if there is some way to lexicographically order the arguments so that+-- they are structurally decreasing. Essentially, in order for there to be, we+-- must be able to find some argument which is always either unchanged or+-- decreasing. We can then remove every call where that argument is decreasing+-- and recurse.+structDecreasing :: Var -> [StructCall] -> Result ()+structDecreasing _ [] = mempty+structDecreasing funName calls+ | null sharedArgs = addError funName "Non-structural recursion" mempty+ | otherwise = structDecreasing funName $ (map removeSharedArgs . filter noneDecreasing) calls+ where+ sharedArgs = foldl1 L.intersect (structCallArgs <$> calls)+ noneDecreasing call = null $ structCallDecArgs call `L.intersect` sharedArgs+ removeSharedArgs call = call { structCallArgs = structCallArgs call L.\\ sharedArgs }
+ src/Language/Haskell/Liquid/Transforms/ANF.hs view
@@ -0,0 +1,419 @@+--------------------------------------------------------------------------------+-- | Convert GHC Core into Administrative Normal Form (ANF) --------------------+--------------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Language.Haskell.Liquid.Transforms.ANF (anormalize) where++import Debug.Trace (trace)+import Prelude hiding (error)+import Language.Haskell.Liquid.GHC.TypeRep+import Liquid.GHC.API as Ghc hiding ( mkTyArg+ , showPpr+ , DsM+ , panic)+import qualified Liquid.GHC.API as Ghc+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+import qualified Language.Haskell.Liquid.GHC.Resugar as Rs+import Data.Maybe (fromMaybe)+import Data.List (sortBy, (\\))+import qualified Text.Printf as Printf+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM++--------------------------------------------------------------------------------+-- | A-Normalize a module ------------------------------------------------------+--------------------------------------------------------------------------------+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+ γ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@ --------------------------------------------------+--------------------------------------------------------------------------------++-- Can't make the below default for normalizeBind as it+-- fails tests/pos/lets.hs due to GHCs odd let-bindings++normalizeTopBind :: AnfEnv -> Bind CoreBndr -> Ghc.DsM [CoreBind]+normalizeTopBind γ (NonRec x e)+ = do e' <- runDsM $ evalStateT (stitch γ e) (DsST [])+ return [normalizeTyVars $ NonRec x e']++normalizeTopBind γ (Rec xes)+ = do xes' <- runDsM $ execStateT (normalizeBind γ (Rec xes)) (DsST [])+ return $ map normalizeTyVars (st_binds xes')++normalizeTyVars :: Bind Id -> Bind Id+normalizeTyVars (NonRec x e) = NonRec (setVarType x t') $ normalizeForAllTys e+ where+ t' = subst msg as as' bt+ msg = "WARNING: unable to renameVars on " ++ GM.showPpr x+ as' = fst $ splitForAllTyCoVars $ exprType e+ (as, bt) = splitForAllTyCoVars (varType x)+normalizeTyVars (Rec xes) = Rec xes'+ where+ nrec = normalizeTyVars <$> (uncurry NonRec <$> xes)+ xes' = (\case NonRec x e -> (x, e); _ -> impossible Nothing "This cannot happen") <$> nrec++subst :: String -> [TyVar] -> [TyVar] -> Type -> Type+subst msg as as' bt+ | length as == length as'+ = mkForAllTys (mkTyArg <$> as') $ substTy su bt+ | otherwise+ = trace msg $ mkForAllTys (mkTyArg <$> as) bt+ where su = mkTvSubstPrs $ zip as (mkTyVarTys as')++-- | eta-expand CoreBinds with quantified types+normalizeForAllTys :: CoreExpr -> CoreExpr+normalizeForAllTys e = case e of+ Lam b _ | isTyVar b+ -> e+ _ -> mkLams tvs (mkTyApps e (map mkTyVarTy tvs))+ where+ (tvs, _) = splitForAllTyCoVars (exprType e)+++newtype DsM a = DsM {runDsM :: Ghc.DsM a}+ deriving (Functor, Monad, MonadUnique, Applicative)++newtype DsST = DsST { st_binds :: [CoreBind] }++type DsMW = StateT DsST DsM++------------------------------------------------------------------+normalizeBind :: AnfEnv -> CoreBind -> DsMW ()+------------------------------------------------------------------+normalizeBind γ (NonRec x e)+ = do e' <- normalize γ e+ add [NonRec x e']++normalizeBind γ (Rec xes)+ = do es' <- mapM (stitch γ) es+ add [Rec (zip xs es')]+ where+ (xs, es) = unzip xes++--------------------------------------------------------------------+normalizeName :: AnfEnv -> CoreExpr -> DsMW CoreExpr+--------------------------------------------------------------------++-- normalizeNameDebug γ e+-- = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e++normalizeName γ e@(Lit l)+ | shouldNormalize l+ = normalizeLiteral γ e+ | otherwise+ = return e++normalizeName γ (Var x)+ = return $ Var (lookupAnfEnv γ x x)++normalizeName _ e@(Type _)+ = return e++normalizeName γ e@(Coercion _)+ = do x <- lift $ freshNormalVar γ $ exprType e+ add [NonRec x e]+ return $ Var x++normalizeName γ (Tick tt e)+ = do e' <- normalizeName (γ `at` tt) e+ return $ Tick tt e'++normalizeName γ e+ = do e' <- normalize γ e+ x <- lift $ freshNormalVar γ $ exprType e+ add [NonRec x e']+ return $ Var x++shouldNormalize :: Literal -> Bool+shouldNormalize (LitNumber {}) = True+shouldNormalize (LitString {}) = True+shouldNormalize _ = False++add :: [CoreBind] -> DsMW ()+add w = modify $ \s -> s { st_binds = st_binds s ++ w}++--------------------------------------------------------------------------------+normalizeLiteral :: AnfEnv -> CoreExpr -> DsMW CoreExpr+--------------------------------------------------------------------------------+normalizeLiteral γ e =+ do x <- lift $ freshNormalVar γ $ exprType e+ add [NonRec x e]+ return $ Var x++--------------------------------------------------------------------------------+normalize :: AnfEnv -> CoreExpr -> DsMW CoreExpr+--------------------------------------------------------------------------------+normalize γ e+ | UX.patternFlag γ+ , Just p <- Rs.lift e+ = normalizePattern γ p++normalize γ (Lam x e) | isTyVar x+ = do e' <- normalize γ e+ return $ Lam x e'++normalize γ (Lam x e)+ = do e' <- stitch γ e+ return $ Lam x e'++normalize γ (Let b e)+ = do normalizeBind γ b+ normalize γ e+ -- Need to float bindings all the way up to the top+ -- Due to GHCs odd let-bindings (see tests/pos/lets.hs)++normalize γ (Case e x t as)+ = do n <- normalizeName γ e+ x' <- lift $ freshNormalVar γ τx -- rename "wild" to avoid shadowing+ let γ' = extendAnfEnv γ x x'+ as' <- forM as $ \(Alt c xs e') -> fmap (Alt c xs) (stitch (incrCaseDepth c γ') e')+ as'' <- lift $ expandDefaultCase γ τx as'+ return $ Case n x' t as''+ where τx = GM.expandVarType x++normalize γ (Var x)+ = return $ Var (lookupAnfEnv γ x x)++normalize _ e@(Lit _)+ = return e++normalize _ e@(Type _)+ = return e++normalize γ (Cast e τ)+ = do e' <- normalizeName γ e+ return $ Cast e' τ++normalize γ (App e1 e2@(Type _))+ = do e1' <- normalize γ e1+ e2' <- normalize γ e2+ return $ App e1' e2'++normalize γ (App e1 e2)+ = do e1' <- normalize γ e1+ n2 <- normalizeName γ e2+ return $ App e1' n2++normalize γ (Tick tt e)+ = do e' <- normalize (γ `at` tt) e+ return $ Tick tt e'++normalize _ (Coercion c)+ = return $ Coercion c++--------------------------------------------------------------------------------+stitch :: AnfEnv -> CoreExpr -> DsMW CoreExpr+--------------------------------------------------------------------------------+stitch γ e+ = do bs' <- get+ modify $ \s -> s { st_binds = [] }+ e' <- normalize γ e+ bs <- st_binds <$> get+ put bs'+ return $ mkCoreLets bs e'++_mkCoreLets' :: [CoreBind] -> CoreExpr -> CoreExpr+_mkCoreLets' bs e = mkCoreLets bs1 e1+ where+ (e1, bs1) = GM.tracePpr "MKCORELETS" (e, bs)++--------------------------------------------------------------------------------+normalizePattern :: AnfEnv -> Rs.Pattern -> DsMW CoreExpr+--------------------------------------------------------------------------------+normalizePattern γ p@(Rs.PatBind {}) = do+ -- don't normalize the >>= itself, we have a special typing rule for it+ e1' <- normalize γ (Rs.patE1 p)+ e2' <- stitch γ (Rs.patE2 p)+ return $ Rs.lower p { Rs.patE1 = e1', Rs.patE2 = e2' }++normalizePattern γ p@(Rs.PatReturn {}) = do+ e' <- normalize γ (Rs.patE p)+ return $ Rs.lower p { Rs.patE = e' }++normalizePattern _ p@(Rs.PatProject {}) =+ return (Rs.lower p)++normalizePattern γ p@(Rs.PatSelfBind {}) = do+ normalize γ (Rs.patE p)++normalizePattern γ p@(Rs.PatSelfRecBind {}) = do+ e' <- normalize γ (Rs.patE p)+ return $ Rs.lower p { Rs.patE = e' }+++--------------------------------------------------------------------------------+expandDefault :: AnfEnv -> Bool+--------------------------------------------------------------------------------+expandDefault γ = aeCaseDepth γ <= maxCaseExpand γ++--------------------------------------------------------------------------------+expandDefaultCase :: AnfEnv+ -> Type+ -> [CoreAlt]+ -> DsM [CoreAlt]+--------------------------------------------------------------------------------+expandDefaultCase γ tyapp zs@(Alt DEFAULT _ _ : _) | expandDefault γ+ = expandDefaultCase' γ tyapp zs++expandDefaultCase γ tyapp@(TyConApp tc _) z@(Alt DEFAULT _ _:dcs)+ = case tyConDataCons_maybe tc of+ Just ds -> do let ds' = ds \\ [ d | Alt (DataAlt d) _ _ <- dcs]+ let n = length ds'+ if n == 1+ then expandDefaultCase' γ tyapp z+ else if maxCaseExpand γ /= 2+ then return z+ else return (trace (expandMessage False γ n) z)+ Nothing -> return z --++expandDefaultCase _ _ z+ = return z++expandDefaultCase'+ :: AnfEnv -> Type -> [CoreAlt] -> DsM [CoreAlt]+expandDefaultCase' γ t (Alt DEFAULT _ e : dcs)+ | Just dtss <- GM.defaultDataCons t ((\(Alt dc _ _) -> dc) <$> dcs) = do+ dcs' <- warnCaseExpand γ <$> forM dtss (cloneCase γ e)+ return $ sortCases (dcs' ++ dcs)+expandDefaultCase' _ _ z+ = return z++cloneCase :: AnfEnv -> CoreExpr -> (DataCon, [TyVar], [Type]) -> DsM CoreAlt+cloneCase γ e (d, as, ts) = do+ xs <- mapM (freshNormalVar γ) ts+ return (Alt (DataAlt d) (as ++ xs) e)++sortCases :: [CoreAlt] -> [CoreAlt]+sortCases = sortBy Ghc.cmpAlt++warnCaseExpand :: AnfEnv -> [a] -> [a]+warnCaseExpand γ xs+ | 10 < n = trace (expandMessage True γ n) xs+ | otherwise = xs+ where+ n = length xs++expandMessage :: Bool -> AnfEnv -> Int -> String+expandMessage expand γ n = unlines [msg1, msg2]+ where+ msg1 = Printf.printf "WARNING: (%s) %s DEFAULT with %d cases at depth %d" (showPpr sp) v1 n d+ msg2 = Printf.printf "%s expansion with --max-case-expand=%d" v2 d'+ (v1, v2, d')+ | expand = ("Expanding" , "Disable", d-1) :: (String, String, Int)+ | otherwise = ("Not expanding", "Enable" , d+1)+ d = aeCaseDepth γ+ sp = Sp.srcSpan (aeSrcSpan γ)++--------------------------------------------------------------------------------+-- | ANF Environments ----------------------------------------------------------+--------------------------------------------------------------------------------+freshNormalVar :: AnfEnv -> Type -> DsM Id+freshNormalVar γ t = do+ u <- getUniqueM+ let i = getKey u+ let sp = Sp.srcSpan (aeSrcSpan γ)+ return (mkUserLocal (anfOcc i) u Ghc.Many t sp)++anfOcc :: Int -> OccName+anfOcc = mkVarOccFS . GM.symbolFastString . F.intSymbol F.anfPrefix++data AnfEnv = AnfEnv+ { aeVarEnv :: HashMap StableId Id+ -- ^ A mapping between a 'StableId' (see below) and an 'Id'.+ , aeSrcSpan :: Sp.SpanStack+ , aeCfg :: UX.Config+ , aeCaseDepth :: !Int+ }++-- | A \"stable\" 'Id'. When transforming 'Core' into ANF notation, we need to keep around a mapping between+-- a particular 'Var' (typically an 'Id') and an 'Id'. Previously this was accomplished using a 'VarEnv',+-- a GHC data structure where keys are 'Unique's. Working with 'Unique' in GHC is not always robust enough+-- when it comes to LH. First of all, the /way/ 'Unique's are constructed might change between GHC versions,+-- and they are not stable between rebuilds/compilations. In the case of this module, in GHC 9 the test+-- BST.hs was failing because two different 'Id's, namely \"wild_X2\" and \"dOrd_X2\" were being given the+-- same 'Unique' by GHC (i.e. \"X2\") which was causing the relevant entry to be overwritten in the 'AnfEnv'+-- causing a unification error.+--+-- A 'StableId' is simply a wrapper over an 'Id' with a different 'Eq' instance that really guarantee+-- uniqueness (for our purposes, anyway).+newtype StableId = StableId Id++instance Eq StableId where+ (StableId id1) == (StableId id2) =+ -- We first use the default 'Eq' instance, which works on uniques (basically, integers) and is+ -- efficient. If we get 'False' it means those 'Unique' are really different, but if we get 'True',+ -- we need to be /really/ sure that's the case by using the 'stableNameCmp' function on the 'Name's.+ -- Nothing to do when id1 == id2 as the uniques are /really/ different.+ (id1 == id2) && (stableNameCmp (getName id1) (getName id2) == EQ) -- Avoid unique clashing.++-- For the 'Hashable' instance, we rely on the 'Unique'. This means in pratice there is a tiny chance+-- of collision, but this should only marginally affects the efficiency of the data structure.+instance Hashable StableId where+ hashWithSalt s (StableId id1) = hashWithSalt s (getKey $ getUnique id1)++-- Shows this 'StableId' by also outputting the associated unique.+instance Show StableId where+ show (StableId id1) = nameStableString (getName id1) <> "_" <> show (getUnique id1)++instance UX.HasConfig AnfEnv where+ getConfig = aeCfg++emptyAnfEnv :: UX.Config -> AnfEnv+emptyAnfEnv cfg = AnfEnv+ { aeVarEnv = mempty+ , aeSrcSpan = Sp.empty+ , aeCfg = cfg+ , aeCaseDepth = 1+ }++lookupAnfEnv :: AnfEnv -> Id -> Id -> Id+lookupAnfEnv γ x (StableId -> y) = HM.lookupDefault x y (aeVarEnv γ)++extendAnfEnv :: AnfEnv -> Id -> Id -> AnfEnv+extendAnfEnv γ (StableId -> x) y = γ { aeVarEnv = HM.insert x y (aeVarEnv γ) }++incrCaseDepth :: AltCon -> AnfEnv -> AnfEnv+incrCaseDepth DEFAULT γ = γ { aeCaseDepth = 1 + aeCaseDepth γ }+incrCaseDepth _ γ = γ++at :: AnfEnv -> CoreTickish -> AnfEnv+at γ tt = γ { aeSrcSpan = Sp.push (Sp.Tick tt) (aeSrcSpan γ)}
+ src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs view
@@ -0,0 +1,661 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Haskell.Liquid.Transforms.CoreToLogic+ ( coreToDef+ , coreToFun+ , coreToLogic+ , mkLit, mkI, mkS+ , runToLogic+ , runToLogicWithBoolBinds+ , logicType+ , inlineSpecType+ , measureSpecType+ , weakenResult+ , normalize+ ) where++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 qualified Liquid.GHC.API as Ghc+import qualified Liquid.GHC.API as C+import qualified Data.List as L+import Data.Maybe (listToMaybe)+import qualified Data.Text as T+import qualified Data.Char+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)+import qualified Language.Fixpoint.Types as F+import qualified Language.Haskell.Liquid.GHC.Misc as GM+++import Language.Haskell.Liquid.Bare.Types+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.RefType++import qualified Data.HashMap.Strict as M++logicType :: (Reftable r) => Bool -> Type -> RRType r+logicType allowTC τ = fromRTypeRep $ t { ty_binds = bs, ty_info = is, ty_args = as, ty_refts = rs}+ where+ t = toRTypeRep $ ofType τ+ (bs, is, as, rs) = Misc.unzip4 $ dropWhile (isErasable' . Misc.thd4) $ Misc.zip4 (ty_binds t) (ty_info t) (ty_args t) (ty_refts t)+ isErasable' = if allowTC then isEmbeddedClass else isClassType++{- | [NOTE:inlineSpecType type]: the refinement depends on whether the result type is a Bool or not:+ CASE1: measure f@logic :: X -> Bool <=> f@haskell :: x:X -> {v:Bool | v <=> (f@logic x)}+ CASE2: measure f@logic :: X -> Y <=> f@haskell :: x:X -> {v:Y | v = (f@logic x)}+ -}+-- formerly: strengthenResult+inlineSpecType :: Bool -> Var -> SpecType+inlineSpecType allowTC v = fromRTypeRep $ rep {ty_res = res `strengthen` r , ty_binds = xs}+ where+ r = MkUReft (mkReft (mkEApp f (mkA <$> vxs))) mempty+ rep = toRTypeRep t+ res = ty_res rep+ xs = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]+ vxs = dropWhile (isErasable' . snd) $ zip xs (ty_args rep)+ isErasable' = if allowTC then isEmbeddedClass else isClassType+ f = dummyLoc (symbol v)+ t = ofType (GM.expandVarType v) :: SpecType+ mkA = EVar . fst+ mkReft = if isBool res then propReft else exprReft++-- | Refine types of measures: keep going until you find the last data con!+-- this code is a hack! we refine the last data constructor,+-- it got complicated to support both+-- 1. multi parameter measures (see tests/pos/HasElem.hs)+-- 2. measures returning functions (fromReader :: Reader r a -> (r -> a) )+-- TODO: SIMPLIFY by dropping support for multi parameter measures++-- formerly: strengthenResult'+measureSpecType :: Bool -> Var -> SpecType+measureSpecType allowTC v = go mkT [] [(1::Int)..] st+ where+ mkReft | boolRes = propReft+ | otherwise = exprReft+ mkT xs = MkUReft (mkReft $ mkEApp locSym (EVar <$> reverse xs)) mempty+ locSym = dummyLoc (symbol v)+ st = ofType (GM.expandVarType v) :: SpecType+ boolRes = isBool $ ty_res $ toRTypeRep st++ go f args i (RAllT a t r) = RAllT a (go f args i t) r+ go f args i (RAllP p t) = RAllP p $ go f args i t+ go f args i (RFun x ii t1 t2 r)+ | (if allowTC then isEmbeddedClass else isClassType) t1 = RFun x ii t1 (go f args i t2) r+ go f args i t@(RFun _ ii t1 t2 r)+ | hasRApps t = RFun x' ii t1 (go f (x':args) (tail i) t2) r+ where x' = intSymbol (symbol ("x" :: String)) (head i)+ go f args _ t = t `strengthen` f args++ hasRApps (RFun _ _ t1 t2 _) = hasRApps t1 || hasRApps t2+ hasRApps RApp {} = True+ hasRApps _ = False+++-- | 'weakenResult foo t' drops the singleton constraint `v = foo x y` +-- that is added, e.g. for measures in /strengthenResult'. +-- This should only be used _when_ checking the body of 'foo' +-- where the output, is, by definition, equal to the singleton.+weakenResult :: Bool -> Var -> SpecType -> SpecType+weakenResult allowTC v t = F.notracepp msg t'+ where+ msg = "weakenResult v =" ++ GM.showPpr v ++ " t = " ++ showpp t+ t' = fromRTypeRep $ rep { ty_res = mapExprReft weaken (ty_res rep) }+ rep = toRTypeRep t+ weaken x = pAnd . filter ((Just vE /=) . isSingletonExpr x) . conjuncts+ vE = mkEApp vF xs+ xs = EVar . fst <$> dropWhile ((if allowTC then isEmbeddedClass else isClassType) . snd) xts+ xts = zip (ty_binds rep) (ty_args rep)+ vF = dummyLoc (symbol v)++type LogicM = ExceptT Error (StateT LState Identity)++data LState = LState+ { lsSymMap :: LogicMap+ , lsError :: String -> Error+ , lsEmb :: TCEmb TyCon+ , lsBools :: [Var]+ , lsDCMap :: DataConMap+ }++throw :: String -> LogicM a+throw str = do+ fmkError <- gets lsError+ throwError $ fmkError str++getState :: LogicM LState+getState = get++runToLogic+ :: TCEmb TyCon -> LogicMap -> DataConMap -> (String -> Error)+ -> LogicM t -> Either Error t+runToLogic = runToLogicWithBoolBinds []++runToLogicWithBoolBinds+ :: [Var] -> TCEmb TyCon -> LogicMap -> DataConMap -> (String -> Error)+ -> LogicM t -> Either Error t+runToLogicWithBoolBinds xs tce lmap dm ferror m+ = evalState (runExceptT m) $ LState+ { lsSymMap = lmap+ , lsError = ferror+ , lsEmb = tce+ , lsBools = xs+ , lsDCMap = dm+ }++coreAltToDef :: (Reftable r) => Bool -> LocSymbol -> Var -> [Var] -> Var -> Type -> [C.CoreAlt]+ -> LogicM [Def (Located (RRType r)) DataCon]+coreAltToDef allowTC 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+ d2s <- F.notracepp "coreAltDefs-2" <$> mkDef locSym cc myArgs z defAlts defExpr+ return (d1s ++ d2s)+ where+ myArgs = reverse zs+ cc = if eqType t boolTy then P else E+ defAlts = GM.defaultDataCons (GM.expandVarType y) ((\(Alt c _ _) -> c) <$> alts)+ defExpr = listToMaybe [ e | (Alt C.DEFAULT _ e) <- alts ]+ dataAlts = [ a | a@(Alt (C.DataAlt _) _ _) <- alts ]+ litAlts = [ a | a@(Alt (C.LitAlt _) _ _) <- alts ]++ -- 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+ mkAlt _ _ _ _ alt+ = throw $ "Bad alternative" ++ GM.showPpr alt++ mkDef x ctor _args dx (Just dtss) (Just e) = do+ eDef <- ctor <$> coreToLg allowTC e+ -- let ys = toArgs id args+ let dxt = Just (varRType dx)+ return [ Def x {- ys -} d dxt (defArgs x ts) eDef | (d, _, ts) <- dtss ]++ mkDef _ _ _ _ _ _ =+ return []++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 x = zipWith (\i t -> (defArg i, defRTyp t)) [0..]+ where+ defArg = tempSymbol (val x)+ defRTyp = Just . F.atLoc x . ofType++coreToDef :: Reftable r => Bool -> LocSymbol -> Var -> C.CoreExpr+ -> LogicM [Def (Located (RRType r)) DataCon]+coreToDef allowTC locSym _ = go [] . inlinePreds . simplify allowTC+ 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) e+ | Just t <- isMeasureArg z = coreAltToDef allowTC 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 x msg = panic sp e+ where+ sp = Just (GM.fSrcSpan x)+ e = Printf.printf "Cannot create measure '%s': %s" (F.showpp x) msg+++-- | 'isMeasureArg x' returns 'Just t' if 'x' is a valid argument for a measure.+isMeasureArg :: Var -> Maybe Type+isMeasureArg x+ | Just tc <- tcMb+ , Ghc.isAlgTyCon tc = F.notracepp "isMeasureArg" $ Just t+ | otherwise = Nothing+ where+ t = GM.expandVarType x+ tcMb = tyConAppTyCon_maybe t+++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+ 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.Tick _ e) = go acc e+ go acc e = (reverse acc,) . Right <$> coreToLg allowTC e+++instance Show C.CoreExpr where+ show = GM.showPpr++coreToLogic :: Bool -> C.CoreExpr -> LogicM Expr+coreToLogic allowTC cb = coreToLg allowTC (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)+ | 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+-- 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+ 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')+-- 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)+++++coerceToLg :: Coercion -> LogicM (Sort, Sort)+coerceToLg = typeEqToLg . coercionTypeEq++coercionTypeEq :: Coercion -> (Type, Type)+coercionTypeEq co+ | Ghc.Pair s t <- -- GM.tracePpr ("coercion-type-eq-1: " ++ GM.showPpr co) $+ coercionKind co+ = (s, t)++typeEqToLg :: (Type, Type) -> LogicM (Sort, Sort)+typeEqToLg (s, t) = do+ tce <- gets lsEmb+ let tx = typeSort tce . expandTypeSynonyms+ return $ F.notracepp "TYPE-EQ-TO-LOGIC" (tx s, tx t)++checkBoolAlts :: [C.CoreAlt] -> LogicM (C.CoreExpr, C.CoreExpr)+checkBoolAlts [Alt (C.DataAlt false) [] efalse, Alt (C.DataAlt true) [] etrue]+ | false == falseDataCon, true == trueDataCon+ = return (efalse, etrue)++checkBoolAlts [Alt (C.DataAlt true) [] etrue, Alt (C.DataAlt false) [] efalse]+ | false == falseDataCon, true == trueDataCon+ = return (efalse, etrue)+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+ where+ normAlts = normalizeAlts alts+ go :: [(C.AltCon, Expr)] -> LogicM Expr+ go [(_,p)] = return (p `subst1` su)+ go ((d,p):dps) = do c <- checkDataAlt d e+ e' <- go dps+ return (EIte c p e' `subst1` su)+ go [] = panic (Just (getSrcSpan v)) $ "Unexpected empty cases in casesToLg: " ++ show e+ su = (symbol v, e)++checkDataAlt :: C.AltCon -> Expr -> LogicM Expr+checkDataAlt (C.DataAlt d) e = return $ EApp (EVar (makeDataConChecker d)) e+checkDataAlt C.DEFAULT _ = return PTrue+checkDataAlt (C.LitAlt l) e+ | Just le <- mkLit l = return (EEq le e)+ | otherwise = throw $ "Oops, not yet handled: checkDataAlt on Lit: " ++ GM.showPpr l++-- | 'altsDefault' reorders the CoreAlt to ensure that 'DEFAULT' is at the end.+normalizeAlts :: [C.CoreAlt] -> [C.CoreAlt]+normalizeAlts alts = ctorAlts ++ defAlts+ where+ (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 allowTC _ (Alt a _ e)+ = (a, ) <$> coreToLg allowTC e++dataConProj :: DataConMap -> Expr -> DataCon -> Var -> Int -> [(Symbol, Expr)]+dataConProj dm de d x i = [(symbol x, t), (GM.simplesymbol x, t)]+ where+ t | primDataCon d = de+ | otherwise = EApp (EVar $ makeDataConSelector (Just dm) d i) de++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+ return $ EIte p e2 e1++toPredApp :: Bool -> C.CoreExpr -> LogicM Expr+toPredApp allowTC p = go . Misc.mapFst opSym . splitArgs allowTC $ p+ where+ opSym = fmap GM.dropModuleNamesAndUnique . tomaybesymbol+ go (Just f, [e1, e2])+ | Just rel <- M.lookup f brels+ = PAtom rel <$> coreToLg allowTC e1 <*> coreToLg allowTC e2+ go (Just f, [e])+ | f == symbol ("not" :: String)+ = PNot <$> coreToLg allowTC e+ | f == symbol ("len" :: String)+ = EApp (EVar "len") <$> coreToLg allowTC 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+ go (Just f, [es])+ | f == symbol ("or" :: String)+ = POr . deList <$> coreToLg allowTC es+ | f == symbol ("and" :: String)+ = PAnd . deList <$> coreToLg allowTC es+ go (_, _)+ = toLogicApp allowTC p++ deList :: Expr -> [Expr]+ deList (EApp (EApp (EVar cons) e) es)+ | cons == symbol ("GHC.Types.:" :: String)+ = e:deList es+ deList (EVar nil)+ | nil == symbol ("GHC.Types.[]" :: String)+ = []+ deList e+ = [e]++toLogicApp :: Bool -> C.CoreExpr -> LogicM Expr+toLogicApp allowTC e = do+ let (f, es) = splitArgs allowTC e+ case f of+ C.Var _ -> do args <- mapM (coreToLg allowTC) 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+ return $ foldl EApp fe args++makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr+makeApp _ _ f [e]+ | val f == symbol ("GHC.Num.negate" :: String)+ = ENeg e+ | val f == symbol ("GHC.Num.fromInteger" :: String)+ , ECon c <- e+ = ECon c+ | (modName, sym) <- GM.splitModuleName (val f)+ , symbol ("Ghci" :: String) `isPrefixOfSym` modName+ , sym == "len"+ = EApp (EVar sym) e++makeApp _ _ f [e1, e2]+ | Just op <- M.lookup (val f) bops+ = EBin op e1 e2+ -- Hack for typeclass support. (overriden == without Eq constraint defined at Ghci)+ | (modName, sym) <- GM.splitModuleName (val f)+ , symbol ("Ghci" :: String) `isPrefixOfSym` modName+ , Just op <- M.lookup (mappendSym (symbol ("GHC.Num." :: String)) sym) bops+ = EBin op e1 e2++makeApp def lmap f es+ = eAppWithMap lmap f es def+ -- where msg = "makeApp f = " ++ show f ++ " es = " ++ show es ++ " def = " ++ show def++eVarWithMap :: Id -> LogicMap -> LogicM 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+++brels :: M.HashMap Symbol Brel+brels = M.fromList [ (symbol ("==" :: String), Eq)+ , (symbol ("/=" :: String), Ne)+ , (symbol (">=" :: String), Ge)+ , (symbol (">" :: String) , Gt)+ , (symbol ("<=" :: String), Le)+ , (symbol ("<" :: String) , Lt)+ ]++bops :: M.HashMap Symbol Bop+bops = M.fromList [ (numSymbol "+", Plus)+ , (numSymbol "-", Minus)+ , (numSymbol "*", Times)+ , (numSymbol "/", Div)+ , (realSymbol "/", Div)+ , (numSymbol "%", Mod)+ ]+ where+ numSymbol :: String -> Symbol+ numSymbol = symbol . (++) "GHC.Num."+ realSymbol :: String -> Symbol+ realSymbol = symbol . (++) "GHC.Real."++splitArgs :: Bool -> C.Expr t -> (C.Expr t, [C.Arg t])+splitArgs allowTC exprt = (exprt', reverse args)+ where+ (exprt', args) = go exprt++ go (C.App (C.Var i) e) | ignoreVar i = go e+ go (C.App f (C.Var v)) | if allowTC then GM.isEmbeddedDictVar v else isErasable v = go f+ go (C.App f e) = (f', e:es) where (f', es) = go f+ go f = (f, [])++tomaybesymbol :: C.CoreExpr -> Maybe Symbol+tomaybesymbol (C.Var x) = Just $ symbol x+tomaybesymbol _ = Nothing++tosymbol :: C.CoreExpr -> LogicM (Located Symbol)+tosymbol e+ = case tomaybesymbol e of+ Just x -> return $ dummyLoc x+ _ -> throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied")++tosymbol' :: C.CoreExpr -> LogicM (Located Symbol)+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"++mkLit :: Literal -> Maybe Expr+mkLit (LitNumber _ n) = mkI n+-- mkLit (MachInt64 n) = mkI n+-- mkLit (MachWord n) = mkI n+-- mkLit (MachWord64 n) = mkI n+-- mkLit (LitInteger n _) = mkI n+mkLit (LitFloat n) = mkR n+mkLit (LitDouble n) = mkR n+mkLit (LitString s) = mkS s+mkLit (LitChar c) = mkC c+mkLit _ = Nothing -- ELit sym sort++mkI :: Integer -> Maybe Expr+mkI = Just . ECon . I++mkR :: Rational -> Maybe Expr+mkR = Just . ECon . F.R . fromRational++mkS :: ByteString -> Maybe Expr+mkS = Just . ESym . SL . decodeUtf8With lenientDecode++mkC :: Char -> Maybe Expr+mkC = Just . ECon . (`F.L` F.charSort) . repr+ where+ repr = T.pack . show . Data.Char.ord++ignoreVar :: Id -> Bool+ignoreVar i = simpleSymbolVar i `elem` ["I#", "D#"]++-- | Tries to determine if a 'CoreAlt' maps to one of the 'Integer' type constructors.+-- We need the disjuction for GHC >= 9, where the Integer now comes from the \"ghc-bignum\" package,+-- and it has different names for the constructors.+isBangInteger :: [C.CoreAlt] -> Bool+isBangInteger [Alt (C.DataAlt s) _ _, Alt (C.DataAlt jp) _ _, Alt (C.DataAlt jn) _ _]+ = (symbol s == "GHC.Integer.Type.S#" || symbol s == "GHC.Num.Integer.IS")+ && (symbol jp == "GHC.Integer.Type.Jp#" || symbol jp == "GHC.Num.Integer.IP")+ && (symbol jn == "GHC.Integer.Type.Jn#" || symbol jn == "GHC.Num.Integer.IN")+isBangInteger _ = False++isErasable :: Id -> Bool+isErasable v = F.notracepp msg $ isGhcSplId v && not (isDCId v)+ where+ msg = "isErasable: " ++ GM.showPpr (v, Ghc.idDetails v)++isGhcSplId :: Id -> Bool+isGhcSplId v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v)++isDCId :: Id -> Bool+isDCId v = case Ghc.idDetails v of+ DataConWorkId _ -> True+ DataConWrapId _ -> True+ _ -> False++isANF :: Id -> Bool+isANF v = isPrefixOfSym (symbol ("lq_anf" :: String)) (simpleSymbolVar v)++isDead :: Id -> Bool+isDead = isDeadOcc . occInfo . Ghc.idInfo++class Simplify a where+ simplify :: Bool -> a -> a+ inline :: (Id -> Bool) -> a -> a++ normalize :: Bool -> a -> a+ normalize allowTC = inline_preds . inline_anf . simplify allowTC+ where+ inline_preds = inline (eqType boolTy . GM.expandVarType)+ inline_anf = inline isANF++instance Simplify C.CoreExpr where+ simplify _ e@(C.Var _)+ = e+ simplify _ e@(C.Lit _)+ = e+ simplify allowTC (C.App e (C.Type _))+ = simplify allowTC e+ simplify allowTC (C.App e (C.Var dict)) | (if allowTC then GM.isEmbeddedDictVar else isErasable) dict+ = simplify allowTC e+ simplify allowTC (C.App (C.Lam x e) _) | isDead x+ = simplify allowTC e+ simplify allowTC (C.App e1 e2)+ = C.App (simplify allowTC e1) (simplify allowTC e2)+ simplify allowTC (C.Lam x e) | isTyVar x+ = simplify allowTC e+ simplify allowTC (C.Lam x e) | (if allowTC then GM.isEmbeddedDictVar else isErasable) x+ = simplify allowTC e+ simplify allowTC (C.Lam x e)+ = C.Lam x (simplify allowTC e)+ simplify allowTC (C.Let (C.NonRec x _) e) | (if allowTC then GM.isEmbeddedDictVar else isErasable) x+ = simplify allowTC e+ simplify allowTC (C.Let (C.Rec xes) e) | all ((if allowTC then GM.isEmbeddedDictVar else isErasable) . fst) xes+ = simplify allowTC e+ simplify allowTC (C.Let xes e)+ = C.Let (simplify allowTC xes) (simplify allowTC e)+ simplify allowTC (C.Case e x _t alts@[Alt _ _ ee,_,_]) | isBangInteger alts+ -- XXX(matt): seems to be for debugging?+ = -- Misc.traceShow ("To simplify allowTC case") $ + sub (M.singleton x (simplify allowTC e)) (simplify allowTC ee)+ simplify allowTC (C.Case e x t alts)+ = C.Case (simplify allowTC e) x t (filter (not . isPatErrorAlt) (simplify allowTC <$> alts))+ simplify allowTC (C.Cast e c)+ = C.Cast (simplify allowTC e) c+ simplify allowTC (C.Tick _ e)+ = simplify allowTC e+ simplify _ (C.Coercion c)+ = C.Coercion c+ simplify _ (C.Type t)+ = C.Type t++ inline p (C.Let (C.NonRec x ex) e) | p x+ = sub (M.singleton x (inline p ex)) (inline p e)+ inline p (C.Let xes e) = C.Let (inline p xes) (inline p e)+ inline p (C.App e1 e2) = C.App (inline p e1) (inline p e2)+ inline p (C.Lam x e) = C.Lam x (inline p e)+ inline p (C.Case e x t alts) = C.Case (inline p e) x t (inline p <$> alts)+ inline p (C.Cast e c) = C.Cast (inline p e) c+ inline p (C.Tick t e) = C.Tick t (inline p e)+ inline _ (C.Var x) = C.Var x+ inline _ (C.Lit l) = C.Lit l+ inline _ (C.Coercion c) = C.Coercion c+ inline _ (C.Type t) = C.Type t+++instance Simplify C.CoreBind where+ simplify allowTC (C.NonRec x e) = C.NonRec x (simplify allowTC e)+ simplify allowTC (C.Rec xes) = C.Rec (Misc.mapSnd (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)++instance Simplify C.CoreAlt where+ simplify allowTC (Alt c xs e) = Alt c xs (simplify allowTC e)+ -- where xs = F.tracepp _msg xs0+ -- _msg = "isCoVars? " ++ F.showpp [(x, isCoVar x, varType x) | x <- xs0]+ inline p (Alt c xs e) = Alt c xs (inline p e)
+ src/Language/Haskell/Liquid/Transforms/InlineAux.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Haskell.Liquid.Transforms.InlineAux+ ( inlineAux+ )+where+import qualified Language.Haskell.Liquid.UX.Config as UX+import Liquid.GHC.API+import Control.Arrow (second)+import qualified Language.Haskell.Liquid.GHC.Misc+ as GM+import qualified Data.HashMap.Strict as M++inlineAux :: UX.Config -> Module -> CoreProgram -> CoreProgram+inlineAux cfg m cbs = if UX.auxInline cfg then occurAnalysePgm m (const False) (const False) [] (map f cbs) else cbs+ where+ f :: CoreBind -> CoreBind+ f all'@(NonRec x e)+ | Just (dfunId, methodToAux) <- M.lookup x auxToMethodToAux = NonRec+ x+ (inlineAuxExpr dfunId methodToAux e)+ | otherwise = all'+ f (Rec bs) = Rec (fmap g bs)+ where+ g all'@(x, e)+ | Just (dfunId, methodToAux) <- M.lookup x auxToMethodToAux+ = (x, inlineAuxExpr dfunId methodToAux e)+ | otherwise+ = all'+ auxToMethodToAux = mconcat $ fmap (uncurry dfunIdSubst) (grepDFunIds cbs)+++-- inlineDFun :: DynFlags -> CoreProgram -> IO CoreProgram+-- inlineDFun df cbs = mapM go cbs+-- where+-- go orig@(NonRec x e) | isDFunId x = do+-- -- e''' <- simplifyExpr df e''+-- let newBody = mkCoreApps (GM.tracePpr ("substituted type:" ++ GM.showPpr (exprType (mkCoreApps e' (Var <$> binders)))) e') (fmap Var binders)+-- bind = NonRec (mkWildValBinder (exprType newBody)) newBody+-- pure $ NonRec x (mkLet bind e)+-- | otherwise = pure orig+-- where+-- -- wcBinder = mkWildValBinder t+-- (binders, _) = GM.tracePpr "collectBinders"$ collectBinders e+-- e' = substExprAll empty subst e+-- go recs = pure recs+-- subst = buildDictSubst cbs++-- grab the dictionaries+grepDFunIds :: CoreProgram -> [(DFunId, CoreExpr)]+grepDFunIds = filter (isDFunId . fst) . flattenBinds++isClassOpAuxOccName :: OccName -> Bool+isClassOpAuxOccName occ = case occNameString occ of+ '$' : 'c' : _ -> True+ _ -> False++isClassOpAuxOf :: Id -> Id -> Bool+isClassOpAuxOf aux method = case occNameString $ getOccName aux of+ '$' : 'c' : rest -> rest == occNameString (getOccName method)+ _ -> False++dfunIdSubst :: DFunId -> CoreExpr -> M.HashMap Id (Id, M.HashMap Id Id)+dfunIdSubst dfunId e = M.fromList $ zip auxIds (repeat (dfunId, methodToAux))+ where+ methodToAux = M.fromList+ [ (m, aux) | m <- methods, aux <- auxIds, aux `isClassOpAuxOf` m ]+ (_, _, cls, _) = tcSplitDFunTy (idType dfunId)+ auxIds = filter (isClassOpAuxOccName . getOccName) (exprFreeVarsList e)+ methods = classAllSelIds cls++inlineAuxExpr :: DFunId -> M.HashMap Id Id -> CoreExpr -> CoreExpr+inlineAuxExpr dfunId methodToAux = go+ where+ go :: CoreExpr -> CoreExpr+ go (Lam b body) = Lam b (go body)+ go (Let b body)+ | NonRec x e <- b, isDictId x =+ go $ substExpr (extendIdSubst emptySubst x e) body+ | otherwise = Let (mapBnd go b) (go body)+ go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts)+ go (Cast e c ) = Cast (go e) c+ go (Tick t e ) = Tick t (go e)+ go e+ | (Var m, args) <- collectArgs e+ , Just aux <- M.lookup m methodToAux+ , arg : argsNoTy <- dropWhile isTypeArg args+ , (Var x, argargs) <- collectArgs arg+ , x == dfunId+ = GM.notracePpr ("inlining in" ++ GM.showPpr e)+ $ mkCoreApps (Var aux) (argargs ++ (go <$> argsNoTy))+ go (App e0 e1) = App (go e0) (go e1)+ go e = e+++-- modified from Rec.hs+mapBnd :: (Expr b -> Expr b) -> Bind b -> Bind b+mapBnd f (NonRec b e) = NonRec b (f e)+mapBnd f (Rec bs ) = Rec (map (second f) bs)++mapAlt :: (Expr b -> Expr b) -> Alt b -> Alt b+mapAlt f (Alt d bs e) = Alt d bs (f e)
+ src/Language/Haskell/Liquid/Transforms/Rec.hs view
@@ -0,0 +1,291 @@+{-# 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 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 :: !Int+ , _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 VisArg Many (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 Int where+ fresh _ = freshInt++instance Freshable Unique where+ fresh _ = freshUnique++instance Freshable Var where+ fresh v = fmap (setVarUnique v) freshUnique++freshInt :: MonadState TrEnv m => m Int+freshInt+ = do s <- get+ let n = freshIndex s+ put s{freshIndex = n+1}+ return n++freshUnique :: MonadState TrEnv m => m Unique+freshUnique = fmap (mkUnique 'X') freshInt+++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
@@ -0,0 +1,114 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Haskell.Liquid.Transforms.RefSplit (++ splitXRelatedRefs++ ) where++import Prelude hiding (error)++import Data.List (partition)+import Text.PrettyPrint.HughesPJ++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.PrettyPrint ()++import Language.Fixpoint.Types hiding (Predicate)+import Language.Fixpoint.Misc++splitXRelatedRefs :: Symbol -> SpecType -> (SpecType, SpecType)+splitXRelatedRefs x t = splitRType x t++++splitRType :: Symbol+ -> RType c tv (UReft Reft)+ -> (RType c tv (UReft Reft), RType c tv (UReft Reft))+splitRType f (RVar a r) = (RVar a r1, RVar a r2)+ where+ (r1, r2) = splitRef f r+splitRType f (RFun x i tx t r) = (RFun x i tx1 t1 r1, RFun x i tx2 t2 r2)+ where+ (tx1, tx2) = splitRType f tx+ (t1, t2) = splitRType f t+ (r1, r2) = splitRef f r+splitRType f (RAllT v t r) = (RAllT v t1 r1, RAllT v t2 r2)+ where+ (t1, t2) = splitRType f t+ (r1, r2) = splitRef f r+splitRType f (RAllP p t) = (RAllP p t1, RAllP p t2)+ where+ (t1, t2) = splitRType f t+splitRType f (RApp c ts rs r) = (RApp c ts1 rs1 r1, RApp c ts2 rs2 r2)+ where+ (ts1, ts2) = unzip (splitRType f <$> ts)+ (rs1, rs2) = unzip (splitUReft f <$> rs)+ (r1, r2) = splitRef f r+splitRType f (RAllE x tx t) = (RAllE x tx1 t1, RAllE x tx2 t2)+ where+ (tx1, tx2) = splitRType f tx+ (t1, t2) = splitRType f t+splitRType f (REx x tx t) = (REx x tx1 t1, REx x tx2 t2)+ where+ (tx1, tx2) = splitRType f tx+ (t1, t2) = splitRType f t+splitRType _ (RExprArg e) = (RExprArg e, RExprArg e)+splitRType f (RAppTy tx t r) = (RAppTy tx1 t1 r1, RAppTy tx2 t2 r2)+ where+ (tx1, tx2) = splitRType f tx+ (t1, t2) = splitRType f t+ (r1, r2) = splitRef f r+splitRType f (RRTy xs r o rt) = (RRTy xs1 r1 o rt1, RRTy xs2 r2 o rt2)+ where+ (xs1, xs2) = unzip (go <$> xs)+ (r1, r2) = splitRef f r+ (rt1, rt2) = splitRType f rt++ go (x, t) = let (t1, t2) = splitRType f t in ((x,t1), (x, t2))+splitRType f (RHole r) = (RHole r1, RHole r2)+ where+ (r1, r2) = splitRef f r+++splitUReft :: Symbol -> RTProp c tv (UReft Reft) -> (RTProp c tv (UReft Reft), RTProp c tv (UReft Reft))+splitUReft x (RProp xs (RHole r)) = (RProp xs (RHole r1), RProp xs (RHole r2))+ where+ (r1, r2) = splitRef x r+splitUReft x (RProp xs t) = (RProp xs t1, RProp xs t2)+ where+ (t1, t2) = splitRType x t++splitRef :: Symbol -> UReft Reft -> (UReft Reft, UReft Reft)+splitRef f (MkUReft r p) = (MkUReft r1 p1, MkUReft r2 p2)+ where+ (r1, r2) = splitReft f r+ (p1, p2) = splitPred f p++splitReft :: Symbol -> Reft -> (Reft, Reft)+splitReft f (Reft (v, xs)) = (Reft (v, pAnd xs1), Reft (v, pAnd xs2))+ where+ (xs1, xs2) = partition (isFree f) (unPAnd xs)++ unPAnd (PAnd ps) = concatMap unPAnd ps+ unPAnd p = [p]+++splitPred :: Symbol -> Predicate -> (Predicate, Predicate)+splitPred f (Pr ps) = (Pr ps1, Pr ps2)+ where+ (ps1, ps2) = partition g ps+ g p = any (isFree f) (thd3 <$> pargs p)+++class IsFree a where+ isFree :: Symbol -> a -> Bool++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
@@ -0,0 +1,504 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module contains functions for recursively "rewriting"+-- GHC core using "rules".++module Language.Haskell.Liquid.Transforms.Rewrite+ ( -- * Top level rewrite function+ rewriteBinds++ -- * Low-level Rewriting Function+ -- , rewriteWith++ -- * Rewrite Rule+ -- , RewriteRule++ ) where++import Liquid.GHC.API as Ghc hiding (showPpr, substExpr)+import Language.Haskell.Liquid.GHC.TypeRep ()+import Data.Maybe (fromMaybe)+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.UX.Config (Config, noSimplifyCore)+import qualified Data.List as L+import qualified Data.HashMap.Strict as M++--------------------------------------------------------------------------------+-- | Top-level rewriter --------------------------------------------------------+--------------------------------------------------------------------------------+rewriteBinds :: Config -> [CoreBind] -> [CoreBind]+rewriteBinds cfg+ | simplifyCore cfg+ = fmap (normalizeTuples + . rewriteBindWith undollar + . rewriteBindWith tidyTuples + . rewriteBindWith simplifyPatTuple)+ | otherwise+ = id++simplifyCore :: Config -> Bool+simplifyCore = not . noSimplifyCore++undollar :: RewriteRule+undollar = go + where + go e + -- matches `$ t1 t2 t3 f a` + | App e1 a <- untick e+ , App e2 f <- untick e1+ , App e3 t3 <- untick e2 + , App e4 t2 <- untick e3 + , App d t1 <- untick e4 + , Var v <- untick d + , v `hasKey` dollarIdKey+ , Type _ <- untick t1+ , Type _ <- untick t2+ , Type _ <- untick t3+ = 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++ + ++untick :: CoreExpr -> CoreExpr +untick (Tick _ e) = untick e +untick e = e ++tidyTuples :: RewriteRule+tidyTuples ce = Just $ evalState (go ce) []+ where+ 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 (Var v) x t alts)+ = Case (Var v) x t <$> mapM (goAltR v) alts+ 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++ goAltR v (Alt c bs e)+ = do m <- get+ case L.lookup (c,v) m of+ Just bs' -> return (Alt c bs' (substTuple bs' bs e))+ Nothing -> do let bs' = mkAlive <$> bs+ modify (((c,v),bs'):)+ return (Alt c bs' e)++++normalizeTuples :: CoreBind -> CoreBind+normalizeTuples cb+ | NonRec x e <- cb+ = NonRec x $ go e+ | Rec xes <- cb+ = let (xs,es) = unzip xes in+ Rec $ zip xs (go <$> es)+ where+ go (Let (NonRec x ex) e)+ | Case _ _ _ alts <- unTickExpr ex+ , [Alt _ vs (Var z)] <- alts+ , z `elem` vs+ = Let (NonRec z (go ex)) (substTuple [z] [x] (go e))+ 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)+ go (App e1 e2)+ = App (go e1) (go e2)+ go (Lam x e)+ = Lam x (go e)+ go (Case e b t alt)+ = Case (go e) b t ((\(Alt c bs e') -> Alt c bs (go e')) <$> alt)+ go (Cast e c)+ = Cast (go e) c+ go (Tick t e)+ = Tick t (go e)+ go (Type t)+ = Type t+ go (Coercion c)+ = Coercion c+ go (Lit l)+ = Lit l+ go (Var x)+ = Var x+++--------------------------------------------------------------------------------+-- | A @RewriteRule@ is a function that maps a CoreExpr to another+--------------------------------------------------------------------------------+type RewriteRule = CoreExpr -> Maybe CoreExpr+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+rewriteBindWith :: RewriteRule -> CoreBind -> CoreBind+--------------------------------------------------------------------------------+rewriteBindWith r (NonRec x e) = NonRec x (rewriteWith r e)+rewriteBindWith r (Rec xes) = Rec (mapSnd (rewriteWith r) <$> xes)++--------------------------------------------------------------------------------+rewriteWith :: RewriteRule -> CoreExpr -> CoreExpr+--------------------------------------------------------------------------------+rewriteWith tx = go+ where+ go = txTop . step+ txTop e = fromMaybe e (tx e)+ goB (Rec xes) = Rec (mapSnd 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')+ step (Lam x e) = Lam x (go e)+ step (Cast e c) = Cast (go e) c+ step (Tick t e) = Tick t (go e)+ step (Case e x t cs) = Case (go e) x t ((\(Alt c bs e') -> Alt c bs (go e')) <$> cs)+ step e@(Type _) = e+ step e@(Lit _) = e+ step e@(Var _) = e+ step e@(Coercion _) = e+++--------------------------------------------------------------------------------+-- | 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+++_safeSimplifyPatTuple :: RewriteRule+_safeSimplifyPatTuple e+ | Just e' <- simplifyPatTuple e+ , Ghc.exprType e' == Ghc.exprType e+ = Just e'+ | otherwise+ = 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)++ 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++ 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+ 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++isIrrefutErrorVar :: Var -> Bool+-- isIrrefutErrorVar _x = False -- Ghc.iRREFUT_PAT_ERROR_ID == x -- TODO:GHC-863+isIrrefutErrorVar x = x == Ghc.pAT_ERROR_ID++--------------------------------------------------------------------------------+-- | `substTuple xs ys e'` returns e' [y1 := x1,...,yn := xn]+--------------------------------------------------------------------------------+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'+ where+ xs' = {- F.symbol -} show <$> xs+ ys' = {- F.symbol -} show <$> ys++isTuple :: CoreExpr -> Maybe [Var]+isTuple e+ | (Var t, es) <- collectArgs e+ , isTupleId t+ , Just xs <- mapM isVar (secondHalf es)+ = Just xs+ | otherwise+ = Nothing++isVar :: CoreExpr -> Maybe Var+isVar (Var x) = Just x+isVar _ = Nothing++secondHalf :: [a] -> [a]+secondHalf xs = drop (n `div` 2) xs+ where+ n = length xs
+ src/Language/Haskell/Liquid/Transforms/Simplify.hs view
@@ -0,0 +1,43 @@+module Language.Haskell.Liquid.Transforms.Simplify (simplifyBounds) where++import Prelude hiding (error)+import Language.Haskell.Liquid.Types+import Language.Fixpoint.Types+import Language.Fixpoint.Types.Visitor+-- import Control.Applicative ((<$>))+++simplifyBounds :: SpecType -> SpecType+simplifyBounds = fmap go+ where+ go x = x { ur_reft = go' $ ur_reft x }+ -- OLD go' (Reft (v, rs)) = Reft(v, filter (not . isBoundLike) rs)+ go' (Reft (v, p)) = Reft(v, dropBoundLike p)++dropBoundLike :: Expr -> Expr+dropBoundLike p+ | isKvar p = p+ | isBoundLikePred p = mempty+ | otherwise = p+ where+ isKvar = not . null . kvarsExpr++isBoundLikePred :: Expr -> Bool+isBoundLikePred (PAnd ps) = simplifyLen <= length [p | p <- ps, isImp p ]+isBoundLikePred _ = False++isImp :: Expr -> Bool+isImp (PImp _ _) = True+isImp _ = False++-- OLD isBoundLike (RConc pred) = isBoundLikePred pred+-- OLD isBoundLike (RKvar _ _) = False+++-- OLD moreThan 0 _ = True+-- OLD moreThan _ [] = False+-- OLD moreThan i (True : xs) = moreThan (i-1) xs+-- OLD moreThan i (False : xs) = moreThan i xs++simplifyLen :: Int+simplifyLen = 5
+ src/Language/Haskell/Liquid/Types.hs view
@@ -0,0 +1,17 @@+-- | 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
@@ -0,0 +1,162 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.Types.Bounds (++ Bound(..),++ RBound, RRBound,++ RBEnv, RRBEnv,++ makeBound,++ ) where++import Prelude hiding (error)+import Text.PrettyPrint.HughesPJ+import GHC.Generics+import Data.List (partition)+import Data.Maybe+import Data.Hashable+import Data.Bifunctor+import Data.Data+import qualified Data.Binary as B+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.RefType+++data Bound t e = Bound+ { bname :: LocSymbol -- ^ The name of the bound+ , tyvars :: [t] -- ^ Type variables that appear in the bounds+ , 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)++type RBound = RRBound RSort+type RRBound tv = Bound tv F.Expr+type RBEnv = M.HashMap LocSymbol RBound+type RRBEnv tv = M.HashMap LocSymbol (RRBound tv)+++instance Hashable (Bound t e) where+ hashWithSalt i = hashWithSalt i . bname++instance Eq (Bound t e) where+ b1 == b2 = bname b1 == bname b2++instance (PPrint e, PPrint t) => (Show (Bound t e)) where+ show = showpp+++instance (PPrint e, PPrint t) => (PPrint (Bound t e)) where+ pprintTidy k (Bound s vs ps ys e) = "bound" <+> pprintTidy k s <+>+ "forall" <+> pprintTidy k vs <+> "." <+>+ pprintTidy k (fst <$> ps) <+> "=" <+>+ ppBsyms k (fst <$> ys) <+> pprintTidy k e+ where+ ppBsyms _ [] = ""+ ppBsyms k' xs = "\\" <+> pprintTidy k' xs <+> "->"++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+ second f (Bound s vs ps xs e) = Bound s vs ps xs (f e)++makeBound :: (PPrint r, UReftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r)+ => RRBound RSort -> [RRType r] -> [F.Symbol] -> RRType r -> RRType r+makeBound (Bound _ vs ps xs expr) ts qs+ = RRTy cts mempty OCons+ where+ cts = (\(x, t) -> (x, foldr subsTyVarMeet t su)) <$> cts'++ cts' = makeBoundType penv rs xs++ penv = zip (val . fst <$> ps) qs+ rs = bkImp [] expr++ bkImp acc (F.PImp p q) = bkImp (p:acc) q+ bkImp acc p = p:acc++ su = [(α, toRSort t, t) | (RVar α _, t) <- zip vs ts ]++makeBoundType :: (PPrint r, UReftable r)+ => [(F.Symbol, F.Symbol)]+ -> [F.Expr]+ -> [(LocSymbol, RSort)]+ -> [(F.Symbol, RRType r)]+makeBoundType penv (q:qs) xts = go xts+ where+ -- NV TODO: Turn this into a proper error+ go [] = panic Nothing "Bound with empty symbols"++ 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))+ (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))+ tq t x = ofRSort t `strengthen` makeRef penv x q++ (ps, rs) = partitionPs penv qs+++-- NV TODO: Turn this into a proper error+makeBoundType _ _ _ = panic Nothing "Bound with empty predicates"+++partitionPs :: [(F.Symbol, F.Symbol)] -> [F.Expr] -> (M.HashMap F.Symbol [UsedPVar], [F.Expr])+partitionPs penv qs = Misc.mapFst makeAR $ partition (isPApp penv) qs+ where+ makeAR ps = M.fromListWith (++) $ map (toUsedPVars penv) ps++isPApp :: [(F.Symbol, a)] -> F.Expr -> Bool+isPApp penv (F.EApp (F.EVar p) _) = isJust $ lookup p penv+isPApp penv (F.EApp e _) = isPApp penv e+isPApp _ _ = False++toUsedPVars :: [(F.Symbol, F.Symbol)] -> F.Expr -> (F.Symbol, [PVar ()])+toUsedPVars penv q@(F.EApp _ expr) = (sym, [toUsedPVar penv q])+ where+ -- NV : TODO make this a better error+ sym = case {- unProp -} expr of {F.EVar x -> x; e -> todo Nothing ("Bound fails in " ++ show e) }+toUsedPVars _ _ = impossible Nothing "This cannot happen"++toUsedPVar :: [(F.Symbol, F.Symbol)] -> F.Expr -> PVar ()+toUsedPVar penv ee@(F.EApp _ _)+ = PV q (PVProp ()) e (((), F.dummySymbol,) <$> es')+ where+ F.EVar e = {- unProp $ -} last es+ es' = init es+ Just q = lookup p penv+ (F.EVar p, es) = F.splitEApp ee++toUsedPVar _ _ = impossible Nothing "This cannot happen"++-- `makeRef` is used to make the refinement of the last implication,+-- thus it can contain both concrete and abstract refinements++makeRef :: (UReftable r) => [(F.Symbol, F.Symbol)] -> LocSymbol -> F.Expr -> r+makeRef penv v (F.PAnd rs) = ofUReft (MkUReft (F.Reft (val v, F.pAnd rrs)) r)+ where+ r = Pr (toUsedPVar penv <$> pps)+ (pps, rrs) = partition (isPApp penv) rs++makeRef penv v rr+ | isPApp penv rr = ofUReft (MkUReft (F.Reft(val v, mempty)) r)+ where+ r = Pr [toUsedPVar penv rr]++makeRef _ v p = F.ofReft (F.Reft (val v, p))
+ src/Language/Haskell/Liquid/Types/Dictionaries.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Language.Haskell.Liquid.Types.Dictionaries (+ makeDictionaries+ , makeDictionary+ , dfromList+ , dmapty+ , dmap+ , dinsert+ , dlookup+ , dhasinfo+ , fromRISig+ ) 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 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 ----------------------------------------------------+--------------------------------------------------------------------------------++dfromList :: [(Ghc.Var, M.HashMap F.Symbol (RISig t))] -> DEnv Ghc.Var t+dfromList = DEnv . M.fromList++dmapty :: (a -> b) -> DEnv v a -> DEnv v b+dmapty f (DEnv e) = DEnv (M.map (M.map (fmap f)) e)++-- REBARE: mapRISig :: (a -> b) -> RISig a -> RISig b+-- REBARE: mapRISig f (RIAssumed t) = RIAssumed (f t)+-- REBARE: mapRISig f (RISig t) = RISig (f t)++fromRISig :: RISig a -> a+fromRISig (RIAssumed t) = t+fromRISig (RISig t) = t++dmap :: (v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2+dmap f xts = M.map f xts++dinsert :: (Eq x, Hashable x)+ => DEnv x ty -> x -> M.HashMap F.Symbol (RISig ty) -> DEnv x ty+dinsert (DEnv denv) x xts = DEnv $ M.insert x xts denv++dlookup :: (Eq k, Hashable k)+ => DEnv k t -> k -> Maybe (M.HashMap F.Symbol (RISig t))+dlookup (DEnv denv) x = M.lookup x denv+++dhasinfo :: (F.Symbolic a1, Show a) => Maybe (M.HashMap F.Symbol a) -> a1 -> Maybe a+dhasinfo Nothing _ = Nothing+dhasinfo (Just xts) x = M.lookup x' xts+ where+ x' = GM.dropModuleNamesCorrect (F.symbol x)
+ src/Language/Haskell/Liquid/Types/Equality.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleInstances #-}++-- Syntactic Equality of Types up tp forall type renaming++module Language.Haskell.Liquid.Types.Equality where++import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.Types+import qualified Liquid.GHC.API as Ghc++import Control.Monad.Writer.Lazy+-- import Control.Monad+import qualified Data.List as L++instance REq SpecType where+ t1 =*= t2 = compareRType t1 t2++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)++ (res, ys) = runWriter (go i1 i2)+ go :: SpecType -> SpecType -> Writer [(RTyVar, RTyVar)] Bool+ go (RAllT x1 t1 r1) (RAllT x2 t2 r2)+ | RTV v1 <- ty_var_value x1+ , RTV v2 <- ty_var_value x2+ , r1 =*= r2+ = go t1 (subt (v2, Ghc.mkTyVarTy v1) t2)++ go (RVar v1 r1) (RVar v2 r2)+ = do tell [(v1, v2)]+ return (r1 =*= r2)+ -- = v1 == v2 && r1 =*= r2+ go (RFun x1 _ t11 t12 r1) (RFun x2 _ t21 t22 r2)+ | x1 == x2 && r1 =*= r2+ = liftM2 (&&) (go t11 t21) (go t12 t22)+ go (RAllP x1 t1) (RAllP x2 t2)+ | x1 == x2+ = go t1 t2+ go (RApp x1 ts1 ps1 r1) (RApp x2 ts2 ps2 r2)+ | x1 == x2 &&+ r1 =*= r2 && and (zipWith (=*=) ps1 ps2)+ = and <$> zipWithM go ts1 ts2+ go (RAllE x1 t11 t12) (RAllE x2 t21 t22) | x1 == x2+ = liftM2 (&&) (go t11 t21) (go t12 t22)+ go (REx x1 t11 t12) (REx x2 t21 t22) | x1 == x2+ = liftM2 (&&) (go t11 t21) (go t12 t22)+ go (RExprArg e1) (RExprArg e2)+ = return (e1 =*= e2)+ go (RAppTy t11 t12 r1) (RAppTy t21 t22 r2) | r1 =*= r2+ = liftM2 (&&) (go t11 t21) (go t12 t22)+ go (RRTy _ _ _ r1) (RRTy _ _ _ r2)+ = return (r1 =*= r2)+ go (RHole r1) (RHole r2)+ = return (r1 =*= r2)+ go _t1 _t2+ = return False++class REq a where+ (=*=) :: a -> a -> Bool++instance REq t2 => REq (Ref t1 t2) where+ (RProp _ t1) =*= (RProp _ t2) = t1 =*= t2++instance REq (UReft F.Reft) where+ (MkUReft r1 p1) =*= (MkUReft r2 p2)+ = r1 =*= r2 && p1 == p2++instance REq F.Reft where+ F.Reft (v1, e1) =*= F.Reft (v2, e2) = F.subst1 e1 (v1, F.EVar v2) =*= e2++instance REq F.Expr where+ e1 =*= e2 = go (F.simplify e1) (F.simplify e2)+ where go r1 r2 = F.notracepp ("comparing " ++ showpp (F.toFix r1, F.toFix r2)) $ r1 == r2++instance REq r => REq (Located r) where+ t1 =*= t2 = val t1 =*= val t2
+ src/Language/Haskell/Liquid/Types/Errors.hs view
@@ -0,0 +1,1089 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-} -- PPrint and aeson instances.++-- | This module contains the *types* related creating Errors.+-- It depends only on Fixpoint and basic haskell libraries,+-- and hence, should be importable everywhere.++module Language.Haskell.Liquid.Types.Errors (+ -- * Generic Error Type+ TError (..)++ -- * Parse error synonym+ , ParseError++ -- * Error with Source Context+ , CtxError (..)+ , errorsWithContext++ -- * Subtyping Obligation Type+ , Oblig (..)++ -- * Adding a Model of the context+ , WithModel (..), dropModel++ -- * Panic (unexpected failures)+ , UserError+ , panic+ , panicDoc+ , todo+ , impossible+ , uError+ , sourceErrors+ , errDupSpecs++ -- * Printing Errors+ , ppError+ , ppTicks++ -- * SrcSpan Helpers+ , packRealSrcSpan+ , unpackRealSrcSpan+ , srcSpanFileMb+ ) where++import Prelude hiding (error, span)++import GHC.Generics+import Control.DeepSeq+import qualified Control.Exception as Ex+import Data.Typeable (Typeable)+import Data.Generics (Data)+import qualified Data.Binary as B+import qualified Data.Maybe as Mb+import Data.Aeson hiding (Result)+import Data.Hashable+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import Data.Void+import System.Directory+import System.FilePath+import Text.PrettyPrint.HughesPJ+import qualified Text.Megaparsec as P++import Liquid.GHC.API as Ghc hiding ( Expr+ , ($+$)+ , nest+ , text+ , blankLine+ , (<+>)+ , vcat+ , hsep+ , comma+ , colon+ , parens+ , empty+ , char+ , panic+ , int+ , hcat+ )+import Language.Fixpoint.Types (pprint, showpp, Tidy (..), PPrint (..), Symbol, Expr, SubcId)+import qualified Language.Fixpoint.Misc as Misc+import qualified Language.Haskell.Liquid.Misc as Misc+import Language.Haskell.Liquid.Misc ((<->))+import Language.Haskell.Liquid.Types.Generics++type ParseError = P.ParseError String Void++instance PPrint ParseError where+ pprintTidy _ e = vcat $ text <$> ls+ where+ ls = lines $ P.parseErrorTextPretty e++--------------------------------------------------------------------------------+-- | Context information for Error Messages ------------------------------------+--------------------------------------------------------------------------------+data CtxError t = CtxError+ { ctErr :: TError t+ , ctCtx :: Doc+ } deriving (Functor)++instance Eq (CtxError t) where+ e1 == e2 = ctErr e1 == ctErr e2++--------------------------------------------------------------------------------+errorsWithContext :: [TError Doc] -> IO [CtxError Doc]+--------------------------------------------------------------------------------+errorsWithContext es+ = Misc.concatMapM fileErrors+ $ Misc.groupList [ (srcSpanFileMb (pos e), e) | e <- es ]++fileErrors :: (Maybe FilePath, [TError Doc]) -> IO [CtxError Doc]+fileErrors (fp, errs) = do+ fb <- getFileBody fp+ return (errorWithContext fb <$> errs)++errorWithContext :: FileBody -> TError Doc -> CtxError Doc+errorWithContext fb e = CtxError e (srcSpanContext fb (pos e))++srcSpanContext :: FileBody -> SrcSpan -> Doc+srcSpanContext fb sp+ | Just (l, c, l', c') <- srcSpanInfo sp+ = makeContext l c c' (getFileLines fb l l')+ | otherwise+ = empty++srcSpanInfo :: SrcSpan -> Maybe (Int, Int, Int, Int)+srcSpanInfo (RealSrcSpan s _)+ = Just (l, c, l', c')+ where+ l = srcSpanStartLine s+ c = srcSpanStartCol s+ l' = srcSpanEndLine s+ c' = srcSpanEndCol s+srcSpanInfo _ = Nothing++getFileLines :: FileBody -> Int -> Int -> [String]+getFileLines fb i j = slice (i - 1) (j - 1) fb++getFileBody :: Maybe FilePath -> IO FileBody+getFileBody Nothing =+ return []+getFileBody (Just f) = do+ b <- doesFileExist f+ if b then lines <$> Misc.sayReadFile f+ else return []++type FileBody = [String]++slice :: Int -> Int -> [a] -> [a]+slice i j xs = take (j - i + 1) (drop i xs)++makeContext :: Int -> Int -> Int -> [String] -> Doc+makeContext _ _ _ [] = empty+makeContext l c c' [s] = makeContext1 l c c' s+makeContext l _ _ ss = vcat $ text " "+ : zipWith makeContextLine [l..] ss+ ++ [ text " "+ , text " " ]++makeContextLine :: Int -> String -> Doc+makeContextLine l s = lnum l <+> text s+ where+ lnum n = text (show n) <+> text "|"++makeContext1 :: Int -> Int -> Int -> String -> Doc+makeContext1 l c c' s = vcat [ text " "+ , lnum l <+> (text s $+$ cursor)+ , text " "+ , text " "+ ]+ where+ lnum n = text (show n) <+> text "|"+ cursor = blanks (c - 1) <-> pointer (max 1 (c' - c))+ blanks n = text $ replicate n ' '+ pointer n = text $ replicate n '^'++--------------------------------------------------------------------------------+-- | Different kinds of Check "Obligations" ------------------------------------+--------------------------------------------------------------------------------++data Oblig+ = OTerm -- ^ Obligation that proves termination+ | OInv -- ^ Obligation that proves invariants+ | OCons -- ^ Obligation that proves subtyping constraints+ deriving (Eq, Generic, Data, Typeable)+ deriving Hashable via Generically Oblig++instance B.Binary Oblig+instance Show Oblig where+ show OTerm = "termination-condition"+ show OInv = "invariant-obligation"+ show OCons = "constraint-obligation"++instance NFData Oblig++instance PPrint Oblig where+ pprintTidy _ = ppOblig++ppOblig :: Oblig -> Doc+ppOblig OCons = text "Constraint Check"+ppOblig OTerm = text "Termination Check"+ppOblig OInv = text "Invariant Check"++--------------------------------------------------------------------------------+-- | Generic Type for Error Messages -------------------------------------------+--------------------------------------------------------------------------------++-- | INVARIANT : all Error constructors should have a pos field++data TError t =+ ErrSubType { pos :: !SrcSpan+ , msg :: !Doc+ , cid :: Maybe SubcId+ , ctx :: !(M.HashMap Symbol t)+ , tact :: !t+ , texp :: !t+ } -- ^ liquid type error++ | ErrSubTypeModel+ { pos :: !SrcSpan+ , msg :: !Doc+ , cid :: Maybe SubcId+ , ctxM :: !(M.HashMap Symbol (WithModel t))+ , tactM :: !(WithModel t)+ , texp :: !t+ } -- ^ liquid type error with a counter-example++ | ErrFCrash { pos :: !SrcSpan+ , msg :: !Doc+ , ctx :: !(M.HashMap Symbol t)+ , tact :: !t+ , texp :: !t+ } -- ^ liquid type error++ | ErrHole { pos :: !SrcSpan+ , msg :: !Doc+ , ctx :: !(M.HashMap Symbol t)+ , svar :: !Symbol+ , thl :: !t+ } -- ^ hole type++ | ErrHoleCycle+ { pos :: !SrcSpan+ , holesCycle :: [Symbol] -- Var?+ } -- ^ hole dependencies form a cycle error++ | ErrAssType { pos :: !SrcSpan+ , obl :: !Oblig+ , msg :: !Doc+ , ctx :: !(M.HashMap Symbol t)+ , cond :: t+ } -- ^ condition failure error++ | ErrParse { pos :: !SrcSpan+ , msg :: !Doc+ , pErr :: !ParseError+ } -- ^ specification parse error++ | ErrTySpec { pos :: !SrcSpan+ , knd :: !(Maybe Doc)+ , var :: !Doc+ , typ :: !t+ , msg :: !Doc+ } -- ^ sort error in specification++ | ErrTermSpec { pos :: !SrcSpan+ , var :: !Doc+ , msg :: !Doc+ , exp :: !Expr+ , typ :: !t+ , msg' :: !Doc+ } -- ^ sort error in specification++ | ErrDupAlias { pos :: !SrcSpan+ , var :: !Doc+ , kind :: !Doc+ , locs :: ![SrcSpan]+ } -- ^ multiple alias with same name error++ | ErrDupSpecs { pos :: !SrcSpan+ , var :: !Doc+ , locs:: ![SrcSpan]+ } -- ^ multiple specs for same binder error++ | ErrDupIMeas { pos :: !SrcSpan+ , var :: !Doc+ , tycon :: !Doc+ , locs :: ![SrcSpan]+ } -- ^ multiple definitions of the same instance measure++ | ErrDupMeas { pos :: !SrcSpan+ , var :: !Doc+ , locs :: ![SrcSpan]+ } -- ^ multiple definitions of the same measure++ | ErrDupField { pos :: !SrcSpan+ , dcon :: !Doc+ , field :: !Doc+ } -- ^ duplicate fields in same datacon++ | ErrDupNames { pos :: !SrcSpan+ , var :: !Doc+ , names :: ![Doc]+ } -- ^ name resolves to multiple possible GHC vars++ | ErrBadData { pos :: !SrcSpan+ , var :: !Doc+ , msg :: !Doc+ } -- ^ bad data type specification (?)++ | ErrDataCon { pos :: !SrcSpan+ , var :: !Doc+ , msg :: !Doc+ } -- ^ refined datacon mismatches haskell datacon++ | ErrDataConMismatch+ { pos :: !SrcSpan+ , var :: !Doc+ , dcs :: [Doc]+ , rdcs :: [Doc]+ } -- ^ constructors in refinement do not match original datatype++ | ErrInvt { pos :: !SrcSpan+ , inv :: !t+ , msg :: !Doc+ } -- ^ Invariant sort error++ | ErrIAl { pos :: !SrcSpan+ , inv :: !t+ , msg :: !Doc+ } -- ^ Using sort error++ | ErrIAlMis { pos :: !SrcSpan+ , tAs :: !t+ , tUs :: !t+ , msg :: !Doc+ } -- ^ Incompatible using error++ | ErrMeas { pos :: !SrcSpan+ , ms :: !Doc+ , msg :: !Doc+ } -- ^ Measure sort error++ | ErrHMeas { pos :: !SrcSpan+ , ms :: !Doc+ , msg :: !Doc+ } -- ^ Haskell bad Measure error++ | ErrUnbound { pos :: !SrcSpan+ , var :: !Doc+ } -- ^ Unbound symbol in specification++ | ErrUnbPred { pos :: !SrcSpan+ , var :: !Doc+ } -- ^ Unbound predicate being applied++ | ErrGhc { pos :: !SrcSpan+ , msg :: !Doc+ } -- ^ GHC error: parsing or type checking++ | ErrResolve { pos :: !SrcSpan+ , kind :: !Doc+ , var :: !Doc+ , msg :: !Doc+ } -- ^ Name resolution error++ | ErrMismatch { pos :: !SrcSpan -- ^ haskell type location+ , var :: !Doc+ , msg :: !Doc+ , hs :: !Doc+ , lqTy :: !Doc+ , diff :: !(Maybe (Doc, Doc)) -- ^ specific pair of things that mismatch+ , lqPos :: !SrcSpan -- ^ lq type location+ } -- ^ Mismatch between Liquid and Haskell types++ | ErrPartPred { pos :: !SrcSpan+ , ectr :: !Doc+ , var :: !Doc+ , argN :: !Int+ , expN :: !Int+ , actN :: !Int+ } -- ^ Mismatch in expected/actual args of abstract refinement++ | ErrAliasCycle { pos :: !SrcSpan+ , acycle :: ![(SrcSpan, Doc)]+ } -- ^ Cyclic Refined Type Alias Definitions++ | ErrIllegalAliasApp { pos :: !SrcSpan+ , dname :: !Doc+ , dpos :: !SrcSpan+ } -- ^ Illegal RTAlias application (from BSort, eg. in PVar)++ | ErrAliasApp { pos :: !SrcSpan+ , dname :: !Doc+ , dpos :: !SrcSpan+ , msg :: !Doc+ }++ | ErrTermin { pos :: !SrcSpan+ , bind :: ![Doc]+ , msg :: !Doc+ } -- ^ Termination Error++ | ErrStTerm { pos :: !SrcSpan+ , dname :: !Doc+ , msg :: !Doc+ } -- ^ Termination Error++ | ErrILaw { pos :: !SrcSpan+ , cname :: !Doc+ , iname :: !Doc+ , msg :: !Doc+ } -- ^ Instance Law Error++ | ErrRClass { pos :: !SrcSpan+ , cls :: !Doc+ , insts :: ![(SrcSpan, Doc)]+ } -- ^ Refined Class/Interfaces Conflict++ | ErrMClass { pos :: !SrcSpan+ , var :: !Doc+ } -- ^ Standalone class method refinements++ | ErrBadQual { pos :: !SrcSpan+ , qname :: !Doc+ , msg :: !Doc+ } -- ^ Non well sorted Qualifier++ | ErrSaved { pos :: !SrcSpan+ , nam :: !Doc+ , msg :: !Doc+ } -- ^ Previously saved error, that carries over after DiffCheck++ | ErrFilePragma { pos :: !SrcSpan+ }++ | ErrTyCon { pos :: !SrcSpan+ , msg :: !Doc+ , tcname :: !Doc+ }++ | ErrLiftExp { pos :: !SrcSpan+ , msg :: !Doc+ }++ | ErrParseAnn { pos :: !SrcSpan+ , msg :: !Doc+ }++ | ErrNoSpec { pos :: !SrcSpan+ , srcF :: !Doc+ , bspF :: !Doc+ }++ | ErrFail { pos :: !SrcSpan+ , var :: !Doc+ }++ | ErrFailUsed { pos :: !SrcSpan+ , var :: !Doc+ , clients :: ![Doc]+ }++ | ErrRewrite { pos :: !SrcSpan+ , msg :: !Doc+ }++ | ErrPosTyCon { pos :: SrcSpan+ , tc :: !Doc+ , dc :: !Doc+ }+++ | ErrOther { pos :: SrcSpan+ , msg :: !Doc+ } -- ^ Sigh. Other.++ deriving (Typeable, Generic , Functor )++errDupSpecs :: Doc -> Misc.ListNE SrcSpan -> TError t+errDupSpecs d spans@(sp:_) = ErrDupSpecs sp d spans+errDupSpecs _ _ = impossible Nothing "errDupSpecs with empty spans!"++-- FIXME ES: this is very suspicious, why can't we have multiple errors+-- arising from the same span?++instance Eq (TError a) where+ e1 == e2 = errSpan e1 == errSpan e2++errSpan :: TError a -> SrcSpan+errSpan = pos++--------------------------------------------------------------------------------+-- | Simple unstructured type for panic ----------------------------------------+--------------------------------------------------------------------------------+type UserError = TError Doc++instance PPrint UserError where+ pprintTidy k = ppError k empty . fmap (pprintTidy Lossy)++data WithModel t+ = NoModel t+ | WithModel !Doc t+ deriving (Functor, Show, Eq, Generic)++instance NFData t => NFData (WithModel t)++dropModel :: WithModel t -> t+dropModel m = case m of+ NoModel t -> t+ WithModel _ t -> t++instance PPrint SrcSpan where+ pprintTidy _ = pprSrcSpan++pprSrcSpan :: SrcSpan -> Doc+pprSrcSpan (UnhelpfulSpan reason) = text $ case reason of+ UnhelpfulNoLocationInfo -> "UnhelpfulNoLocationInfo"+ UnhelpfulWiredIn -> "UnhelpfulWiredIn"+ UnhelpfulInteractive -> "UnhelpfulInteractive"+ UnhelpfulGenerated -> "UnhelpfulGenerated"+ UnhelpfulOther fs -> unpackFS fs+pprSrcSpan (RealSrcSpan s _) = pprRealSrcSpan s++pprRealSrcSpan :: RealSrcSpan -> Doc+pprRealSrcSpan span+ | sline == eline && scol == ecol =+ hcat [ pathDoc <-> colon+ , int sline <-> colon+ , int scol+ ]+ | sline == eline =+ hcat $ [ pathDoc <-> colon+ , int sline <-> colon+ , int scol+ ] ++ [char '-' <-> int (ecol - 1) | (ecol - scol) > 1]+ | otherwise =+ hcat [ pathDoc <-> colon+ , parens (int sline <-> comma <-> int scol)+ , char '-'+ , parens (int eline <-> comma <-> int ecol')+ ]+ where+ path = srcSpanFile span+ sline = srcSpanStartLine span+ eline = srcSpanEndLine span+ scol = srcSpanStartCol span+ ecol = srcSpanEndCol span++ pathDoc = text $ normalise $ unpackFS path+ ecol' = if ecol == 0 then ecol else ecol - 1++instance Show UserError where+ show = showpp++instance Ex.Exception UserError++-- | Construct and show an Error, then crash+uError :: UserError -> a+uError = Ex.throw++-- | Construct and show an Error, then crash+panicDoc :: {- (?callStack :: CallStack) => -} SrcSpan -> Doc -> a+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)+ where+ sspan = Mb.fromMaybe noSrcSpan++-- | Construct and show an Error with an optional SrcSpan, then crash+-- This function should be used to mark unimplemented functionality+todo :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a+todo s m = panic s $ unlines+ [ "This functionality is currently unimplemented. "+ , "If this functionality is critical to you, please contact us at: "+ , "https://github.com/ucsd-progsys/liquidhaskell/issues"+ , m+ ]++-- | Construct and show an Error with an optional SrcSpan, then crash+-- This function should be used to mark impossible-to-reach codepaths+impossible :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a+impossible s m = panic s $ unlines msg ++ m+ where+ msg = [ "This should never happen! If you are seeing this message, "+ , "please submit a bug report at "+ , "https://github.com/ucsd-progsys/liquidhaskell/issues "+ , "with this message and the source file that caused this error."+ , ""+ ]++++-- type CtxError = Error+--------------------------------------------------------------------------------+ppError :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc+--------------------------------------------------------------------------------+ppError k dCtx e = ppError' k dCtx e++nests :: Int -> [Doc] -> Doc+nests n = foldr (\d acc -> d $+$ nest n acc) empty+-- nests n = foldr (\d acc -> nest n (d $+$ acc)) empty++sepVcat :: Doc -> [Doc] -> Doc+sepVcat d ds = vcat $ L.intersperse d ds++blankLine :: Doc+blankLine = sizedText 5 "."++ppFull :: Tidy -> Doc -> Doc+ppFull Full d = d+ppFull Lossy _ = empty++ppReqInContext :: PPrint t => Tidy -> t -> t -> M.HashMap Symbol t -> Doc+ppReqInContext td tA tE c+ = sepVcat blankLine+ [ nests 2 [ text "The inferred type"+ , text "VV :" <+> pprintTidy td tA]+ , nests 2 [ text "is not a subtype of the required type"+ , text "VV :" <+> pprintTidy td tE]+ , ppContext td c+ ]++ppContext :: PPrint t => Tidy -> M.HashMap Symbol t -> Doc+ppContext td c+ | not (null xts) = nests 2 [ text "in the context"+ , vsep (map (uncurry (pprintBind td)) xts)+ ]+ | otherwise = empty+ where+ xts = M.toList c++pprintBind :: PPrint t => Tidy -> Symbol -> t -> Doc+pprintBind td v t = pprintTidy td v <+> char ':' <+> pprintTidy td t++ppReqModelInContext+ :: (PPrint t) => Tidy -> WithModel t -> t -> M.HashMap Symbol (WithModel t) -> Doc+ppReqModelInContext td tA tE c+ = sepVcat blankLine+ [ nests 2 [ text "The inferred type"+ , pprintModel td "VV" tA]+ , nests 2 [ text "is not a subtype of the required type"+ , pprintModel td "VV" (NoModel tE)]+ , nests 2 [ text "in the context"+ , vsep (map (uncurry (pprintModel td)) (M.toList c))+ ]+ ]++vsep :: [Doc] -> Doc+vsep = vcat . L.intersperse (char ' ')++pprintModel :: PPrint t => Tidy -> Symbol -> WithModel t -> Doc+pprintModel td v wm = case wm of+ NoModel t+ -> pprintTidy td v <+> char ':' <+> pprintTidy td t+ WithModel m t+ -> pprintTidy td v <+> char ':' <+> pprintTidy td t $+$+ pprintTidy td v <+> char '=' <+> pprintTidy td m++ppPropInContext :: (PPrint p, PPrint c) => Tidy -> p -> c -> Doc+ppPropInContext td p c+ = sepVcat blankLine+ [ nests 2 [ text "Property"+ , pprintTidy td p]+ , nests 2 [ text "Not provable in context"+ , pprintTidy td c+ ]+ ]++instance ToJSON RealSrcSpan where+ toJSON sp = object [ "filename" .= f+ , "startLine" .= l1+ , "startCol" .= c1+ , "endLine" .= l2+ , "endCol" .= c2+ ]+ where+ (f, l1, c1, l2, c2) = unpackRealSrcSpan sp++unpackRealSrcSpan :: RealSrcSpan -> (String, Int, Int, Int, Int)+unpackRealSrcSpan rsp = (f, l1, c1, l2, c2)+ where+ f = unpackFS $ srcSpanFile rsp+ l1 = srcSpanStartLine rsp+ c1 = srcSpanStartCol rsp+ l2 = srcSpanEndLine rsp+ c2 = srcSpanEndCol rsp+++instance FromJSON RealSrcSpan where+ parseJSON (Object v) =+ packRealSrcSpan+ <$> v .: "filename"+ <*> v .: "startLine"+ <*> v .: "startCol"+ <*> v .: "endLine"+ <*> v .: "endCol"+ parseJSON _ = mempty++packRealSrcSpan :: FilePath -> Int -> Int -> Int -> Int -> RealSrcSpan+packRealSrcSpan f l1 c1 l2 c2 = mkRealSrcSpan loc1 loc2+ where+ loc1 = mkRealSrcLoc (fsLit f) l1 c1+ loc2 = mkRealSrcLoc (fsLit f) l2 c2++srcSpanFileMb :: SrcSpan -> Maybe FilePath+srcSpanFileMb (RealSrcSpan s _) = Just $ unpackFS $ srcSpanFile s+srcSpanFileMb _ = Nothing+++instance ToJSON SrcSpan where+ toJSON (RealSrcSpan rsp _) = object [ "realSpan" .= True, "spanInfo" .= rsp ]+ toJSON (UnhelpfulSpan _) = object [ "realSpan" .= False ]++instance FromJSON SrcSpan where+ parseJSON (Object v) = do tag <- v .: "realSpan"+ if tag+ then RealSrcSpan <$> v .: "spanInfo" <*> pure Nothing+ else return noSrcSpan+ parseJSON _ = mempty++-- Default definition use ToJSON and FromJSON+instance ToJSONKey SrcSpan+instance FromJSONKey SrcSpan++instance (PPrint a, Show a) => ToJSON (TError a) where+ toJSON e = object [ "pos" .= pos e+ , "msg" .= render (ppError' Full empty e)+ ]++instance FromJSON (TError a) where+ parseJSON (Object v) = errSaved <$> v .: "pos"+ <*> v .: "msg"+ parseJSON _ = mempty++errSaved :: SrcSpan -> String -> TError a+errSaved sp body | n : m <- lines body = ErrSaved sp (text n) (text $ unlines m)++totalityType :: PPrint a => Tidy -> a -> Bool+totalityType td tE = pprintTidy td tE == text "{VV : Addr# | 5 < 4}"++hint :: TError a -> Doc+hint e = maybe empty (\d -> "" $+$ ("HINT:" <+> d)) (go e)+ where+ go ErrMismatch {} = Just "Use the hole '_' instead of the mismatched component (in the Liquid specification)"+ go ErrSubType {} = Just "Use \"--no-totality\" to deactivate totality checking."+ go ErrNoSpec {} = Just "Run 'liquid' on the source file first."+ go _ = Nothing++--------------------------------------------------------------------------------+ppError' :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc+--------------------------------------------------------------------------------+ppError' td dCtx (ErrAssType _ o _ c p)+ = pprintTidy td o+ $+$ dCtx+ $+$ ppFull td (ppPropInContext td p c)++ppError' td dCtx err@(ErrSubType _ _ _ _ _ tE)+ | totalityType td tE+ = text "Totality Error"+ $+$ dCtx+ $+$ text "Your function is not total: not all patterns are defined."+ $+$ hint err -- "Hint: Use \"--no-totality\" to deactivate totality checking."++ppError' _td _dCtx (ErrHoleCycle _ holes)+ = "Cycle of holes found"+ $+$ pprint holes++ppError' _td _dCtx (ErrHole _ msg _ x t)+ = "Hole Found"+ $+$ pprint x <+> "::" <+> pprint t+ $+$ msg++ppError' td dCtx (ErrSubType _ _ cid c tA tE)+ = text "Liquid Type Mismatch"+ $+$ nest 4+ (blankLine+ $+$ dCtx+ $+$ ppFull td (ppReqInContext td tA tE c)+ $+$ maybe mempty (\i -> text "Constraint id" <+> text (show i)) cid)++ppError' td dCtx (ErrSubTypeModel _ _ cid c tA tE)+ = text "Liquid Type Mismatch"+ $+$ nest 4+ (dCtx+ $+$ ppFull td (ppReqModelInContext td tA tE c)+ $+$ maybe mempty (\i -> text "Constraint id" <+> text (show i)) cid)++ppError' td dCtx (ErrFCrash _ _ c tA tE)+ = text "Fixpoint Crash on Constraint"+ $+$ dCtx+ $+$ ppFull td (ppReqInContext td tA tE c)++ppError' _ dCtx (ErrParse _ _ e)+ = text "Cannot parse specification:"+ $+$ dCtx+ $+$ nest 4 (pprint e)++ppError' _ dCtx (ErrTySpec _ _k v t s)+ = ("Illegal type specification for" <+> ppTicks v) -- <-> ppKind k <-> ppTicks v)+ -- = dSp <+> ("Illegal type specification for" <+> _ppKind k <-> ppTicks v)+ $+$ dCtx+ $+$ nest 4 (vcat [ pprint v <+> Misc.dcolon <+> pprint t+ , pprint s+ , pprint _k+ ])+ where+ _ppKind Nothing = empty+ _ppKind (Just d) = d <-> " "++ppError' _ dCtx (ErrLiftExp _ v)+ = text "Cannot lift" <+> ppTicks v <+> "into refinement logic"+ $+$ dCtx+ $+$ nest 4 (text "Please export the binder from the module to enable lifting.")++ppError' _ dCtx (ErrBadData _ v s)+ = text "Bad Data Specification"+ $+$ dCtx+ $+$ (pprint s <+> "for" <+> ppTicks v)++ppError' _ dCtx (ErrDataCon _ d s)+ = "Malformed refined data constructor" <+> ppTicks d+ $+$ dCtx+ $+$ s++ppError' _ dCtx (ErrDataConMismatch _ d dcs rdcs)+ = text "Data constructors in refinement do not match original datatype for" <+> ppTicks d+ $+$ dCtx+ $+$ nest 4 (text "Constructors in Haskell declaration: " <+> hsep (L.intersperse comma dcs))+ $+$ nest 4 (text "Constructors in refinement : " <+> hsep (L.intersperse comma rdcs))++ppError' _ dCtx (ErrBadQual _ n d)+ = text "Illegal qualifier specification for" <+> ppTicks n+ $+$ dCtx+ $+$ pprint d++ppError' _ dCtx (ErrTermSpec _ v msg e t s)+ = text "Illegal termination specification for" <+> ppTicks v+ $+$ dCtx+ $+$ nest 4 ((text "Termination metric" <+> ppTicks e <+> text "is" <+> msg <+> "in type signature")+ $+$ nest 4 (pprint t)+ $+$ pprint s)++ppError' _ _ (ErrInvt _ t s)+ = text "Bad Invariant Specification"+ $+$ nest 4 (text "invariant " <+> pprint t $+$ pprint s)++ppError' _ _ (ErrIAl _ t s)+ = text "Bad Using Specification"+ $+$ nest 4 (text "as" <+> pprint t $+$ pprint s)++ppError' _ _ (ErrIAlMis _ t1 t2 s)+ = text "Incompatible Using Specification"+ $+$ nest 4 ((text "using" <+> pprint t1 <+> text "as" <+> pprint t2) $+$ pprint s)++ppError' _ _ (ErrMeas _ t s)+ = text "Bad Measure Specification"+ $+$ nest 4 (text "measure " <+> pprint t $+$ pprint s)++ppError' _ dCtx (ErrHMeas _ t s)+ = text "Cannot lift Haskell function" <+> ppTicks t <+> text "to logic"+ $+$ dCtx+ $+$ nest 4 (pprint s)++ppError' _ dCtx (ErrDupSpecs _ v ls)+ = text "Multiple specifications for" <+> ppTicks v <+> colon+ $+$ dCtx+ $+$ ppSrcSpans ls++ppError' _ dCtx (ErrDupIMeas _ v t ls)+ = text "Multiple instance measures" <+> ppTicks v <+> text "for type" <+> ppTicks t+ $+$ dCtx+ $+$ ppSrcSpans ls++ppError' _ dCtx (ErrDupMeas _ v ls)+ = text "Multiple measures named" <+> ppTicks v+ $+$ dCtx+ $+$ ppSrcSpans ls++ppError' _ dCtx (ErrDupField _ dc x)+ = text "Malformed refined data constructor" <+> dc+ $+$ dCtx+ $+$ nest 4 (text "Duplicated definitions for field" <+> ppTicks x)++ppError' _ dCtx (ErrDupNames _ x ns)+ = text "Ambiguous specification symbol" <+> ppTicks x+ $+$ dCtx+ $+$ ppNames ns++ppError' _ dCtx (ErrDupAlias _ k v ls)+ = text "Multiple definitions of" <+> pprint k <+> ppTicks v+ $+$ dCtx+ $+$ ppSrcSpans ls++ppError' _ dCtx (ErrUnbound _ x)+ = text "Unbound variable" <+> pprint x+ $+$ dCtx++ppError' _ dCtx (ErrUnbPred _ p)+ = text "Cannot apply unbound abstract refinement" <+> ppTicks p+ $+$ dCtx++ppError' _ dCtx (ErrGhc _ s)+ = text "GHC Error"+ $+$ dCtx+ $+$ nest 4 (pprint s)++ppError' _ _ (ErrFail _ s)+ = text "Failure Error:"+ $+$ text "Definition of" <+> pprint s <+> text "declared to fail is safe."++ppError' _ _ (ErrFailUsed _ s xs)+ = text "Failure Error:"+ $+$ text "Binder" <+> pprint s <+> text "declared to fail is used by"+ <+> hsep (L.intersperse comma xs)++ppError' _ dCtx (ErrResolve _ kind v msg)+ = (text "Unknown" <+> kind <+> ppTicks v)+ $+$ dCtx+ $+$ nest 4 msg++ppError' _ dCtx (ErrPartPred _ c p i eN aN)+ = text "Malformed predicate application"+ $+$ dCtx+ $+$ nest 4 (vcat+ [ "The" <+> text (Misc.intToString i) <+> "argument of" <+> c <+> "is predicate" <+> ppTicks p+ , "which expects" <+> pprint eN <+> "arguments" <+> "but is given only" <+> pprint aN+ , " "+ , "Abstract predicates cannot be partially applied; for a possible fix see:"+ , " "+ , nest 4 "https://github.com/ucsd-progsys/liquidhaskell/issues/594"+ ])++ppError' _ dCtx e@(ErrMismatch _ x msg τ t cause hsSp)+ = "Specified type does not refine Haskell type for" <+> ppTicks x <+> parens msg+ $+$ dCtx+ $+$ sepVcat blankLine+ [ "The Liquid type"+ , nest 4 t+ , "is inconsistent with the Haskell type"+ , nest 4 τ+ , "defined at" <+> pprint hsSp+ , maybe empty ppCause cause+ ]+ where+ ppCause (hsD, lqD) = sepVcat blankLine+ [ "Specifically, the Liquid component"+ , nest 4 lqD+ , "is inconsistent with the Haskell component"+ , nest 4 hsD+ , hint e+ ]++ppError' _ dCtx (ErrAliasCycle _ acycle)+ = text "Cyclic type alias definition for" <+> ppTicks n0+ $+$ dCtx+ $+$ nest 4 (sepVcat blankLine (hdr : map describe acycle))+ where+ hdr = text "The following alias definitions form a cycle:"+ describe (p, n) = text "*" <+> ppTicks n <+> parens (text "defined at:" <+> pprint p)+ n0 = snd . head $ acycle++ppError' _ dCtx (ErrIllegalAliasApp _ dn dl)+ = text "Refinement type alias cannot be used in this context"+ $+$ dCtx+ $+$ text "Type alias:" <+> pprint dn+ $+$ text "Defined at:" <+> pprint dl++ppError' _ dCtx (ErrAliasApp _ name dl s)+ = text "Malformed application of type alias" <+> ppTicks name+ $+$ dCtx+ $+$ nest 4 (vcat [ text "The alias" <+> ppTicks name <+> "defined at:" <+> pprint dl+ , s ])++ppError' _ dCtx (ErrSaved _ name s)+ = name -- <+> "(saved)"+ $+$ dCtx+ $+$ {- nest 4 -} s++ppError' _ dCtx (ErrFilePragma _)+ = text "Illegal pragma"+ $+$ dCtx+ $+$ text "--idirs, --c-files, and --ghc-option cannot be used in file-level pragmas"++ppError' _ _ err@(ErrNoSpec _ srcF bspecF)+ = vcat [ text "Cannot find .bspec file "+ , nest 4 bspecF+ , text "for the source file "+ , nest 4 srcF+ , hint err+ ]++ppError' _ dCtx (ErrOther _ s)+ = text "Uh oh."+ $+$ dCtx+ $+$ nest 4 s++ppError' _ dCtx (ErrTermin _ xs s)+ = text "Termination Error"+ $+$ dCtx+ <+> hsep (L.intersperse comma xs) $+$ s++ppError' _ dCtx (ErrStTerm _ x s)+ = text "Structural Termination Error"+ $+$ dCtx+ <+> (text "Cannot prove termination for size" <+> x) $+$ s+ppError' _ dCtx (ErrILaw _ c i s)+ = text "Law Instance Error"+ $+$ dCtx+ <+> (text "The instance" <+> i <+> text "of class" <+> c <+> text "is not valid.") $+$ s++ppError' _ dCtx (ErrMClass _ v)+ = text "Standalone class method refinement"+ $+$ dCtx+ $+$ (text "Invalid type specification for" <+> v)+ $+$ text "Use class or instance refinements instead."++ppError' _ _ (ErrRClass p0 c is)+ = text "Refined classes cannot have refined instances"+ $+$ nest 4 (sepVcat blankLine $ describeCls : map describeInst is)+ where+ describeCls+ = text "Refined class definition for:" <+> c+ $+$ text "Defined at:" <+> pprint p0+ describeInst (p, t)+ = text "Refined instance for:" <+> t+ $+$ text "Defined at:" <+> pprint p++ppError' _ dCtx (ErrTyCon _ msg ty)+ = text "Illegal data refinement for" <+> ppTicks ty+ $+$ dCtx+ $+$ nest 4 msg++ppError' _ dCtx (ErrRewrite _ msg )+ = text "Rewrite error"+ $+$ dCtx+ $+$ nest 4 msg++ppError' _ dCtx (ErrPosTyCon _ tc dc)+ = text "Negative occurence of" <+> tc <+> "in" <+> dc+ $+$ dCtx+ $+$ vcat+ ["\n"+ , "To deactivate or understand the need of positivity check, see:"+ , " "+ , nest 2 "https://ucsd-progsys.github.io/liquidhaskell/options/#positivity-check"+ ]++ppError' _ dCtx (ErrParseAnn _ msg)+ = text "Malformed annotation"+ $+$ dCtx+ $+$ nest 4 msg++ppTicks :: PPrint a => a -> Doc+ppTicks = ticks . pprint++ticks :: Doc -> Doc+ticks d = text "`" <-> d <-> text "`"++ppSrcSpans :: [SrcSpan] -> Doc+ppSrcSpans = ppList (text "Conflicting definitions at")++ppNames :: [Doc] -> Doc+ppNames ds = ppList "Could refer to any of the names" ds -- [text "-" <+> d | d <- ds]++ppList :: (PPrint a) => Doc -> [a] -> Doc+ppList d ls+ = nest 4 (sepVcat blankLine (d : [ text "*" <+> pprint l | l <- ls ]))++-- | Convert a GHC error into a list of our errors.++sourceErrors :: String -> SourceError -> [TError t]+sourceErrors s =+ concatMap errMsgErrors . bagToList . srcErrorMessages+ where+ errMsgErrors e = [ ErrGhc (errMsgSpan e) msg ]+ where+ msg = text s $+$ nest 4 (text (show e))
+ src/Language/Haskell/Liquid/Types/Fresh.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}++module Language.Haskell.Liquid.Types.Fresh+ ( Freshable(..)+ , refreshTy+ , refreshVV+ , refreshArgs+ , refreshHoles+ , refreshArgsSub+ )+ where++import Data.Maybe (catMaybes) -- , fromJust, isJust)+import Data.Bifunctor+import qualified Data.List as L+-- import qualified Data.HashMap.Strict as M+-- import qualified Data.HashSet as S+-- import Data.Hashable+-- import Control.Monad.State (gets, get, put, modify)+-- import Control.Monad (when, (>=>))+-- import CoreUtils (exprType)+import Prelude hiding (error)+-- import Type (Type)+-- import CoreSyn+-- import Var (varType, isTyVar, Var)++import qualified Language.Fixpoint.Types as F+-- import Language.Fixpoint.Types.Visitor (kvars)+import Language.Haskell.Liquid.Misc (single)+import Language.Haskell.Liquid.Types.Types+import Language.Haskell.Liquid.Types.RefType+++class (Applicative m, Monad m) => Freshable m a where+ fresh :: m a+ true :: Bool -> a -> m a+ true _ = return+ refresh :: Bool -> a -> m a+ refresh _ = return+++instance (Freshable m Integer, Monad m, Applicative m) => Freshable m F.Symbol where+ fresh = F.tempSymbol "x" <$> fresh++instance (Freshable m Integer, Monad m, Applicative m) => Freshable m F.Expr where+ fresh = kv <$> fresh+ where+ kv = (`F.PKVar` mempty) . F.intKvar++instance (Freshable m Integer, Monad m, Applicative m) => Freshable m [F.Expr] where+ fresh = single <$> fresh++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)+ refresh _ (F.Reft (_,_)) = (F.Reft .) . (,) <$> freshVV <*> fresh+ where+ freshVV = F.vv . Just <$> fresh++instance Freshable m Integer => Freshable m RReft where+ fresh = panic Nothing "fresh RReft"+ 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+ 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 allowTC (RAllT α t r)+ = RAllT α <$> true allowTC t <*> true allowTC r++trueRefType allowTC (RAllP π t)+ = RAllP π <$> true allowTC t++trueRefType allowTC (RFun _ _ t t' _)+ -- YL: attaching rfinfo here is crucial+ = rFun' (classRFInfo allowTC) <$> fresh <*> true allowTC t <*> true allowTC t'++trueRefType allowTC (RApp c ts _ _) | if allowTC then isEmbeddedDict c else isClass c+ = rRCls c <$> mapM (true allowTC) ts++trueRefType allowTC (RApp c ts rs r)+ = RApp c <$> mapM (true allowTC) ts <*> mapM (trueRef allowTC) rs <*> true allowTC r++trueRefType allowTC (RAppTy t t' _)+ = RAppTy <$> true allowTC t <*> true allowTC t' <*> return mempty++trueRefType allowTC (RVar a r)+ = RVar a <$> true allowTC r++trueRefType allowTC (RAllE y ty tx)+ = do y' <- fresh+ ty' <- true allowTC ty+ tx' <- true allowTC tx+ return $ RAllE y' ty' (tx' `F.subst1` (y, F.EVar y'))++trueRefType allowTC (RRTy e o r t)+ = RRTy e o r <$> trueRefType allowTC t++trueRefType allowTC (REx _ t t')+ = REx <$> fresh <*> true allowTC t <*> true allowTC t'++trueRefType _ t@(RExprArg _)+ = return t++trueRefType _ t@(RHole _)+ = return t++trueRef :: (F.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 allowTC (RAllT α t r)+ = RAllT α <$> refresh allowTC t <*> true allowTC r++refreshRefType allowTC (RAllP π t)+ = RAllP π <$> refresh allowTC t++refreshRefType allowTC (RFun sym i t t' _)+ | sym == F.dummySymbol = (\b t1 t2 -> RFun b i t1 t2 mempty) <$> fresh <*> refresh allowTC t <*> refresh allowTC t'+ | otherwise = (\t1 t2 -> RFun sym i t1 t2 mempty) <$> refresh allowTC t <*> refresh allowTC t'++refreshRefType _ (RApp rc ts _ _) | isClass rc+ = return $ rRCls rc ts++refreshRefType allowTC (RApp rc ts rs r)+ = RApp rc <$> mapM (refresh allowTC) ts <*> mapM (refreshRef allowTC) rs <*> refresh allowTC r++refreshRefType allowTC (RVar a r)+ = RVar a <$> refresh allowTC r++refreshRefType allowTC (RAppTy t t' r)+ = RAppTy <$> refresh allowTC t <*> refresh allowTC t' <*> refresh allowTC r++refreshRefType allowTC (RAllE y ty tx)+ = do y' <- fresh+ ty' <- refresh allowTC ty+ tx' <- refresh allowTC tx+ return $ RAllE y' ty' (tx' `F.subst1` (y, F.EVar y'))++refreshRefType allowTC (RRTy e o r t)+ = RRTy e o r <$> refreshRefType allowTC t++refreshRefType _ t+ = return t++refreshRef :: (F.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++freshSym :: Freshable f a => (t, t1) -> f (a, t1)+freshSym (_, t) = (, t) <$> fresh+++--------------------------------------------------------------------------------+refreshTy :: (FreshM m) => SpecType -> m SpecType+--------------------------------------------------------------------------------+refreshTy t = refreshVV t >>= refreshArgs++--------------------------------------------------------------------------------+type FreshM m = Freshable m Integer+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+refreshVV :: FreshM m => SpecType -> m SpecType+--------------------------------------------------------------------------------+refreshVV (RAllT a t r) =+ RAllT a <$> refreshVV t <*> return r++refreshVV (RAllP p t) =+ RAllP p <$> refreshVV t++refreshVV (REx x t1 t2) = do+ t1' <- refreshVV t1+ t2' <- refreshVV t2+ shiftVV (REx x t1' t2') <$> fresh++refreshVV (RFun x i t1 t2 r) = do+ t1' <- refreshVV t1+ t2' <- refreshVV t2+ shiftVV (RFun x i t1' t2' r) <$> fresh++refreshVV (RAppTy t1 t2 r) = do+ t1' <- refreshVV t1+ t2' <- refreshVV t2+ shiftVV (RAppTy t1' t2' r) <$> fresh++refreshVV (RApp c ts rs r) = do+ ts' <- mapM refreshVV ts+ rs' <- mapM refreshVVRef rs+ shiftVV (RApp c ts' rs' r) <$> fresh++refreshVV t =+ shiftVV t <$> fresh++refreshVVRef :: Freshable m Integer => Ref b SpecType -> m (Ref b SpecType)+refreshVVRef (RProp ss (RHole r))+ = return $ RProp ss (RHole r)++refreshVVRef (RProp ss t)+ = do xs <- mapM (const fresh) syms+ let su = F.mkSubst $ zip syms (F.EVar <$> xs)+ t' <- refreshVV t+ return $ RProp (zip xs bs) (F.subst su t')+ where+ (syms, bs) = unzip ss++--------------------------------------------------------------------------------+refreshArgs :: (FreshM m) => SpecType -> m SpecType+--------------------------------------------------------------------------------+refreshArgs t = fst <$> refreshArgsSub t+++-- NV TODO: this does not refresh args if they are wrapped in an RRTy+refreshArgsSub :: (FreshM m) => SpecType -> m (SpecType, F.Subst)+refreshArgsSub t+ = do ts <- mapM refreshArgs ts_u+ xs' <- mapM (const fresh) xs+ let sus = F.mkSubst <$> L.inits (zip xs (F.EVar <$> xs'))+ let su = last sus+ ts' <- mapM refreshPs $ zipWith F.subst sus ts+ let rs' = zipWith F.subst sus rs+ tr <- refreshPs $ F.subst su tbd+ let t' = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = tr, ty_refts = rs'}+ return (t', su)+ where+ trep = toRTypeRep t+ xs = ty_binds trep+ ts_u = ty_args trep+ tbd = ty_res trep+ rs = ty_refts trep++refreshPs :: (FreshM m) => SpecType -> m SpecType+refreshPs = mapPropM go+ where+ go (RProp s st) = do+ t' <- refreshPs st+ xs <- mapM (const fresh) s+ let su = F.mkSubst [(y, F.EVar x) | (x, (y, _)) <- zip xs s]+ 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)+ => 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)+ => 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)+ | otherwise = (Just $ F.symbol x,x,) <$> mapReftM tx t+ where+ tx r | hasHole r = refresh allowTC r+ | otherwise = return r++noHoles :: (F.Reftable r, TyConable c) => RType c tv r -> Bool+noHoles = and . foldReft False (\_ r bs -> not (hasHole r) : bs) []
+ src/Language/Haskell/Liquid/Types/Generics.hs view
@@ -0,0 +1,62 @@+{- | Geriving instances, generically.+ This module shares some of the underlying ideas and implementations of the+ [generic-data](https://hackage.haskell.org/package/generic-data-0.8.1.0/docs/Generic-Data.html)+ package, allowing us to derive a bunch of instances using the underlying 'Generic' implementation,+ but in a more declarative way.++ In particular we introduc the 'Generically' newtype wrapper to be used with '-XDerivingVia' to make+ derivation explicit. For example:++@+ data Foo = Foo+ deriving Generic+ deriving Eq via Generically Foo+@++-}++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Haskell.Liquid.Types.Generics where++import GHC.Generics+import Data.Hashable+import Data.Binary+import Data.Hashable.Generic+import Data.Function++newtype Generically a = Generically a deriving Generic++-- * 'Hashable'++instance (Eq (Generically a), Generic a, GHashable Zero (Rep a)) => Hashable (Generically a) where+ hashWithSalt s (Generically a) = genericHashWithSalt s a++-- * 'Binary'++instance (Generic a, GBinaryPut (Rep a), GBinaryGet (Rep a)) => Binary (Generically a) where+ get = Generically . to' <$> gget+ put (Generically a) = gput (from' a)++-- * 'Eq'++-- | Generic @('==')@.+--+-- @+-- instance 'Eq' MyType where+-- ('==') = 'geq'+-- @+geq :: (Generic a, Eq (Rep a ())) => a -> a -> Bool+geq = (==) `on` from'++instance (Generic a, Eq (Rep a ())) => Eq (Generically a) where+ (Generically a) == (Generically b) = geq a b++-- | A helper for better type inference.+from' :: Generic a => a -> Rep a ()+from' = from++to' :: Generic a => Rep a () -> a+to' = to
+ src/Language/Haskell/Liquid/Types/Literals.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.Types.Literals + ( literalFRefType+ , literalFReft+ , literalConst+ , mkI, mkS+ ) where++import Prelude hiding (error)+import Language.Haskell.Liquid.GHC.TypeRep ()+import Liquid.GHC.API hiding (panic)++import Language.Haskell.Liquid.Types.Types+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Transforms.CoreToLogic (mkLit, mkI, mkS)++import qualified Language.Fixpoint.Types as F++---------------------------------------------------------------+----------------------- Typing Literals -----------------------+---------------------------------------------------------------++makeRTypeBase :: Monoid r => Type -> r -> RType RTyCon RTyVar r+makeRTypeBase (TyVarTy α) x+ = RVar (rTyVar α) x+makeRTypeBase (TyConApp c ts) x+ = rApp c ((`makeRTypeBase` mempty) <$> ts) [] x+makeRTypeBase _ _+ = panic Nothing "RefType : makeRTypeBase"++literalFRefType :: Literal -> RType RTyCon RTyVar F.Reft+literalFRefType l+ = makeRTypeBase (literalType l) (literalFReft l)++literalFReft :: Literal -> F.Reft+literalFReft l = maybe mempty mkReft $ mkLit l++mkReft :: F.Expr -> F.Reft+mkReft = F.exprReft++-- | `literalConst` returns `Nothing` for unhandled lits because+-- otherwise string-literals show up as global int-constants+-- which blow up qualifier instantiation.++literalConst :: F.TCEmb TyCon -> Literal -> (F.Sort, Maybe F.Expr)+literalConst tce l = (t, mkLit l)+ where+ t = typeSort tce $ literalType l
+ src/Language/Haskell/Liquid/Types/Meet.hs view
@@ -0,0 +1,36 @@+-- | This code has various wrappers around `meet` and `strengthen`+-- that are here so that we can throw decent error messages if+-- they fail. The module depends on `RefType` and `UX.Tidy`.++module Language.Haskell.Liquid.Types.Meet ( meetVarTypes ) where++import Text.PrettyPrint.HughesPJ (Doc)+import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.Types.Types+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+ where+ (_hsSp, hsT) = hs+ (_lqSp, lqT) = lq+ -- _err = ErrMismatch lqSp v (text "meetVarTypes") hsD lqD hsSp+ -- _hsD = F.pprint hsT+ -- _lqD = F.pprint lqT+{- + +_meetError :: F.TCEmb TyCon -> Error -> SpecType -> SpecType -> SpecType+_meetError _emb _e t t'+ -- // | meetable emb t t'+ | True = t `F.meet` t'+ -- // | otherwise = panicError e++_meetable :: F.TCEmb TyCon -> SpecType -> SpecType -> Bool+_meetable _emb t1 t2 = F.notracepp ("meetable: " ++ showpp (s1, t1, s2, t2)) (s1 == s2)+ where+ s1 = tx t1+ s2 = tx t2+ tx = rTypeSort _emb . toRSort++-}
+ src/Language/Haskell/Liquid/Types/Names.hs view
@@ -0,0 +1,20 @@+module Language.Haskell.Liquid.Types.Names+ (lenLocSymbol, anyTypeSymbol, functionComposisionSymbol, selfSymbol) where++import Language.Fixpoint.Types++-- RJ: Please add docs+lenLocSymbol :: Located Symbol+lenLocSymbol = dummyLoc $ symbol ("autolen" :: String)++anyTypeSymbol :: Symbol+anyTypeSymbol = symbol ("GHC.Prim.Any" :: String)+++-- defined in include/GHC/Base.hs+functionComposisionSymbol :: Symbol+functionComposisionSymbol = symbol ("GHC.Base.." :: String)+++selfSymbol :: Symbol+selfSymbol = symbol ("liquid_internal_this" :: String)
+ src/Language/Haskell/Liquid/Types/PredType.hs view
@@ -0,0 +1,568 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.Types.PredType (+ PrType+ , TyConP (..), DataConP (..)+ , dataConTy+ , dataConPSpecType+ , makeTyConInfo+ , replacePreds+ , replacePredsWithRefs+ , pVartoRConc++ -- * Dummy `Type` that represents _all_ abstract-predicates+ , predType++ -- * Compute @RType@ of a given @PVar@+ , pvarRType+ , substParg+ , pApp+ , pappSort+ , pappArity++ -- * should be elsewhere+ , dataConWorkRep+ , substPVar+ ) where++import Prelude hiding (error)+import Text.PrettyPrint.HughesPJ+import Liquid.GHC.API hiding ( panic+ , (<+>)+ , hsep+ , punctuate+ , comma+ , parens+ , showPpr+ )+import Language.Haskell.Liquid.GHC.TypeRep ()+import Data.Hashable+import qualified Data.HashMap.Strict as M+import qualified Data.Maybe as Mb+import qualified Data.List as L -- (foldl', partition)+-- import Data.List (nub)++import Language.Fixpoint.Misc++-- import Language.Fixpoint.Types hiding (Expr, Predicate)+import qualified Language.Fixpoint.Types as F+import qualified Liquid.GHC.API as Ghc+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.Types.RefType hiding (generalize)+import Language.Haskell.Liquid.Types.Types+import Data.Default++makeTyConInfo :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> [TyConP] -> TyConMap+makeTyConInfo tce fiTcs tcps = TyConMap+ { tcmTyRTy = tcM+ , tcmFIRTy = tcInstM+ , tcmFtcArity = arities+ }+ where+ tcM = M.fromList [(tcpCon tcp, mkRTyCon tcp) | tcp <- tcps ]+ tcInstM = mkFInstRTyCon tce fiTcs tcM+ arities = safeFromList "makeTyConInfo" [ (c, length ts) | (c, ts) <- M.keys tcInstM ]++mkFInstRTyCon :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> M.HashMap Ghc.TyCon RTyCon -> M.HashMap (Ghc.TyCon, [F.Sort]) RTyCon+mkFInstRTyCon tce fiTcs tcm = M.fromList+ [ ((c, typeSort tce <$> ts), rtc)+ | fiTc <- fiTcs+ , rtc <- Mb.maybeToList (M.lookup fiTc tcm)+ , (c, ts) <- Mb.maybeToList (famInstArgs fiTc)+ ]++mkRTyCon :: TyConP -> RTyCon+mkRTyCon (TyConP _ tc αs' ps tyvariance predvariance size)+ = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size)+ where+ τs = [rVar α :: RSort | α <- tyConTyVarsDef tc]+ pvs' = subts (zip αs' τs) <$> ps+++-------------------------------------------------------------------------------+-- | @dataConPSpecType@ converts a @DataConP@, LH's internal representation for+-- a (refined) data constructor into a @SpecType@ for that constructor.+-- TODO: duplicated with Liquid.Measure.makeDataConType+-------------------------------------------------------------------------------+dataConPSpecType :: Bool -> DataConP -> [(Var, SpecType)]+-------------------------------------------------------------------------------+dataConPSpecType allowTC dcp = [(workX, workT), (wrapX, wrapT) ]+ where+ workT | isVanilla = wrapT+ | otherwise = dcWorkSpecType dc wrapT+ wrapT = dcWrapSpecType allowTC dc dcp+ workX = dataConWorkId dc -- This is the weird one for GADTs+ wrapX = dataConWrapId dc -- This is what the user expects to see+ isVanilla = isVanillaDataCon dc+ dc = dcpCon dcp++dcWorkSpecType :: DataCon -> SpecType -> SpecType+dcWorkSpecType c wrT = fromRTypeRep (meetWorkWrapRep c wkR wrR)+ where+ wkR = dataConWorkRep c+ wrR = toRTypeRep wrT++dataConWorkRep :: DataCon -> SpecRep+dataConWorkRep c = toRTypeRep+ -- . F.tracepp ("DCWR-2: " ++ F.showpp c)+ . ofType+ -- . F.tracepp ("DCWR-1: " ++ F.showpp c)+ . dataConRepType+ -- . Var.varType+ -- . dataConWorkId+ $ c+{-+dataConWorkRep :: DataCon -> SpecRep+dataConWorkRep dc = RTypeRep+ { ty_vars = as+ , ty_preds = []+ , ty_labels = []+ , ty_binds = replicate nArgs F.dummySymbol+ , ty_refts = replicate nArgs mempty+ , ty_args = ts'+ , ty_res = t'+ }+ where+ (ts', t') = F.tracepp "DCWR-1" (ofType <$> ts, ofType t)+ as = makeRTVar . rTyVar <$> αs+ tArg+ (αs,_,eqs,th,ts,t) = dataConFullSig dc+ nArgs = length ts++dataConResultTy :: DataCon -> [TyVar] -> Type -> Type+dataConResultTy dc αs t = mkFamilyTyConApp tc tArgs'+ where+ tArgs' = take (nArgs - nVars) tArgs ++ (mkTyVarTy <$> αs)+ nVars = length αs+ nArgs = length tArgs+ (tc, tArgs) = fromMaybe err (splitTyConApp_maybe _t)+ err = GM.namedPanic dc ("Cannot split result type of DataCon " ++ show dc)++ -- t = RT.ofType $ mkFamilyTyConApp tc tArgs'+ -- as = makeRTVar . rTyVar <$> αs+ -- (αs,_,_,_,_ts,_t) = dataConFullSig dc++-}++meetWorkWrapRep :: DataCon -> SpecRep -> SpecRep -> SpecRep+meetWorkWrapRep c workR wrapR+ | 0 <= pad'+ = workR { ty_binds = xs ++ ty_binds wrapR+ , ty_args = ts ++ zipWith F.meet ts' (ty_args wrapR)+ , ty_res = strengthenRType (ty_res workR) (ty_res wrapR)+ , ty_preds = ty_preds wrapR+ }+ | otherwise+ = panic (Just (getSrcSpan c)) errMsg+ where+ pad' = {- F.tracepp ("MEETWKRAP: " ++ show (ty_vars workR)) $ -} workN - wrapN+ (xs, _) = splitAt pad' (ty_binds workR)+ (ts, ts') = splitAt pad' (ty_args workR)+ workN = length (ty_args workR)+ wrapN = length (ty_args wrapR)+ errMsg = "Unsupported Work/Wrap types for Data Constructor " ++ showPpr c++strengthenRType :: SpecType -> SpecType -> SpecType+strengthenRType wkT wrT = maybe wkT (strengthen wkT) (stripRTypeBase wrT)+++-- maybe a tc flag is unnecessary but I don't know if {-@ class ... @-}+-- would reach here+dcWrapSpecType :: Bool -> DataCon -> DataConP -> SpecType+dcWrapSpecType allowTC dc (DataConP _ _ vs ps cs yts rt _ _ _)+ = {- F.tracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ -}+ mkArrow makeVars' ps ts' rt'+ where+ isCls = Ghc.isClassTyCon $ Ghc.dataConTyCon dc+ (as, sts) = unzip (reverse yts)+ 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+ ts' = map ("" , classRFInfo allowTC , , mempty) cs ++ yts'+ subst = F.mkSubst [(x, F.EVar y) | (x, y) <- zip as 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++dataConTy :: Monoid r+ => M.HashMap RTyVar (RType RTyCon RTyVar r)+ -> Type -> RType RTyCon RTyVar r+dataConTy m (TyVarTy v)+ = M.lookupDefault (rVar v) (RTV v) m+dataConTy m (FunTy _ _ t1 t2)+ = rFun F.dummySymbol (dataConTy m t1) (dataConTy m t2)+dataConTy m (ForAllTy (Bndr α _) t) -- α :: TyVar+ = RAllT (makeRTVar (RTV α)) (dataConTy m t) mempty+dataConTy m (TyConApp c ts)+ = rApp c (dataConTy m <$> ts) [] mempty+dataConTy _ _+ = panic Nothing "ofTypePAppTy"++----------------------------------------------------------------------------+-- | Interface: Replace Predicate With Uninterpreted Function Symbol -------+----------------------------------------------------------------------------+replacePredsWithRefs :: (UsedPVar, (F.Symbol, [((), F.Symbol, F.Expr)]) -> F.Expr)+ -> UReft F.Reft -> UReft F.Reft+replacePredsWithRefs (p, r) (MkUReft (F.Reft(v, rs)) (Pr ps))+ = MkUReft (F.Reft (v, rs'')) (Pr ps2)+ where+ rs'' = mconcat $ rs : rs'+ rs' = r . (v,) . pargs <$> ps1+ (ps1, ps2) = L.partition (== p) ps++pVartoRConc :: PVar t -> (F.Symbol, [(a, b, F.Expr)]) -> F.Expr+pVartoRConc p (v, args) | length args == length (pargs p)+ = pApp (pname p) $ F.EVar v : (thd3 <$> args)++pVartoRConc p (v, args)+ = pApp (pname p) $ F.EVar v : args'+ where+ args' = (thd3 <$> args) ++ drop (length args) (thd3 <$> pargs p)++-----------------------------------------------------------------------+-- | @pvarRType π@ returns a trivial @RType@ corresponding to the+-- function signature for a @PVar@ @π@. For example, if+-- @π :: T1 -> T2 -> T3 -> Prop@+-- 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 (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)+ -> [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++predRTyCon :: RTyCon+predRTyCon = symbolRTyCon predName++wpredRTyCon :: RTyCon+wpredRTyCon = symbolRTyCon wpredName++symbolRTyCon :: F.Symbol -> RTyCon+symbolRTyCon n = RTyCon (stringTyCon 'x' 42 $ F.symbolString n) [] def++-------------------------------------------------------------------------------------+-- | Instantiate `PVar` with `RTProp` -----------------------------------------------+-------------------------------------------------------------------------------------+-- | @replacePreds@ is the main function used to substitute an (abstract)+-- predicate with a concrete Ref, that is either an `RProp` or `RHProp`+-- type. The substitution is invoked to obtain the `SpecType` resulting+-- at /predicate application/ sites in 'Language.Haskell.Liquid.Constraint'.+-- The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`.+-- That is, there are no further _quantified_ `PVar` in the target.+-------------------------------------------------------------------------------------+replacePreds :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType+-------------------------------------------------------------------------------------+replacePreds msg = L.foldl' go+ where+ go _ (_, RProp _ (RHole _)) = panic Nothing "replacePreds on RProp _ (RHole _)"+ go z (π, t) = substPred msg (π, t) z+++-- TODO: replace `replacePreds` with+-- instance SubsTy RPVar (Ref RReft SpecType) SpecType where+-- subt (pv, r) t = replacePreds "replacePred" t (pv, r)++-- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType+-- replacePreds msg = foldl' go+-- where go z (π, RProp t) = substPred msg (π, t) z+-- go z (π, RPropP r) = replacePVarReft (π, r) <$> z++-------------------------------------------------------------------------------------+substPVar :: PVar BSort -> PVar BSort -> BareType -> BareType+-------------------------------------------------------------------------------------+substPVar src dst = go+ where+ go :: BareType -> BareType+ 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)+ | pname q == pname src = RAllP q t+ | otherwise = RAllP q (go t)+ go (RAllT a t r) = RAllT a (go t) (goRR r)+ go (RFun x i t t' r) = RFun x i (go t) (go t') (goRR r)+ go (RAllE x t t') = RAllE x (go t) (go t')+ go (REx x t t') = REx x (go t) (go t')+ go (RRTy e r o rt) = RRTy e' (goRR r) o (go rt) where e' = [(x, go t) | (x, t) <- e]+ 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 rp = rp {rf_body = go (rf_body rp) }+ goRR :: RReft -> RReft+ goRR rr = rr { ur_pred = goP (ur_pred rr) }+ goP :: Predicate -> Predicate+ goP (Pr ps) = Pr (goPV <$> ps)+ goPV :: UsedPVar -> UsedPVar+ goPV pv+ | pname pv == pname src = pv { pname = pname dst }+ | otherwise = pv++-------------------------------------------------------------------------------+substPred :: String -> (RPVar, SpecProp) -> SpecType -> SpecType+-------------------------------------------------------------------------------++substPred _ (rp, RProp ss (RVar a1 r1)) t@(RVar a2 r2)+ | isPredInReft && a1 == a2 = RVar a1 $ meetListWithPSubs πs ss r1 r2'+ | isPredInReft = panic Nothing ("substPred RVar Var Mismatch" ++ show (a1, a2))+ | otherwise = t+ where+ (r2', πs) = splitRPvar rp r2+ isPredInReft = not $ null πs++substPred msg su@(π, _ ) (RApp c ts rs r)+ | null πs = t'+ | otherwise = substRCon msg su t' πs r2'+ where+ t' = RApp c (substPred msg su <$> ts) (substPredP msg su <$> rs) r+ (r2', πs) = splitRPvar π r++substPred msg (p, tp) (RAllP q@PV{} t)+ | p /= q = RAllP q $ substPred msg (p, tp) t+ | otherwise = RAllP q t++substPred msg su (RAllT a t r) = RAllT a (substPred msg su t) r++substPred msg su@(rp,prop) (RFun x i rt rt' r)+-- = RFun x (substPred msg su t) (substPred msg su t') r+ | 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+ 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 (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t')+substPred msg su (REx x t t') = REx x (substPred msg su t) (substPred msg su t')+substPred _ _ t = t++-- | Requires: @not $ null πs@+-- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType++substRCon+ :: (PPrint t, PPrint t2, Eq tv, F.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),+ SubsTy tv (RType RTyCon tv ()) (RTVar tv (RType RTyCon tv ())),+ FreeVar RTyCon tv,+ F.Reftable (RTProp RTyCon tv r),+ F.Reftable (RTProp RTyCon tv ()))+ => [Char]+ -> (t, Ref RSort (RType RTyCon tv r))+ -> RType RTyCon tv r+ -> [PVar t2]+ -> r+ -> RType RTyCon tv r+substRCon msg (_, RProp ss t1@(RApp c1 ts1 rs1 r1)) t2@(RApp c2 ts2 rs2 _) πs r2'+ | rtc_tc c1 == rtc_tc c2 = RApp c1 ts rs $ meetListWithPSubs πs ss r1 r2'+ 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+ 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++substRCon msg su t _ _ = {- panic Nothing -} errorP "substRCon: " $ msg ++ " " ++ showpp (su, t)++pad :: [Char] -> (a -> a) -> [a] -> [a] -> ([a], [a])+pad _ f [] ys = (f <$> ys, ys)+pad _ f xs [] = (xs, f <$> xs)+pad msg _ xs ys+ | nxs == nys = (xs, ys)+ | otherwise = panic Nothing $ "pad: " ++ msg+ where+ nxs = length xs+ nys = length ys++substPredP :: [Char]+ -> (RPVar, Ref RSort (RRType RReft))+ -> Ref RSort (RType RTyCon RTyVar RReft)+ -> Ref RSort SpecType+substPredP _ su p@(RProp _ (RHole _))+ = panic Nothing ("PredType.substPredP1 called on invalid inputs: " ++ showpp (su, p))+substPredP msg (p, RProp ss prop) (RProp s t)+ = RProp ss' $ substPred (msg ++ ": substPredP") (p, RProp ss {- (subst su prop) -} prop ) t+ where+ ss' = drop n ss ++ s+ n = length ss - length (freeArgsPs p t)+ -- su = mkSubst (zip (fst <$> ss) (EVar . fst <$> ss'))+++splitRPvar :: PVar t -> UReft r -> (UReft r, [UsedPVar])+splitRPvar pv (MkUReft x (Pr pvs)) = (MkUReft x (Pr pvs'), epvs)+ where+ (epvs, pvs') = L.partition (uPVar pv ==) pvs++-- TODO: rewrite using foldReft+freeArgsPs :: PVar (RType t t1 ()) -> RType t t1 (UReft t2) -> [F.Symbol]+freeArgsPs p (RVar _ r)+ = freeArgsPsRef p r+freeArgsPs p (RFun _ _ t1 t2 r)+ = L.nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (RAllT _ t r)+ = L.nub $ freeArgsPs p t ++ freeArgsPsRef p r+freeArgsPs p (RAllP p' t)+ | p == p' = []+ | otherwise = freeArgsPs p t+freeArgsPs p (RApp _ ts _ r)+ = L.nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts+freeArgsPs p (RAllE _ t1 t2)+ = L.nub $ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (REx _ t1 t2)+ = L.nub $ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (RAppTy t1 t2 r)+ = L.nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs _ (RExprArg _)+ = []+freeArgsPs p (RHole r)+ = freeArgsPsRef p r+freeArgsPs p (RRTy env r _ t)+ = L.nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t++freeArgsPsRef :: PVar t1 -> UReft t -> [F.Symbol]+freeArgsPsRef p (MkUReft _ (Pr ps)) = [x | (_, x, w) <- concatMap pargs ps', F.EVar x == w]+ where+ 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)+ => 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))+ => t (PVar t4)+ -> [(F.Symbol, b)]+ -> Ref τ (RType t1 t2 t3)+ -> Ref τ (RType t1 t2 t3)+ -> 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 ss r1 r2 π+ | all (\(_, x, F.EVar y) -> x == y) (pargs π)+ = r2 `F.meet` r1+ | all (\(_, x, F.EVar y) -> x /= y) (pargs π)+ = r2 `F.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))+ => [(F.Symbol, b)]+ -> Ref τ (RType t t1 t2)+ -> Ref τ (RType t t1 t2)+ -> PVar t3+ -> Ref τ (RType t t1 t2)+meetListWithPSubRef _ (RProp _ (RHole _)) _ _ -- TODO: Is this correct?+ = panic Nothing "PredType.meetListWithPSubRef called with invalid input"+meetListWithPSubRef _ _ (RProp _ (RHole _)) _+ = 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+ | all (\(_, x, F.EVar y) -> x /= y) (pargs π)+ = RProp s2 $ r2 `F.meet` F.subst su r1+ | otherwise+ = panic Nothing $ "PredType.meetListWithPSubRef partial application to " ++ showpp π+ where+ su = F.mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]+ su' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip (fst <$> s2) (fst <$> s1)]+++----------------------------------------------------------------------------+-- | Interface: Modified CoreSyn.exprType due to predApp -------------------+----------------------------------------------------------------------------+predType :: Type+predType = symbolType predName++wpredName, predName :: F.Symbol+predName = "Pred"+wpredName = "WPred"++symbolType :: F.Symbol -> Type+symbolType = TyVarTy . symbolTyVar+++substParg :: Functor f => (F.Symbol, F.Expr) -> f Predicate -> f Predicate+substParg (x, y) = fmap fp+ where+ fxy s = if s == F.EVar x then y else s+ fp = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv })++-------------------------------------------------------------------------------+----------------------------- Predicate Application --------------------------+-------------------------------------------------------------------------------+pappArity :: Int+pappArity = 7++pappSort :: Int -> F.Sort+pappSort n = F.mkFFunc (2 * n) $ [ptycon] ++ args ++ [F.boolSort]+ where+ ptycon = F.fAppTC predFTyCon $ F.FVar <$> [0..n-1]+ args = F.FVar <$> [n..(2*n-1)]+++predFTyCon :: F.FTycon+predFTyCon = F.symbolFTycon $ dummyLoc predName
+ src/Language/Haskell/Liquid/Types/PrettyPrint.hs view
@@ -0,0 +1,560 @@+-- | This module contains a single function that converts a RType -> Doc+-- without using *any* simplifications.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Haskell.Liquid.Types.PrettyPrint+ ( -- * Printable RTypes+ OkRT++ -- * Printers+ , rtypeDoc++ -- * Printing Lists (TODO: move to fixpoint)+ , pprManyOrdered+ , pprintLongList+ , pprintSymbol++ -- * Printing diagnostics+ , printWarning++ -- * Filtering errors+ , Filter(..)+ , getFilters+ , reduceFilters+ , defaultFilterReporter++ -- * Reporting errors in the typechecking phase+ , FilterReportErrorsArgs(..)+ , filterReportErrorsWith+ , filterReportErrors++ ) where++import Control.Monad (void)+import qualified Data.HashMap.Strict as M+import qualified Data.List as L -- (sort)+import qualified Data.Set as Set+import Data.String+import Language.Fixpoint.Misc+import qualified Language.Fixpoint.Types as F+import qualified Liquid.GHC.API as Ghc+import Liquid.GHC.API as Ghc ( Class+ , SrcSpan+ , PprPrec+ , Type+ , Var+ , Name+ , SourceError+ , TyCon+ , topPrec+ , funPrec+ , srcSpanStartLine+ , srcSpanStartCol+ )+import Language.Haskell.Liquid.GHC.Logging (mkLongErrAt)+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.Types.Types+import Prelude hiding (error)+import Text.PrettyPrint.HughesPJ hiding ((<>))+++-- | `Filter`s match errors. They are used to ignore classes of errors they+-- match. `AnyFilter` matches all errors. `StringFilter` matches any error whose+-- \"representation\" contains the given `String`. A \"representation\" is+-- pretty-printed String of the error.+data Filter = StringFilter String+ | AnyFilter+ deriving (Eq, Ord, Show)++--------------------------------------------------------------------------------+pprManyOrdered :: (PPrint a, Ord a) => F.Tidy -> String -> [a] -> [Doc]+--------------------------------------------------------------------------------+pprManyOrdered k msg = map ((text msg <+>) . pprintTidy k) . L.sort++--------------------------------------------------------------------------------+pprintLongList :: PPrint a => F.Tidy -> [a] -> Doc+--------------------------------------------------------------------------------+pprintLongList k = brackets . vcat . map (pprintTidy k)+++--------------------------------------------------------------------------------+pprintSymbol :: F.Symbol -> Doc+--------------------------------------------------------------------------------+pprintSymbol x = char '‘' <-> pprint x <-> char '’'+++--------------------------------------------------------------------------------+-- | A whole bunch of PPrint instances follow ----------------------------------+--------------------------------------------------------------------------------+instance PPrint (Ghc.MsgEnvelope Ghc.DecoratedSDoc) where+ pprintTidy _ = text . show++instance PPrint SourceError where+ pprintTidy _ = text . show++instance PPrint Var where+ pprintTidy _ = pprDoc++instance PPrint (Ghc.Expr Var) where+ pprintTidy _ = pprDoc++instance PPrint (Ghc.Bind Var) where+ pprintTidy _ = pprDoc++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???++instance PPrint Class where+ pprintTidy F.Lossy = shortModules . pprDoc+ pprintTidy F.Full = pprDoc++instance Show Predicate where+ show = showpp++instance (PPrint t) => PPrint (Annot t) where+ pprintTidy k (AnnUse t) = text "AnnUse" <+> pprintTidy k t+ pprintTidy k (AnnDef t) = text "AnnDef" <+> pprintTidy k t+ pprintTidy k (AnnRDf t) = text "AnnRDf" <+> pprintTidy k t+ pprintTidy _ (AnnLoc l) = text "AnnLoc" <+> pprDoc l++instance PPrint a => PPrint (AnnInfo a) where+ pprintTidy k (AI m) = vcat $ pprAnnInfoBinds k <$> M.toList m++instance PPrint a => Show (AnnInfo a) where+ show = showpp++pprAnnInfoBinds :: (PPrint a, PPrint b) => F.Tidy -> (SrcSpan, [(Maybe a, b)]) -> Doc+pprAnnInfoBinds k (l, xvs)+ = vcat $ pprAnnInfoBind k . (l,) <$> xvs++pprAnnInfoBind :: (PPrint a, PPrint b) => F.Tidy -> (SrcSpan, (Maybe a, b)) -> Doc+pprAnnInfoBind k (Ghc.RealSrcSpan sp _, xv)+ = xd $$ pprDoc l $$ pprDoc c $$ pprintTidy k n $$ vd $$ text "\n\n\n"+ where+ l = srcSpanStartLine sp+ c = srcSpanStartCol sp+ (xd, vd) = pprXOT k xv+ n = length $ lines $ render vd++pprAnnInfoBind _ (_, _)+ = empty++pprXOT :: (PPrint a, PPrint a1) => F.Tidy -> (Maybe a, a1) -> (Doc, Doc)+pprXOT k (x, v) = (xd, pprintTidy k v)+ where+ xd = maybe "unknown" (pprintTidy k) x++instance PPrint LMap where+ pprintTidy _ (LMap x xs e) = hcat [pprint x, pprint xs, text "|->", pprint e ]++instance PPrint LogicMap where+ pprintTidy _ (LM lm am) = vcat [ text "Logic Map"+ , nest 2 $ text "logic-map"+ , nest 4 $ pprint lm+ , nest 2 $ text "axiom-map"+ , nest 4 $ pprint am+ ]++--------------------------------------------------------------------------------+-- | Pretty Printing RefType ---------------------------------------------------+--------------------------------------------------------------------------------+instance (OkRT c tv r) => PPrint (RType c tv r) where+ -- RJ: THIS IS THE CRUCIAL LINE, the following prints short types.+ pprintTidy _ = rtypeDoc F.Lossy+ -- pprintTidy _ = ppRType topPrec++instance (PPrint tv, PPrint ty) => PPrint (RTAlias tv ty) where+ pprintTidy = ppAlias++ppAlias :: (PPrint tv, PPrint ty) => F.Tidy -> RTAlias tv ty -> Doc+ppAlias k a = pprint (rtName a)+ <+> pprints k space (rtTArgs a)+ <+> pprints k space (rtVArgs a)+ <+> text " = "+ <+> pprint (rtBody a)++instance (F.PPrint tv, F.PPrint t) => F.PPrint (RTEnv tv t) where+ pprintTidy k rte+ = text "** Type Aliaes *********************"+ $+$ nest 4 (F.pprintTidy k (typeAliases rte))+ $+$ text "** Expr Aliases ********************"+ $+$ nest 4 (F.pprintTidy k (exprAliases rte))++pprints :: (PPrint a) => F.Tidy -> Doc -> [a] -> Doc+pprints k c = sep . punctuate c . map (pprintTidy k)++--------------------------------------------------------------------------------+rtypeDoc :: (OkRT c tv r) => F.Tidy -> RType c tv r -> Doc+--------------------------------------------------------------------------------+rtypeDoc k = pprRtype (ppE k) topPrec+ where+ ppE F.Lossy = ppEnvShort ppEnv+ ppE F.Full = ppEnv++instance PPrint F.Tidy where+ pprintTidy _ F.Full = "Full"+ pprintTidy _ F.Lossy = "Lossy"++type Prec = PprPrec++--------------------------------------------------------------------------------+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+pprRtype bb p t@(RAllP _ _)+ = pprForall bb p t+pprRtype _ _ (RVar a r)+ = F.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+pprRtype bb p (RApp c ts rs r)+ | isTuple c+ = F.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+ | otherwise+ = F.ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc+ where+ rsDoc = ppReftPs bb p rs+ tsDoc = hsep (pprRtype bb p <$> ts)+ ppT = ppTyConB bb++pprRtype bb p t@REx{}+ = ppExists bb p t+pprRtype bb p t@RAllE{}+ = ppAllExpr bb p t+pprRtype _ _ (RExprArg e)+ = braces $ pprint e+pprRtype bb p (RAppTy t t' r)+ = F.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)+ = sep [ppp (pprint o <+> ppe <+> pprint r), pprRtype bb p rt]+ where+ ppe = hsep (punctuate comma (ppxt <$> e)) <+> dcolon+ ppp doc = text "<<" <+> doc <+> text ">>"+ ppxt (x, t) = pprint x <+> ":" <+> pprRtype bb p t+pprRtype _ _ (RHole r)+ = F.ppTy r $ text "_"++ppTyConB :: TyConable c => PPEnv -> c -> Doc+ppTyConB bb+ | ppShort bb = {- shortModules . -} ppTycon+ | otherwise = ppTycon++shortModules :: Doc -> Doc+shortModules = text . F.symbolString . dropModuleNames . F.symbol . render++pprRsubtype+ :: (OkRT c tv r, PPrint a, PPrint (RType c tv r), PPrint (RType c tv ()))+ => PPEnv -> Prec -> [(a, RType c tv r)] -> Doc+pprRsubtype bb p e+ = pprint_env <+> text "|-" <+> pprRtype bb p tl <+> "<:" <+> pprRtype bb p tr+ where+ (el, r) = (init e, last e)+ (env, l) = (init el, last el)+ tr = snd r+ tl = snd l+ pprint_bind (x, t) = pprint x <+> colon <-> colon <+> pprRtype bb p t+ pprint_env = hsep $ punctuate comma (pprint_bind <$> env)++-- | From GHC: TypeRep+maybeParen :: Prec -> Prec -> Doc -> Doc+maybeParen ctxt_prec inner_prec pretty+ | ctxt_prec < inner_prec = pretty+ | otherwise = parens pretty++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 ()))+ => 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'+ where (ws, rt') = split [] rt+ split zs (REx x t t') = split ((x,t):zs) t'+ split zs t = (reverse zs, t)++ppAllExpr+ :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))+ => PPEnv -> Prec -> RType c tv r -> Doc+ppAllExpr bb p rt+ = text "forall" <+> brackets (intersperse comma [pprDbind bb topPrec x t | (x, t) <- ws]) <-> dot <-> pprRtype bb p rt'+ where+ (ws, rt') = split [] rt+ split zs (RAllE x t t') = split ((x,t):zs) t'+ split zs t = (reverse zs, t)++ppReftPs+ :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()),+ F.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+ | not (ppPs ppEnv) = empty+ | otherwise = angleBrackets $ hsep $ punctuate comma $ pprRef <$> rs++pprDbind+ :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))+ => PPEnv -> Prec -> F.Symbol -> RType c tv r -> Doc+pprDbind bb p x t+ | F.isNonSymbol x || (x == F.dummySymbol)+ = pprRtype bb p t+ | otherwise+ = pprint x <-> colon <-> pprRtype bb p t++++pprRtyFun+ :: ( OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))+ => PPEnv -> Doc -> RType c tv r -> Doc+pprRtyFun bb prefix rt = hsep (prefix : dArgs ++ [dOut])+ where+ dArgs = concatMap ppArg args+ dOut = pprRtype bb topPrec out+ ppArg (b, t, a) = [pprDbind bb funPrec b t, a]+ (args, out) = brkFun rt++{-+pprRtyFun bb prefix t+ = prefix <+> pprRtyFun' bb t++pprRtyFun'+ :: ( OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))+ => PPEnv -> RType c tv r -> Doc+pprRtyFun' bb (RImpF b t t' r)+ = F.ppTy r $ pprDbind bb funPrec b t $+$ pprRtyFun bb (text "~>") t'+pprRtyFun' bb (RFun b t t' r)+ = F.ppTy r $ pprDbind bb funPrec b t $+$ pprRtyFun bb arrow t'+pprRtyFun' bb t+ = pprRtype bb topPrec t+-}++brkFun :: RType c tv r -> ([(F.Symbol, RType c tv r, Doc)], RType c tv r)+brkFun (RFun b _ t t' _) = ((b, t, text "->") : args, out)+ where (args, out) = brkFun t'+brkFun out = ([], out)+++++pprForall :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc+pprForall bb p t = maybeParen p funPrec $ sep [+ pprForalls (ppPs bb) (fst <$> ty_vars trep) (ty_preds trep)+ , pprClss cls+ , pprRtype bb topPrec t'+ ]+ where+ trep = toRTypeRep t+ -- YL: remember to revert back+ (cls, t') = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = []}+ -- t' = fromRTypeRep $ trep {ty_vars = [], ty_preds = []}++ pprForalls False _ _ = empty+ pprForalls _ [] [] = empty+ pprForalls True αs πs = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <-> dot++ pprClss [] = empty+ pprClss cs = parens (hsep $ punctuate comma (uncurry (pprCls bb p) <$> cs)) <+> text "=>"++ dαs αs = pprRtvarDef αs++ -- dπs :: Bool -> [PVar a] -> Doc+ dπs _ [] = empty+ dπs False _ = empty+ dπs True πs = angleBrackets $ intersperse comma $ pprPvarDef bb p <$> πs++pprRtvarDef :: (PPrint tv) => [RTVar tv (RType c tv ())] -> Doc+pprRtvarDef = sep . map (pprint . ty_var_value)++pprCls+ :: (OkRT c tv r, PPrint a, PPrint (RType c tv r),+ PPrint (RType c tv ()))+ => PPEnv -> Prec -> a -> [RType c tv r] -> Doc+pprCls bb p c ts+ = pp c <+> hsep (map (pprRtype bb p) ts)+ where+ pp | ppShort bb = text . F.symbolString . dropModuleNames . F.symbol . render . pprint+ | otherwise = pprint+++pprPvarDef :: (OkRT c tv ()) => PPEnv -> Prec -> PVar (RType c tv ()) -> Doc+pprPvarDef bb p (PV s t _ xts)+ = pprint s <+> dcolon <+> intersperse arrow dargs <+> pprPvarKind bb p t+ where+ 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++pprName :: F.Symbol -> Doc+pprName = text . F.symbolString++pprPvarSort :: (OkRT c tv ()) => PPEnv -> Prec -> RType c tv () -> Doc+pprPvarSort bb p t = pprRtype bb p t++pprRef :: (OkRT c tv r) => Ref (RType c tv ()) (RType c tv r) -> Doc+pprRef (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint s+-- pprRef (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))++ppRefArgs :: [F.Symbol] -> Doc+ppRefArgs [] = empty+ppRefArgs ss = text "\\" <-> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> arrow++ppRefSym :: (Eq a, IsString a, PPrint a) => a -> Doc+ppRefSym "" = text "_"+ppRefSym s = pprint s++dot :: Doc+dot = char '.'++instance (PPrint r, F.Reftable r) => PPrint (UReft r) where+ pprintTidy k (MkUReft r p)+ | F.isTauto r = pprintTidy k p+ | F.isTauto p = pprintTidy k r+ | otherwise = pprintTidy k p <-> text " & " <-> pprintTidy k r++--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- | Pretty-printing errors ----------------------------------------------------+--------------------------------------------------------------------------------++-- | Similar in spirit to 'reportErrors' from the GHC API, but it uses our+-- pretty-printer and shim functions under the hood. Also filters the errors+-- according to the given `Filter` list.+--+-- @filterReportErrors failure continue filters k@ will call @failure@ if there+-- are unexpected errors, or will call @continue@ otherwise.+--+-- An error is expected if there is any filter that matches it.+filterReportErrors :: forall e' a. (Show e', F.PPrint e') => FilePath -> Ghc.TcRn a -> Ghc.TcRn a -> [Filter] -> F.Tidy -> [TError e'] -> Ghc.TcRn a+filterReportErrors path failure continue filters k =+ filterReportErrorsWith+ FilterReportErrorsArgs { msgReporter = Ghc.reportErrors+ , filterReporter = defaultFilterReporter path+ , failure = failure+ , continue = continue+ , pprinter = \err -> mkLongErrAt (pos err) (ppError k empty err) mempty+ , matchingFilters = reduceFilters renderer filters+ , filters = filters+ }+ where+ renderer e = render (ppError k empty e $+$ pprint (pos e))+++-- | Retrieve the `Filter`s from the Config.+getFilters :: Config -> [Filter]+getFilters cfg = anyFilter <> stringFilters+ where+ anyFilter = [AnyFilter | expectAnyError cfg]+ stringFilters = StringFilter <$> expectErrorContaining cfg++-- | Return the list of @filters@ that matched the @err@ , given a @renderer@+-- for the @err@ and some @filters@+reduceFilters :: (e -> String) -> [Filter] -> e -> [Filter]+reduceFilters renderer fs err = filter (filterDoesMatchErr renderer err) fs++filterDoesMatchErr :: (e -> String) -> e -> Filter -> Bool+filterDoesMatchErr _ _ AnyFilter = True+filterDoesMatchErr renderer e (StringFilter filter') = stringMatch filter' (renderer e)++stringMatch :: String -> String -> Bool+stringMatch filter' str = filter' `L.isInfixOf` str++-- | Used in `filterReportErrorsWith'`+data FilterReportErrorsArgs m filter msg e a =+ FilterReportErrorsArgs+ {+ -- | Report the @msgs@ to the monad (usually IO)+ msgReporter :: [msg] -> m ()+ ,+ -- | Report unmatched @filters@ to the monad+ filterReporter :: [filter] -> m ()+ ,+ -- | Continuation for when there are unmatched filters or unmatched errors+ failure :: m a+ ,+ -- | Continuation for when there are no unmatched errors or filters+ continue :: m a+ ,+ -- | Compute a representation of the given error; does not report the error+ pprinter :: e -> m msg+ ,+ -- | Yields the filters that map a given error. Must only yield+ -- filters in the @filters@ field.+ matchingFilters :: e -> [filter]+ ,+ -- | List of filters which could have been matched+ filters :: [filter]+ }++-- | Calls the continuations in FilterReportErrorsArgs depending on whethere there+-- are unmatched errors, unmatched filters or none.+filterReportErrorsWith :: (Monad m, Ord filter) => FilterReportErrorsArgs m filter msg e a -> [e] -> m a+filterReportErrorsWith FilterReportErrorsArgs {..} errs =+ let+ (unmatchedErrors, matchedFilters) =+ L.partition (null . snd) [ (e, fs) | e <- errs, let fs = matchingFilters e ]+ unmatchedFilters = Set.toList $+ Set.fromList filters `Set.difference` Set.fromList (concatMap snd matchedFilters)+ in+ if null unmatchedErrors then+ if null unmatchedFilters then+ continue+ else do+ filterReporter unmatchedFilters+ failure+ else do+ msgs <- traverse (pprinter . fst) unmatchedErrors+ void $ msgReporter msgs+ failure++-- | Report errors via GHC's API stating the given `Filter`s did not get+-- matched. Does nothing if the list of filters is empty.+defaultFilterReporter :: FilePath -> [Filter] -> Ghc.TcRn ()+defaultFilterReporter _ [] = pure ()+defaultFilterReporter path fs = Ghc.reportError =<< mkLongErrAt srcSpan (vcat $ leaderMsg : (nest 4 <$> filterMsgs)) empty+ where+ leaderMsg :: Doc+ leaderMsg = text "Could not match the following expected errors with actual thrown errors:"++ filterToMsg :: Filter -> Doc+ filterToMsg AnyFilter = text "<Any Liquid error>"+ filterToMsg (StringFilter s) = text "String filter: " <-> quotes (text s)++ filterMsgs :: [Doc]+ filterMsgs = filterToMsg <$> fs++ beginningOfFile :: Ghc.SrcLoc+ beginningOfFile = Ghc.mkSrcLoc (fromString path) 1 1++ srcSpan :: SrcSpan+ srcSpan = Ghc.mkSrcSpan beginningOfFile beginningOfFile
+ src/Language/Haskell/Liquid/Types/RefType.hs view
@@ -0,0 +1,1933 @@+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Refinement Types. Mostly mirroring the GHC Type definition, but with+-- room for refinements of various sorts.+-- TODO: Desperately needs re-organization.++module Language.Haskell.Liquid.Types.RefType (++ TyConMap++ -- * Functions for lifting Reft-values to Spec-values+ , uTop, uReft, uRType, uRType', uRTypeGen, uPVar++ -- * Applying a solution to a SpecType+ , applySolution++ -- * Functions for decreasing arguments+ , isDecreasing, makeDecrType, makeNumEnv+ , makeLexRefa++ -- * Functions for manipulating `Predicate`s+ , pdVar+ , findPVar+ , FreeVar, allTyVars, allTyVars', freeTyVars, tyClasses, tyConName++ -- * Quantifying RTypes+ , quantifyRTy+ , quantifyFreeRTy++ -- * RType constructors+ , ofType, toType, bareOfType+ , bTyVar, rTyVar, rVar, rApp, gApp, rEx+ , symbolRTyVar, bareRTyVar+ , tyConBTyCon+ , pdVarReft++ -- * Substitutions+ , subts, subvPredicate, subvUReft+ , subsTyVarMeet, subsTyVarMeet', subsTyVarNoMeet+ , subsTyVarsNoMeet, subsTyVarsMeet++ -- * Destructors+ , addTyConInfo+ , appRTyCon+ , typeUniqueSymbol+ , classBinds+ , isSizeable+ , famInstTyConType+ , famInstArgs++ -- * Manipulating Refinements in RTypes+ , strengthen+ , generalize+ , normalizePds+ , dataConMsReft+ , dataConReft+ , rTypeSortedReft+ , rTypeSort+ , typeSort+ , shiftVV++ -- * TODO: classify these+ -- , mkDataConIdsTy+ , expandProductType+ , mkTyConInfo+ , strengthenRefTypeGen+ , strengthenDataConType+ , isBaseTy+ , updateRTVar, isValKind, kindToRType+ , rTVarInfo++ , tyVarsPosition, Positions(..)++ , isNumeric++ ) where++-- import GHC.Stack+import Prelude hiding (error)+-- import qualified Prelude+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid (First(..))+import Data.Hashable+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.List as L+import Control.Monad (void)+import Text.Printf+import Text.PrettyPrint.HughesPJ hiding ((<>), first)+import Language.Fixpoint.Misc+import Language.Fixpoint.Types hiding (DataDecl (..), DataCtor (..), panic, shiftVV, Predicate, isNumeric)+import Language.Fixpoint.Types.Visitor (mapKVars, Visitable)+import qualified Language.Fixpoint.Types as F+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.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+ , Located+ , tyConName+ , punctuate+ , hcat+ , (<+>)+ , parens+ , empty+ , dcolon+ , vcat+ , nest+ , ($+$)+ , panic+ , text+ )+import Language.Haskell.Liquid.GHC.TypeRep () -- Eq Type instance+import Data.List (foldl')++++++++strengthenDataConType :: (Var, SpecType) -> (Var, SpecType)+strengthenDataConType (x, t) = (x, fromRTypeRep trep {ty_res = tres})+ where+ tres = F.notracepp _msg $ ty_res trep `strengthen` MkUReft (exprReft expr') mempty+ trep = toRTypeRep t+ _msg = "STRENGTHEN-DATACONTYPE x = " ++ F.showpp (x, zip xs ts)+ (xs, ts) = dataConArgs trep+ as = ty_vars trep+ x' = symbol x+ expr' | null xs && null as = EVar x'+ | otherwise = mkEApp (dummyLoc x') (EVar <$> xs)+++dataConArgs :: SpecRep -> ([Symbol], [SpecType])+dataConArgs trep = unzip [ (x, t) | (x, t) <- zip xs ts, isValTy t]+ where+ xs = ty_binds trep+ ts = ty_args trep+ isValTy = not . Ghc.isEvVarType . toType False+++pdVar :: PVar t -> Predicate+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)+ where+ PV name ty v args = fromMaybe (msg upv) $ L.find ((== pname upv) . pname) ps+ msg p = panic Nothing $ "RefType.findPVar" ++ showpp p ++ "not found"++-- | Various functions for converting vanilla `Reft` to `Spec`++uRType :: RType c tv a -> RType c tv (UReft a)+uRType = fmap uTop++uRType' :: RType c tv (UReft a) -> RType c tv a+uRType' = fmap ur_reft++uRTypeGen :: Reftable b => RType c tv a -> RType c tv b+uRTypeGen = fmap $ const mempty++uPVar :: PVar t -> UsedPVar+uPVar = void++uReft :: (Symbol, Expr) -> UReft Reft+uReft = uTop . Reft++uTop :: r -> UReft r+uTop r = MkUReft r mempty++--------------------------------------------------------------------+-------------- (Class) Predicates for Valid Refinement Types -------+--------------------------------------------------------------------+++-- Monoid Instances ---------------------------------------------------------++instance ( SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) c+ , OkRT c tv r+ , FreeVar c tv+ , SubsTy tv (RType c tv ()) r+ , SubsTy tv (RType c tv ()) tv+ , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+ )+ => Semigroup (RType c tv r) where+ (<>) = strengthenRefType++-- TODO: remove, use only Semigroup?+instance ( SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) c+ , OkRT c tv r+ , FreeVar c tv+ , SubsTy tv (RType c tv ()) r+ , SubsTy tv (RType c tv ()) tv+ , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+ )+ => Monoid (RType c tv r) where+ mempty = panic Nothing "mempty: RType"++-- MOVE TO TYPES+instance ( SubsTy tv (RType c tv ()) c+ , OkRT c tv r+ , FreeVar c tv+ , SubsTy tv (RType c tv ()) r+ , SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) tv+ , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+ )+ => Semigroup (RTProp c tv r) where+ (<>) (RProp s1 (RHole r1)) (RProp s2 (RHole r2))+ | isTauto r1 = RProp s2 (RHole r2)+ | isTauto r2 = RProp s1 (RHole r1)+ | otherwise = RProp s1 $ RHole $ r1 `meet`+ subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2++ (<>) (RProp s1 t1) (RProp s2 t2)+ | isTrivial t1 = RProp s2 t2+ | isTrivial t2 = RProp s1 t1+ | otherwise = RProp s1 $ t1 `strengthenRefType`+ subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2++-- TODO: remove and use only Semigroup?+instance ( SubsTy tv (RType c tv ()) c+ , OkRT c tv r+ , FreeVar c tv+ , SubsTy tv (RType c tv ()) r+ , SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) tv+ , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+ )+ => Monoid (RTProp c tv r) where+ mempty = panic Nothing "mempty: RTProp"+ mappend = (<>)++{-+NV: The following makes ghc diverge thus dublicating the code+instance ( OkRT c tv r+ , FreeVar c tv+ , SubsTy tv (RType c tv ()) r+ , SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) c+ , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+ , SubsTy tv (RType c tv ()) tv+ ) => Reftable (RTProp c tv r) where+ isTauto (RProp _ (RHole r)) = isTauto r+ isTauto (RProp _ t) = isTrivial t+ top (RProp _ (RHole _)) = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"+ top (RProp xs t) = RProp xs $ mapReft top t+ 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 (UReft Reft)) where+ isTauto (RProp _ (RHole r)) = isTauto r+ isTauto (RProp _ t) = isTrivial t+ top (RProp _ (RHole _)) = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"+ top (RProp xs t) = RProp xs $ mapReft top t+ 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+ isTauto (RProp _ (RHole r)) = isTauto r+ isTauto (RProp _ t) = isTrivial t+ top (RProp _ (RHole _)) = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"+ top (RProp xs t) = RProp xs $ mapReft top t+ 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+ isTauto (RProp _ (RHole r)) = isTauto r+ isTauto (RProp _ t) = isTrivial t+ top (RProp _ (RHole _)) = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"+ top (RProp xs t) = RProp xs $ mapReft top t+ 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+ isTauto (RProp _ (RHole r)) = isTauto r+ isTauto (RProp _ t) = isTrivial t+ top (RProp _ (RHole _)) = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"+ top (RProp xs t) = RProp xs $ mapReft top t+ 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+ isTauto (RProp _ (RHole r)) = isTauto r+ isTauto (RProp _ t) = isTrivial t+ top (RProp _ (RHole _)) = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"+ top (RProp xs t) = RProp xs $ mapReft top t+ 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"++----------------------------------------------------------------------------+-- | Subable Instances -----------------------------------------------------+----------------------------------------------------------------------------++instance Subable (RRProp Reft) where+ syms (RProp ss (RHole r)) = (fst <$> ss) ++ syms r+ 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+++ 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++ 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+++-------------------------------------------------------------------------------+-- | Reftable Instances -------------------------------------------------------+-------------------------------------------------------------------------------++instance (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))+ => Reftable (RType RTyCon RTyVar r) where+ 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"+++instance Reftable (RType BTyCon BTyVar (UReft Reft)) where+ isTauto = isTrivial+ 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"++++-- MOVE TO TYPES+instance Fixpoint String where+ toFix = text++-- MOVE TO TYPES+instance Fixpoint Class where+ toFix = text . GM.showPpr++-- MOVE TO TYPES+class FreeVar a v where+ freeVars :: a -> [v]++-- MOVE TO TYPES+instance FreeVar RTyCon RTyVar where+ freeVars = (RTV <$>) . GM.tyConTyVarsDef . rtc_tc++-- MOVE TO TYPES+instance FreeVar BTyCon BTyVar where+ freeVars _ = []++-- Eq Instances ------------------------------------------------------++-- MOVE TO TYPES+instance (Eq c, Eq tv, Hashable tv, PPrint tv, TyConable c, PPrint c, Reftable (RTProp c tv ()))+ => Eq (RType c tv ()) where+ (==) = eqRSort M.empty++eqRSort :: (Eq a, Eq k, Hashable k, TyConable a, PPrint a, PPrint k, Reftable (RTProp a k ()))+ => M.HashMap k k -> RType a k () -> RType a k () -> Bool+eqRSort m (RAllP _ t) (RAllP _ t')+ = eqRSort m t t'+eqRSort m (RAllP _ t) t'+ = eqRSort m t t'+eqRSort m (RAllT a t _) (RAllT a' t' _)+ | a == a'+ = eqRSort m t t'+ | otherwise+ = eqRSort (M.insert (ty_var_value a') (ty_var_value a) m) t t'+eqRSort m (RAllT _ t _) t'+ = eqRSort m t t'+eqRSort m t (RAllT _ t' _)+ = eqRSort m t t'+eqRSort m (RFun _ _ t1 t2 _) (RFun _ _ t1' t2' _)+ = eqRSort m t1 t1' && eqRSort m t2 t2'+eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _)+ = eqRSort m t1 t1' && eqRSort m t2 t2'+eqRSort m (RApp c ts _ _) (RApp c' ts' _ _)+ = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts')+eqRSort m (RVar a _) (RVar a' _)+ = a == M.lookupDefault a' a' m+eqRSort _ (RHole _) _+ = True+eqRSort _ _ (RHole _)+ = True+eqRSort _ _ _+ = False++--------------------------------------------------------------------------------+-- | Wrappers for GHC Type Elements --------------------------------------------+--------------------------------------------------------------------------------++instance Eq RTyVar where+ -- FIXME: need to compare unique and string because we reuse+ -- uniques in stringTyVar and co.+ RTV α == RTV α' = α == α' && getOccName α == getOccName α'++instance Ord RTyVar where+ compare (RTV α) (RTV α') = case compare α α' of+ EQ -> compare (getOccName α) (getOccName α')+ o -> o++instance Hashable RTyVar where+ hashWithSalt i (RTV α) = hashWithSalt i α++-- TyCon isn't comparable+--instance Ord RTyCon where+-- compare x y = compare (rtc_tc x) (rtc_tc y)++instance Hashable RTyCon where+ hashWithSalt i = hashWithSalt i . rtc_tc++--------------------------------------------------------------------------------+-- | Helper Functions (RJ: Helping to do what?) --------------------------------+--------------------------------------------------------------------------------++rVar :: Monoid r => TyVar -> RType c RTyVar r+rVar = (`RVar` mempty) . RTV++rTyVar :: TyVar -> RTyVar+rTyVar = RTV++updateRTVar :: Monoid r => RTVar RTyVar i -> RTVar RTyVar (RType RTyCon RTyVar r)+updateRTVar (RTVar (RTV a) _) = RTVar (RTV a) (rTVarInfo a)++rTVar :: Monoid r => TyVar -> RTVar RTyVar (RRType r)+rTVar a = RTVar (RTV a) (rTVarInfo a)++bTVar :: Monoid r => TyVar -> RTVar BTyVar (BRType r)+bTVar a = RTVar (BTV (symbol a)) (bTVarInfo a)++bTVarInfo :: Monoid r => TyVar -> RTVInfo (BRType r)+bTVarInfo = mkTVarInfo kindToBRType++rTVarInfo :: Monoid r => TyVar -> RTVInfo (RRType r)+rTVarInfo = mkTVarInfo kindToRType++mkTVarInfo :: (Kind -> s) -> TyVar -> RTVInfo s+mkTVarInfo k2t a = RTVInfo+ { rtv_name = symbol $ varName a+ , rtv_kind = k2t $ tyVarKind a+ , rtv_is_val = isValKind $ tyVarKind a+ , rtv_is_pol = True+ }++kindToRType :: Monoid r => Type -> RRType r+kindToRType = kindToRType_ ofType++kindToBRType :: Monoid r => Type -> BRType r+kindToBRType = kindToRType_ bareOfType++kindToRType_ :: (Type -> z) -> Type -> z+kindToRType_ ofType' = ofType' . go+ where+ go t+ | t == typeSymbolKind = stringTy+ | t == naturalTy = intTy+ | otherwise = t++isValKind :: Kind -> Bool+isValKind x0 =+ let x = expandTypeSynonyms x0+ in x == naturalTy || x == typeSymbolKind++bTyVar :: Symbol -> BTyVar+bTyVar = BTV++symbolRTyVar :: Symbol -> RTyVar+symbolRTyVar = rTyVar . GM.symbolTyVar++bareRTyVar :: BTyVar -> RTyVar+bareRTyVar (BTV tv) = symbolRTyVar tv++normalizePds :: (OkRT c tv r) => RType c tv r -> RType c tv r+normalizePds t = addPds ps t'+ where+ (t', ps) = nlzP [] t++rPred :: PVar (RType c tv ()) -> RType c tv r -> RType c tv r+rPred = RAllP++rEx :: Foldable t+ => t (Symbol, RType c tv r) -> RType c tv r -> RType c tv r+rEx xts rt = foldr (\(x, tx) t -> REx x tx t) rt xts++rApp :: TyCon+ -> [RType RTyCon tv r]+ -> [RTProp RTyCon tv r]+ -> r+ -> RType RTyCon tv r+rApp c = RApp (tyConRTyCon c)++gApp :: TyCon -> [RTyVar] -> [PVar a] -> SpecType+gApp tc αs πs = rApp tc+ [rVar α | RTV α <- αs]+ (rPropP [] . pdVarReft <$> πs)+ mempty++pdVarReft :: PVar t -> UReft Reft+pdVarReft = (\p -> MkUReft mempty p) . pdVar++tyConRTyCon :: TyCon -> RTyCon+tyConRTyCon c = RTyCon c [] (mkTyConInfo c [] [] Nothing)++-- bApp :: (Monoid r) => TyCon -> [BRType r] -> BRType r+bApp :: TyCon -> [BRType r] -> [BRProp r] -> r -> BRType r+bApp c = RApp (tyConBTyCon c)++tyConBTyCon :: TyCon -> BTyCon+tyConBTyCon = mkBTyCon . fmap tyConName . GM.locNamedThing+-- tyConBTyCon = mkBTyCon . fmap symbol . locNamedThing++--- NV TODO : remove this code!!!++addPds :: Foldable t+ => t (PVar (RType c tv ())) -> RType c tv r -> RType c tv r+addPds ps (RAllT v t r) = RAllT v (addPds ps t) r+addPds ps t = foldl' (flip rPred) t ps++nlzP :: (OkRT c tv r) => [PVar (RType c tv ())] -> RType c tv r -> (RType c tv r, [PVar (RType c tv ())])+nlzP ps t@(RVar _ _ )+ = (t, ps)+nlzP ps (RFun b i t1 t2 r)+ = (RFun b i t1' t2' r, ps ++ ps1 ++ ps2)+ where (t1', ps1) = nlzP [] t1+ (t2', ps2) = nlzP [] t2+nlzP ps (RAppTy t1 t2 r)+ = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2)+ where (t1', ps1) = nlzP [] t1+ (t2', ps2) = nlzP [] t2+nlzP ps (RAllT v t r)+ = (RAllT v t' r, ps ++ ps')+ where (t', ps') = nlzP [] t+nlzP ps t@RApp{}+ = (t, ps)+nlzP ps (RAllP p t)+ = (t', [p] ++ ps ++ ps')+ where (t', ps') = nlzP [] t+nlzP ps t@REx{}+ = (t, ps)+nlzP ps t@(RRTy _ _ _ t')+ = (t, ps ++ ps')+ where ps' = snd $ nlzP [] t'+nlzP ps t@RAllE{}+ = (t, ps)+nlzP _ t+ = panic Nothing $ "RefType.nlzP: cannot handle " ++ show t++strengthenRefTypeGen, strengthenRefType ::+ ( OkRT c tv r+ , FreeVar c tv+ , SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) c+ , SubsTy tv (RType c tv ()) r+ , SubsTy tv (RType c tv ()) tv+ , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+ ) => RType c tv r -> RType c tv r -> RType c tv r++strengthenRefType_ ::+ ( OkRT c tv r+ , FreeVar c tv+ , SubsTy tv (RType c tv ()) (RType c tv ())+ , SubsTy tv (RType c tv ()) c+ , SubsTy tv (RType c tv ()) r+ , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+ , SubsTy tv (RType c tv ()) tv+ ) => (RType c tv r -> RType c tv r -> RType c tv r)+ -> RType c tv r -> RType c tv r -> RType c tv r++strengthenRefTypeGen = strengthenRefType_ f+ where+ f (RVar v1 r1) t = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))+ f t (RVar _ r1) = t `strengthen` r1+ f t1 t2 = panic Nothing $ printf "strengthenRefTypeGen on differently shaped types \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"+ (pprRaw t1) (showpp (toRSort t1)) (pprRaw t2) (showpp (toRSort t2))++pprRaw :: (OkRT c tv r) => RType c tv r -> String+pprRaw = render . rtypeDoc Full++{- [NOTE:StrengthenRefType] disabling the `meetable` check because++ (1) It requires the 'TCEmb TyCon' to deal with the fact that sometimes,+ GHC uses the "Family Instance" TyCon e.g. 'R:UniquePerson' and sometimes+ the vanilla TyCon App form, e.g. 'Unique Person'+ (2) We could pass in the TCEmb but that would break the 'Monoid' instance for+ RType. The 'Monoid' instance was was probably a bad idea to begin with,+ and we probably ought to do away with it entirely, but thats a battle I'll+ leave for another day.++ Consequently, its up to users of `strengthenRefType` (and associated functions)+ to make sure that the two types are compatible. For an example, see 'meetVarTypes'.+ -}++strengthenRefType t1 t2+ -- | _meetable t1 t2+ = strengthenRefType_ const t1 t2+ -- | otherwise+ -- = panic Nothing msg+ -- where+ -- msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"+ -- (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))++_meetable :: (OkRT c tv r) => RType c tv r -> RType c tv r -> Bool+_meetable t1 t2 = toRSort t1 == toRSort t2++strengthenRefType_ f (RAllT a1 t1 r1) (RAllT a2 t2 r2)+ = RAllT a1 (strengthenRefType_ f t1 (subsTyVarMeet (ty_var_value a2, toRSort t, t) t2)) (r1 `meet` r2)+ where t = RVar (ty_var_value a1) mempty++strengthenRefType_ f (RAllT a t1 r1) t2+ = RAllT a (strengthenRefType_ f t1 t2) r1++strengthenRefType_ f t1 (RAllT a t2 r2)+ = RAllT a (strengthenRefType_ f t1 t2) r2++strengthenRefType_ f (RAllP p1 t1) (RAllP _ t2)+ = RAllP p1 $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllP p t1) t2+ = RAllP p $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllP p t2)+ = RAllP p $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllE x tx t1) (RAllE y ty t2) | x == y+ = RAllE x (strengthenRefType_ f tx ty) $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllE x tx t1) t2+ = RAllE x tx $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllE x tx t2)+ = RAllE x tx $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAppTy t1 t1' r1) (RAppTy t2 t2' r2)+ = RAppTy t t' (r1 `meet` r2)+ where t = strengthenRefType_ f t1 t2+ t' = strengthenRefType_ f t1' t2'++strengthenRefType_ f (RFun x1 i1 t1 t1' r1) (RFun x2 i2 t2 t2' r2) =+ -- YL: Evidence that we need a Monoid instance for RFInfo?+ if x2 /= F.dummySymbol+ then RFun x2 i1{permitTC = getFirst b} t t1'' (r1 `meet` r2)+ else RFun x1 i1{permitTC = getFirst b} t t2'' (r1 `meet` r2)+ where t = strengthenRefType_ f t1 t2+ t1'' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'+ t2'' = strengthenRefType_ f t1' (subst1 t2' (x2, EVar x1))+ b = First (permitTC i1) <> First (permitTC i2)++strengthenRefType_ f (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)+ = RApp tid ts rs (r1 `meet` r2)+ where ts = zipWith (strengthenRefType_ f) t1s t2s+ rs = meets rs1 rs2++strengthenRefType_ _ (RVar v1 r1) (RVar v2 r2) | v1 == v2+ = RVar v1 (r1 `meet` r2)+strengthenRefType_ f t1 t2+ = f t1 t2++meets :: (F.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++quantifyRTy :: (Monoid r, Eq tv) => [RTVar tv (RType c tv ())] -> RType c tv r -> RType 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 ty = quantifyRTy (freeTyVars ty) ty+++-------------------------------------------------------------------------+addTyConInfo :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))+ => TCEmb TyCon+ -> TyConMap+ -> RRType r+ -> RRType r+-------------------------------------------------------------------------+addTyConInfo tce tyi = mapBot (expandRApp tce tyi)++-------------------------------------------------------------------------+expandRApp :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RRProp r))+ => TCEmb TyCon -> TyConMap -> RRType r -> RRType r+-------------------------------------------------------------------------+expandRApp tce tyi t@RApp{} = RApp rc' ts rs' r+ where+ RApp rc ts rs r = t+ (rc', _) = appRTyCon tce tyi rc as+ pvs = rTyConPVs rc'+ rs' = applyNonNull rs0 (rtPropPV rc pvs) rs+ rs0 = rtPropTop <$> pvs+ n = length fVs+ fVs = GM.tyConTyVarsDef $ rtc_tc rc+ as = choosen n ts (rVar <$> fVs)+expandRApp _ _ t = t++choosen :: Int -> [a] -> [a] -> [a]+choosen 0 _ _ = []+choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys+choosen i [] (y:ys) = y:choosen (i-1) [] ys+choosen _ _ _ = impossible Nothing "choosen: this cannot happen"+++rtPropTop+ :: (OkRT c tv r,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ 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++rtPropPV :: (Fixpoint a, Reftable r)+ => a+ -> [PVar (RType c tv ())]+ -> [Ref (RType c tv ()) (RType c tv r)]+ -> [Ref (RType c tv ()) (RType c tv r)]+rtPropPV _rc = zipWith mkRTProp++mkRTProp :: Reftable r+ => PVar (RType c tv ())+ -> Ref (RType c tv ()) (RType c tv r)+ -> Ref (RType c tv ()) (RType c tv r)+mkRTProp pv (RProp ss (RHole r))+ = RProp ss $ ofRSort (pvType pv) `strengthen` r++mkRTProp pv (RProp ss t)+ | length (pargs pv) == length ss+ = RProp ss t+ | otherwise+ = RProp (pvArgs pv) t++pvArgs :: PVar t -> [(Symbol, t)]+pvArgs pv = [(s, t) | (t, s, _) <- pargs pv]++{- | [NOTE:FamInstPredVars] related to [NOTE:FamInstEmbeds]+ See tests/datacon/pos/T1446.hs+ The function txRefSort converts++ Int<p> ===> {v:Int | p v}++ which is fine, but also converts++ Field<q> Blob a ===> {v:Field Blob a | q v}++ which is NOT ok, because q expects a different arg.++ The above happens because, thanks to instance-family stuff,+ LH doesn't realize that q is actually an ARG of Field Blob+ Note that Field itself has no args, but Field Blob does...++ That is, it is not enough to store the refined `TyCon` info,+ solely in the `RTyCon` as with family instances, you need BOTH+ the `TyCon` and the args to determine the extra info.++ We do so in `TyConMap`, and by crucially extending++ @RefType.appRTyCon@ whose job is to use the Refined @TyCon@+ that is, the @RTyCon@ generated from the @TyConP@ to strengthen+ individual occurrences of the TyCon applied to various arguments.++ -}++appRTyCon :: (ToTypeable r) => TCEmb TyCon -> TyConMap -> RTyCon -> [RRType r] -> (RTyCon, [RPVar])+appRTyCon tce tyi rc ts = F.notracepp _msg (resTc, ps'')+ where+ _msg = "appRTyCon-family: " ++ showpp (Ghc.isFamilyTyCon c, Ghc.tyConRealArity c, toType False <$> ts)+ resTc = RTyCon c ps'' (rtc_info rc'')+ c = rtc_tc rc++ (rc', ps') = rTyConWithPVars tyi rc (rTypeSort tce <$> ts)+ -- TODO:faminst-preds rc' = M.lookupDefault rc c (tcmTyRTy tyi)+ -- TODO:faminst-preds ps' = rTyConPVs rc'++ -- TODO:faminst-preds: these substitutions may be WRONG if we are using FAMINST.+ ps'' = subts (zip (RTV <$> αs) ts') <$> ps'+ where+ ts' = if null ts then rVar <$> βs else toRSort <$> ts+ αs = GM.tyConTyVarsDef (rtc_tc rc')+ βs = GM.tyConTyVarsDef c++ rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc'++rTyConWithPVars :: TyConMap -> RTyCon -> [F.Sort] -> (RTyCon, [RPVar])+rTyConWithPVars tyi rc ts = case famInstTyConMb tyi rc ts of+ Just fiRc -> (rc', rTyConPVs fiRc) -- use the PVars from the family-instance TyCon+ Nothing -> (rc', ps') -- use the PVars from the origin TyCon+ where+ (rc', ps') = plainRTyConPVars tyi rc++-- | @famInstTyConMb rc args@ uses the @RTyCon@ AND @args@ to see if+-- this is a family instance @RTyCon@, and if so, returns it.+-- see [NOTE:FamInstPredVars]+-- eg: 'famInstTyConMb tyi Field [Blob, a]' should give 'Just R:FieldBlob'++famInstTyConMb :: TyConMap -> RTyCon -> [F.Sort] -> Maybe RTyCon+famInstTyConMb tyi rc ts = do+ let c = rtc_tc rc+ n <- M.lookup c (tcmFtcArity tyi)+ M.lookup (c, take n ts) (tcmFIRTy tyi)++famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type+famInstTyConType c = uncurry Ghc.mkTyConApp <$> famInstArgs c++-- | @famInstArgs c@ destructs a family-instance @TyCon@ into its components, e.g.+-- e.g. 'famInstArgs R:FieldBlob' is @(Field, [Blob])@++famInstArgs :: Ghc.TyCon -> Maybe (Ghc.TyCon, [Ghc.Type])+famInstArgs c = case Ghc.tyConFamInst_maybe c of+ Just (c', ts) -> F.notracepp ("famInstArgs: " ++ F.showpp (c, cArity, ts))+ $ Just (c', take (length ts - cArity) ts)+ Nothing -> Nothing+ where+ cArity = Ghc.tyConRealArity c++-- TODO:faminst-preds: case Ghc.tyConFamInst_maybe c of+-- TODO:faminst-preds: Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts))+-- TODO:faminst-preds: $ Just (famInstType (Ghc.tyConArity c) c' ts)+-- TODO:faminst-preds: Nothing -> Nothing++-- TODO:faminst-preds: famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type+-- TODO:faminst-preds: famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)+++++-- | @plainTyConPVars@ uses the @TyCon@ to return the+-- "refined" @RTyCon@ and @RPVars@ from the refined+-- 'data' definition for the @TyCon@, e.g. will use+-- 'List Int' to return 'List<p> Int' (if List has an abs-ref).+plainRTyConPVars :: TyConMap -> RTyCon -> (RTyCon, [RPVar])+plainRTyConPVars tyi rc = (rc', rTyConPVs rc')+ where+ rc' = M.lookupDefault rc (rtc_tc rc) (tcmTyRTy tyi)++++-- RJ: The code of `isNumeric` is incomprehensible.+-- Please fix it to use intSort instead of intFTyCon+isNumeric :: TCEmb TyCon -> RTyCon -> Bool+isNumeric tce c = F.isNumeric mySort+ where+ -- mySort = M.lookupDefault def rc tce+ mySort = maybe def fst (F.tceLookup rc tce)+ def = FTC . symbolFTycon . dummyLoc . tyConName $ rc+ rc = rtc_tc c++addNumSizeFun :: RTyCon -> RTyCon+addNumSizeFun c+ = c {rtc_info = (rtc_info c) {sizeFunction = Just IdSizeFun } }+++generalize :: (Eq tv, Monoid r) => RType c tv r -> RType c tv r+generalize t = mkUnivs (map (, mempty) (freeTyVars t)) [] t++allTyVars :: (Ord tv) => RType c tv r -> [tv]+allTyVars = sortNub . allTyVars'++allTyVars' :: (Eq tv) => RType c tv r -> [tv]+allTyVars' t = fmap ty_var_value $ vs ++ vs'+ where+ vs = map fst . fst3 . bkUniv $ t+ vs' = freeTyVars t+++freeTyVars :: Eq tv => RType c tv r -> [RTVar tv (RType c tv ())]+freeTyVars (RAllP _ t) = freeTyVars t+freeTyVars (RAllT α t _) = freeTyVars t L.\\ [α]+freeTyVars (RFun _ _ t t' _) = freeTyVars t `L.union` freeTyVars t'+freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts+freeTyVars (RVar α _) = [makeRTVar α]+freeTyVars (RAllE _ tx t) = freeTyVars tx `L.union` freeTyVars t+freeTyVars (REx _ tx t) = freeTyVars tx `L.union` freeTyVars t+freeTyVars (RExprArg _) = []+freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t'+freeTyVars (RHole _) = []+freeTyVars (RRTy e _ _ t) = L.nub $ concatMap freeTyVars (t:(snd <$> e))+++tyClasses :: (OkRT RTyCon tv r) => RType RTyCon tv r -> [(Class, [RType RTyCon tv r])]+tyClasses (RAllP _ t) = tyClasses t+tyClasses (RAllT _ t _) = tyClasses t+tyClasses (RAllE _ _ t) = tyClasses t+tyClasses (REx _ _ t) = tyClasses t+tyClasses (RFun _ _ t t' _) = tyClasses t ++ tyClasses t'+tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t'+tyClasses (RApp c ts _ _)+ | Just cl <- tyConClass_maybe $ rtc_tc c+ = [(cl, ts)]+ | otherwise+ = []+tyClasses (RVar _ _) = []+tyClasses (RRTy _ _ _ t) = tyClasses t+tyClasses (RHole _) = []+tyClasses t = panic Nothing ("RefType.tyClasses cannot handle" ++ show t)+++--------------------------------------------------------------------------------+-- TODO: Rewrite subsTyvars with Traversable+--------------------------------------------------------------------------------++subsTyVarsMeet+ :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r+subsTyVarsMeet = subsTyVars True++subsTyVarsNoMeet+ :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r+subsTyVarsNoMeet = subsTyVars False++subsTyVarNoMeet+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r+subsTyVarNoMeet = subsTyVar False++subsTyVarMeet+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r+subsTyVarMeet = subsTyVar True++subsTyVarMeet'+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => (tv, RType c tv r) -> RType c tv r -> RType c tv r+subsTyVarMeet' (α, t) = subsTyVarMeet (α, toRSort t, t)++subsTyVars+ :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => Bool+ -> t (tv, RType c tv (), RType c tv r)+ -> RType c tv r+ -> RType c tv r+subsTyVars meet' ats t = foldl' (flip (subsTyVar meet')) t ats++subsTyVar+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => Bool+ -> (tv, RType c tv (), RType c tv r)+ -> RType c tv r+ -> RType c tv r+subsTyVar meet' = subsFree meet' S.empty++subsFree+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => Bool+ -> S.HashSet tv+ -> (tv, RType c tv (), RType c tv r)+ -> RType c tv r+ -> RType c tv r+subsFree m s z@(α, τ,_) (RAllP π t)+ = RAllP (subt (α, τ) π) (subsFree m s z t)+subsFree m s z@(a, τ, _) (RAllT α t r)+ -- subt inside the type variable instantiates the kind of the variable+ = RAllT (subt (a, τ) α) (subsFree m (ty_var_value α `S.insert` s) z t) (subt (a, τ) r)+subsFree m s z@(α, τ, _) (RFun x i t t' r)+ = RFun x i (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)+subsFree m s z@(α, τ, _) (RApp c ts rs r)+ = RApp c' (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) (subt (α, τ) r)+ where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?+ c' = if α `S.member` s then c else subt z' c+subsFree meet' s (α', τ, t') (RVar α r)+ | α == α' && not (α `S.member` s)+ = if meet' then t' `strengthen` subt (α, τ) r else t'+ | otherwise+ = RVar (subt (α', τ) α) r+subsFree m s z (RAllE x t t')+ = RAllE x (subsFree m s z t) (subsFree m s z t')+subsFree m s z (REx x t t')+ = REx x (subsFree m s z t) (subsFree m s z t')+subsFree m s z@(α, τ, _) (RAppTy t t' r)+ = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)+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)+subsFree _ _ (α, τ, _) (RHole r)+ = RHole (subt (α, τ) r)++subsFrees+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => Bool+ -> S.HashSet tv+ -> [(tv, RType c tv (), RType c tv r)]+ -> RType c tv r+ -> RType c tv r+subsFrees m s zs t = foldl' (flip (subsFree m s)) t zs++-- GHC INVARIANT: RApp is Type Application to something other than TYCon+subsFreeRAppTy+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()),+ FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => Bool+ -> S.HashSet tv+ -> RType c tv r+ -> RType c tv r+ -> r+ -> RType c tv r+subsFreeRAppTy m s (RApp c ts rs r) t' r'+ = mkRApp m s c (ts ++ [t']) rs r r'+subsFreeRAppTy _ _ t t' r'+ = RAppTy t t' r'+++-- | @mkRApp@ is the refined variant of GHC's @mkTyConApp@ which ensures that+-- that applications of the "function" type constructor are normalized to+-- the special case @FunTy _@ representation. The extra `_rep1`, and `_rep2`+-- parameters come from the "levity polymorphism" changes in GHC 8.6 (?)+-- See [NOTE:Levity-Polymorphism]++mkRApp :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => Bool+ -> S.HashSet tv+ -> c+ -> [RType c tv r]+ -> [RTProp c tv r]+ -> r+ -> r+ -> RType c tv r+mkRApp m s c ts rs r r'+ | isFun c, [_rep1, _rep2, t1, t2] <- ts+ = RFun dummySymbol defRFInfo t1 t2 (refAppTyToFun r')+ | otherwise+ = subsFrees m s zs (RApp c ts rs (r `meet` r'))+ where+ zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts]++{-| [NOTE:Levity-Polymorphism]++ Thanks to Joachim Brietner and Simon Peyton-Jones!+ With GHC's "levity polymorphism feature", see more here++ https://stackoverflow.com/questions/35318562/what-is-levity-polymorphism++ The function type constructor actually has type++ (->) :: forall (r1::RuntimeRep) (r2::RuntimeRep). TYPE r1 -> TYPE r2 -> TYPE LiftedRep++ so we have to be careful to follow GHC's @mkTyConApp@++ https://hackage.haskell.org/package/ghc-8.6.4/docs/src/Type.html#mkTyConApp++ which normalizes applications of the `FunTyCon` constructor to use the special+ case `FunTy _` representation thus, so that we are not stuck with incompatible+ representations e.g.++ thing -> thing ... (using RFun)++ and++ (-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing) ... (using RApp)+++ More details from Joachim Brietner:++ Now you might think that the function arrow has the following kind: `(->) :: * -> * -> *`.+ But that is not the full truth: You can have functions that accept or return things with+ different representations than just the usual lifted one.++ So the function arrow actually has kind `(->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> *`.+ And in `(-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing)` you see this spelled+ out explicitly. But it really is just `(thing -> thing)`, just printed with more low-level detail.++ Also see++ • https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#levity-polymorphism+ • and other links from https://stackoverflow.com/a/35320729/946226 (edited)+ -}++refAppTyToFun :: Reftable r => r -> r+refAppTyToFun r+ | isTauto r = r+ | otherwise = panic Nothing "RefType.refAppTyToFun"++subsFreeRef+ :: (Eq tv, Hashable tv, Reftable r, TyConable c,+ SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,+ SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,+ SubsTy tv (RType c tv ()) tv,+ SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))+ => Bool+ -> S.HashSet tv+ -> (tv, RType c tv (), RType c tv r)+ -> RTProp c tv r+ -> RTProp c tv r+subsFreeRef _ _ (α', τ', _) (RProp ss (RHole r))+ = RProp (mapSnd (subt (α', τ')) <$> ss) (RHole r)+subsFreeRef m s (α', τ', t') (RProp ss t)+ = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t+++--------------------------------------------------------------------------------+-- | Type Substitutions --------------------------------------------------------+--------------------------------------------------------------------------------++subts :: (SubsTy tv ty c) => [(tv, ty)] -> c -> c+subts = flip (foldr subt)++instance SubsTy RTyVar (RType RTyCon RTyVar ()) RTyVar where+ subt (RTV x, t) (RTV z) | isTyVar z, tyVarKind z == TyVarTy x+ = RTV (setVarType z $ toType False t)+ subt _ v+ = v++instance SubsTy RTyVar (RType RTyCon RTyVar ()) (RTVar RTyVar (RType RTyCon RTyVar ())) where+ -- NV TODO: update kind+ subt su rty = rty { ty_var_value = subt su $ ty_var_value rty }+++instance SubsTy BTyVar (RType c BTyVar ()) BTyVar where+ subt _ = id++instance SubsTy BTyVar (RType c BTyVar ()) (RTVar BTyVar (RType c BTyVar ())) where+ subt _ = id++instance SubsTy tv ty () where+ subt _ = id++instance SubsTy tv ty Symbol where+ subt _ = id++++instance (SubsTy tv ty Expr) => SubsTy tv ty Reft where+ 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 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+ subt su (RAllE x t1 t2) = RAllE x (subt su t1) (subt su t2)+ subt su (REx x t1 t2) = REx x (subt su t1) (subt su t2)+ subt _ (RExprArg e) = RExprArg e+ subt su (RAppTy t1 t2 r) = RAppTy (subt su t1) (subt su t2) r+ subt su (RRTy e r o t) = RRTy [(x, subt su p) | (x,p) <- e] r o (subt su t)+ subt _ (RHole r) = RHole r++instance SubsTy Symbol Symbol (RTProp BTyCon BTyVar r) where+ subt su (RProp e t) = RProp [(x, subt su xt) | (x,xt) <- e] (subt su t)++++instance (SubsTy tv ty Sort) => SubsTy tv ty Expr where+ subt su (ELam (x, s) e) = ELam (x, subt su s) $ subt su e+ subt su (EApp e1 e2) = EApp (subt su e1) (subt su e2)+ subt su (ENeg e) = ENeg (subt su e)+ subt su (PNot e) = PNot (subt su e)+ subt su (EBin b e1 e2) = EBin b (subt su e1) (subt su e2)+ subt su (EIte e e1 e2) = EIte (subt su e) (subt su e1) (subt su e2)+ subt su (ECst e s) = ECst (subt su e) (subt su s)+ subt su (ETApp e s) = ETApp (subt su e) (subt su s)+ subt su (ETAbs e x) = ETAbs (subt su e) x+ subt su (PAnd es) = PAnd (subt su <$> es)+ subt su (POr es) = POr (subt su <$> es)+ subt su (PImp e1 e2) = PImp (subt su e1) (subt su e2)+ subt su (PIff e1 e2) = PIff (subt su e1) (subt su e2)+ subt su (PAtom b e1 e2) = PAtom b (subt su e1) (subt su e2)+ subt su (PAll xes e) = PAll (subt su <$> xes) (subt su e)+ subt su (PExist xes e) = PExist (subt su <$> xes) (subt su e)+ subt _ e = e++instance (SubsTy tv ty a, SubsTy tv ty b) => SubsTy tv ty (a, b) where+ subt su (x, y) = (subt su x, subt su y)++instance SubsTy BTyVar (RType BTyCon BTyVar ()) Sort where+ subt (v, RVar α _) (FObj s)+ | symbol v == s = FObj $ symbol α+ | otherwise = FObj s+ subt _ s = s+++instance SubsTy Symbol RSort Sort where+ subt (v, RVar α _) (FObj s)+ | symbol v == s = FObj $ symbol {- rTyVarSymbol -} α+ | otherwise = FObj s+ subt _ s = s+++instance SubsTy RTyVar RSort Sort where+ subt (v, sv) (FObj s)+ | symbol v == s = typeSort mempty (toType True sv)+ | 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]++instance SubsTy RTyVar RSort RTyCon where+ subt z c = RTyCon tc ps' i+ where+ tc = rtc_tc c+ 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 τ)++instance SubsTy TyVar Type SpecType where+ subt (α, τ) = subsTyVarMeet (RTV α, ofType τ, ofType τ)++instance SubsTy RTyVar RTyVar SpecType where+ subt (α, a) = subt (α, RVar a () :: RSort)+++instance SubsTy RTyVar RSort RSort where+ subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)++instance SubsTy tv RSort Predicate where+ subt _ = id -- NV TODO++instance (SubsTy tv ty r) => SubsTy tv ty (UReft r) where+ subt su r = r {ur_reft = subt su $ ur_reft r}++-- Here the "String" is a Bare-TyCon. TODO: wrap in newtype+instance SubsTy BTyVar BSort BTyCon where+ subt _ t = t++instance SubsTy BTyVar BSort BSort where+ 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++subvUReft :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft+subvUReft f (MkUReft r p) = MkUReft r (subvPredicate f p)++subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate+subvPredicate f (Pr pvs) = Pr (f <$> pvs)++--------------------------------------------------------------------------------+ofType :: Monoid r => Type -> RRType r+--------------------------------------------------------------------------------+ofType = ofType_ $ TyConv+ { tcFVar = rVar+ , tcFTVar = rTVar+ , tcFApp = \c ts -> rApp c ts [] mempty+ , tcFLit = ofLitType rApp+ }++--------------------------------------------------------------------------------+bareOfType :: Monoid r => Type -> BRType r+--------------------------------------------------------------------------------+bareOfType = ofType_ $ TyConv+ { tcFVar = (`RVar` mempty) . BTV . symbol+ , tcFTVar = bTVar+ , tcFApp = \c ts -> bApp c ts [] mempty+ , tcFLit = ofLitType bApp+ }++--------------------------------------------------------------------------------+ofType_ :: Monoid r => TyConv c tv r -> Type -> RType c tv r+--------------------------------------------------------------------------------+ofType_ tx = go . expandTypeSynonyms+ where+ go (TyVarTy α)+ = tcFVar tx α+ go (FunTy _ _ τ τ')+ = rFun dummySymbol (go τ) (go τ')+ go (ForAllTy (Bndr α _) τ)+ = RAllT (tcFTVar tx α) (go τ) mempty+ go (TyConApp c τs)+ | Just (αs, τ) <- Ghc.synTyConDefn_maybe c+ = go (substTyWith αs τs τ)+ | otherwise+ = tcFApp tx c (go <$> τs) -- [] mempty+ go (AppTy t1 t2)+ = RAppTy (go t1) (ofType_ tx t2) mempty+ go (LitTy x)+ = tcFLit tx x+ go (CastTy t _)+ = go t+ go (CoercionTy _)+ = errorstar "Coercion is currently not supported"++ofLitType :: (Monoid r) => (TyCon -> [RType c tv r] -> [p] -> r -> RType c tv r) -> TyLit -> RType c tv r+ofLitType rF (NumTyLit _) = rF intTyCon [] [] mempty+ofLitType rF t@(StrTyLit _)+ | t == holeLit = RHole mempty+ | otherwise = rF listTyCon [rF charTyCon [] [] mempty] [] mempty++holeLit :: TyLit+holeLit = StrTyLit "$LH_RHOLE"++data TyConv c tv r = TyConv+ { tcFVar :: TyVar -> RType c tv r+ , tcFTVar :: TyVar -> RTVar tv (RType c tv ())+ , tcFApp :: TyCon -> [RType c tv r] -> RType c tv r+ , tcFLit :: TyLit -> RType c tv r+ }++--------------------------------------------------------------------------------+-- | Converting to Fixpoint ----------------------------------------------------+--------------------------------------------------------------------------------+++instance Expression Var where+ expr = eVar++-- TODO: turn this into a map lookup?+dataConReft :: DataCon -> [Symbol] -> Reft+dataConReft c []+ | c == trueDataCon+ = predReft $ eProp vv_+ | c == falseDataCon+ = predReft $ PNot $ eProp vv_++dataConReft c [x]+ | c == intDataCon+ = symbolReft x -- OLD (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))])+dataConReft c _+ | not $ isBaseDataCon c+ = mempty+dataConReft c xs+ = exprReft dcValue -- OLD Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])+ where+ dcValue+ | null xs && null (dataConUnivTyVars c)+ = EVar $ symbol c+ | otherwise+ = mkEApp (dummyLoc $ symbol c) (eVar <$> xs)++isBaseDataCon :: DataCon -> Bool+isBaseDataCon c = and $ isBaseTy <$> map irrelevantMult (dataConOrigArgTys c ++ dataConRepArgTys c)++isBaseTy :: Type -> Bool+isBaseTy (TyVarTy _) = True+isBaseTy (AppTy _ _) = False+isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts+isBaseTy FunTy{} = False+isBaseTy (ForAllTy _ _) = False+isBaseTy (LitTy _) = True+isBaseTy (CastTy _ _) = False+isBaseTy (CoercionTy _) = False+++dataConMsReft :: Reftable r => RType c tv r -> [Symbol] -> Reft+dataConMsReft ty ys = subst su (rTypeReft (ignoreOblig $ ty_res trep))+ where+ trep = toRTypeRep ty+ xs = ty_binds trep+ ts = ty_args trep+ su = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys]++--------------------------------------------------------------------------------+-- | Embedding RefTypes --------------------------------------------------------+--------------------------------------------------------------------------------++type ToTypeable r = (Reftable r, PPrint r, SubsTy RTyVar (RRType ()) r, Reftable (RTProp RTyCon RTyVar r))++-- TODO: remove toType, generalize typeSort+-- YL: really should take a type-level Bool+toType :: (ToTypeable r) => Bool -> RRType r -> Type+toType useRFInfo (RFun _ RFInfo{permitTC = permitTC} t@(RApp c _ _ _) t' _)+ | useRFInfo && isErasable c = toType useRFInfo t'+ | otherwise+ = FunTy VisArg Many (toType useRFInfo t) (toType useRFInfo t')+ where isErasable = if permitTC == Just True then isEmbeddedDict else isClass+toType useRFInfo (RFun _ _ t t' _)+ = FunTy VisArg Many (toType useRFInfo t) (toType useRFInfo t')+toType useRFInfo (RAllT a t _) | RTV α <- ty_var_value a+ = ForAllTy (Bndr α Required) (toType useRFInfo t)+toType useRFInfo (RAllP _ t)+ = toType useRFInfo t+toType _ (RVar (RTV α) _)+ = TyVarTy α+toType useRFInfo (RApp RTyCon{rtc_tc = c} ts _ _)+ = TyConApp c (toType useRFInfo <$> filter notExprArg ts)+ where+ notExprArg (RExprArg _) = False+ notExprArg _ = True+toType useRFInfo (RAllE _ _ t)+ = toType useRFInfo t+toType useRFInfo (REx _ _ t)+ = toType useRFInfo t+toType useRFInfo (RAppTy t (RExprArg _) _)+ = toType useRFInfo t+toType useRFInfo (RAppTy t t' _)+ = AppTy (toType useRFInfo t) (toType useRFInfo t')+toType _ t@(RExprArg _)+ = impossible Nothing $ "CANNOT HAPPEN: RefType.toType called with: " ++ show t+toType useRFInfo (RRTy _ _ _ t)+ = toType useRFInfo t+toType _ (RHole _)+ = LitTy holeLit+-- toType t+-- = {- impossible Nothing -} Prelude.error $ "RefType.toType cannot handle: " ++ show t++{- | [NOTE:Hole-Lit]++We use `toType` to convert RType to GHC.Type to expand any GHC+related type-aliases, e.g. in Bare.Resolve.expandRTypeSynonyms.+If the RType has a RHole then what to do?++We, encode `RHole` as `LitTy "LH_HOLE"` -- which is a bit of+a *hack*. The only saving grace is it is used *temporarily*+and then swiftly turned back into an `RHole` via `ofType`+(after GHC has done its business of expansion).++Of course, we hope this doesn't break any GHC invariants!+See issue #1476 and #1477++The other option is to *not* use `toType` on things that have+holes in them, but this seems worse, e.g. because you may define+a plain GHC alias like:++ type ToNat a = a -> Nat++and then you might write refinement types like:++ {-@ foo :: ToNat {v:_ | 0 <= v} @-}++and we'd want to expand the above to++ {-@ foo :: {v:_ | 0 <= v} -> Nat @-}++and then resolve the hole using the (GHC) type of `foo`.++-}++--------------------------------------------------------------------------------+-- | Annotations and Solutions -------------------------------------------------+--------------------------------------------------------------------------------++rTypeSortedReft :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))+ => TCEmb TyCon -> RRType r -> SortedReft+rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t)++rTypeSort :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))+ => TCEmb TyCon -> RRType r -> Sort+rTypeSort tce = typeSort tce . toType True++--------------------------------------------------------------------------------+applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType+--------------------------------------------------------------------------------+applySolution = fmap . fmap . mapReft' . appSolRefa+ where+ mapReft' f (MkUReft (Reft (x, z)) p) = MkUReft (Reft (x, f z)) p++appSolRefa :: Visitable t+ => M.HashMap KVar Expr -> t -> t+appSolRefa s p = mapKVars f p+ where+ f k = Just $ M.lookupDefault PTop k s++--------------------------------------------------------------------------------+-- shiftVV :: Int -- SpecType -> Symbol -> SpecType+shiftVV :: (TyConable c, F.Reftable (f Reft), Functor f)+ => RType c tv (f Reft) -> Symbol -> RType c tv (f Reft)+--------------------------------------------------------------------------------+shiftVV t@(RApp _ ts rs r) vv'+ = t { rt_args = subst1 ts (rTypeValueVar t, EVar vv') }+ { rt_pargs = subst1 rs (rTypeValueVar t, EVar vv') }+ { rt_reft = (`F.shiftVV` vv') <$> r }++shiftVV t@(RFun _ _ _ _ r) vv'+ = t { rt_reft = (`F.shiftVV` vv') <$> r }++shiftVV t@(RAppTy _ _ r) vv'+ = t { rt_reft = (`F.shiftVV` vv') <$> r }++shiftVV t@(RVar _ r) vv'+ = t { rt_reft = (`F.shiftVV` vv') <$> r }++shiftVV t _+ = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t+++--------------------------------------------------------------------------------+-- |Auxiliary Stuff Used Elsewhere ---------------------------------------------+--------------------------------------------------------------------------------++-- MOVE TO TYPES+instance (Show tv, Show ty) => Show (RTAlias tv ty) where+ show (RTA n as xs t) =+ printf "type %s %s %s = %s" (symbolString n)+ (unwords (show <$> as))+ (unwords (show <$> xs))+ (show t)++--------------------------------------------------------------------------------+-- | From Old Fixpoint ---------------------------------------------------------+--------------------------------------------------------------------------------+typeSort :: TCEmb TyCon -> Type -> Sort+typeSort tce = go+ where+ go :: Type -> Sort+ go t@FunTy{} = typeSortFun tce t+ go τ@(ForAllTy _ _) = typeSortForAll tce τ+ -- go (TyConApp c τs) = fApp (tyConFTyCon tce c) (go <$> τs)+ go (TyConApp c τs)+ | isNewTyCon c+ , not (isRecursivenewTyCon c)+ = go (Ghc.newTyConInstRhs c τs)+ | otherwise+ = tyConFTyCon tce c (go <$> τs)+ go (AppTy t1 t2) = fApp (go t1) [go t2]+ go (TyVarTy tv) = tyVarSort tv+ go (CastTy t _) = go t+ go τ = FObj (typeUniqueSymbol τ)++tyConFTyCon :: TCEmb TyCon -> TyCon -> [Sort] -> Sort+tyConFTyCon tce c ts = case tceLookup c tce of+ Just (t, WithArgs) -> t+ Just (t, NoArgs) -> fApp t ts+ Nothing -> fApp (fTyconSort niTc) ts+ where+ niTc = symbolNumInfoFTyCon (dummyLoc $ tyConName c) (isNumCls c) (isFracCls c)+ -- oldRes = F.notracepp _msg $ M.lookupDefault def c tce+ -- _msg = "tyConFTyCon c = " ++ show c ++ "default " ++ show (def, Ghc.isFamInstTyCon c)++tyVarSort :: TyVar -> Sort+tyVarSort = FObj . symbol++typeUniqueSymbol :: Type -> Symbol+typeUniqueSymbol = symbol . GM.typeUniqueString++typeSortForAll :: TCEmb TyCon -> Type -> Sort+typeSortForAll tce τ = F.notracepp ("typeSortForall " ++ showpp τ) $ genSort sbody+ where+ sbody = typeSort tce tbody+ genSort t = foldl' (flip FAbs) (sortSubst su t) [i..n+i-1]+ (as, tbody) = F.notracepp ("splitForallTys" ++ GM.showPpr τ) (splitForAllTyCoVars τ)+ su = M.fromList $ zip sas (FVar <$> [i..])+ sas = symbol <$> as+ n = length as+ i = sortAbs sbody + 1++-- RJ: why not make this the Symbolic instance?+tyConName :: TyCon -> Symbol+tyConName c+ | listTyCon == c = listConName+ | Ghc.isTupleTyCon c = tupConName+ | otherwise = symbol c++typeSortFun :: TCEmb TyCon -> Type -> Sort+typeSortFun tce t = mkFFunc 0 sos+ where+ sos = typeSort tce <$> τs+ τs = grabArgs [] t++grabArgs :: [Type] -> Type -> [Type]+grabArgs τs (FunTy _ _ τ1 τ2)+ | Just a <- stringClassArg τ1+ = grabArgs τs (mapType (\t -> if t == a then stringTy else t) τ2)+ -- not ( F.notracepp ("isNonArg: " ++ GM.showPpr τ1) $ isNonValueTy τ1)+ | otherwise+ = grabArgs (τ1:τs) τ2+ -- otherwise+ -- = grabArgs τs τ2+ -- -- | otherwise+ -- -- = grabArgs τs τ2+grabArgs τs τ+ = reverse (τ:τs)+++expandProductType :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))+ => Var -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r+expandProductType x t+ | isTrivial' = t+ | otherwise = fromRTypeRep $ trep {ty_binds = xs', ty_info=is', ty_args = ts', ty_refts = rs'}+ where+ isTrivial' = ofType (varType x) == toRSort t+ τs = map irrelevantMult $ fst $ splitFunTys $ snd $ splitForAllTyCoVars $ toType False t+ trep = toRTypeRep t+ (xs',is',ts',rs') = unzip4 $ concatMap mkProductTy $ zip5 τs (ty_binds trep) (ty_info trep) (ty_args trep) (ty_refts trep)++-- splitFunTys :: Type -> ([Type], Type)++data DataConAppContext+ = DataConAppContext+ { dcac_dc :: !DataCon+ , dcac_tys :: ![Type]+ , dcac_arg_tys :: ![(Type, StrictnessMark)]+ , dcac_co :: !Coercion+ }++mkProductTy :: forall t r. (Monoid t, Monoid r)+ => (Type, Symbol, RFInfo, RType RTyCon RTyVar r, t)+ -> [(Symbol, RFInfo, RType RTyCon RTyVar r, t)]+mkProductTy (τ, x, i, t, r) = maybe [(x, i, t, r)] f (deepSplitProductType menv τ)+ where+ f :: DataConAppContext -> [(Symbol, RFInfo, RType RTyCon RTyVar r, t)]+ f DataConAppContext{..} = map ((dummySymbol, defRFInfo, , mempty) . ofType . fst) dcac_arg_tys+ menv = (emptyFamInstEnv, emptyFamInstEnv)++-- Copied from GHC 9.0.2.+orElse :: Maybe a -> a -> a+orElse = flip fromMaybe++-- Copied from GHC 9.0.2.+deepSplitProductType :: FamInstEnvs -> Type -> Maybe DataConAppContext+-- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)+-- then dc @ tys (args::arg_tys) :: rep_ty+-- co :: ty ~ rep_ty+-- Why do we return the strictness of the data-con arguments?+-- Answer: see Note [Record evaluated-ness in worker/wrapper]+deepSplitProductType fam_envs ty+ | let (co, ty1) = topNormaliseType_maybe fam_envs ty+ `orElse` (mkRepReflCo ty, ty)+ , Just (tc, tc_args) <- splitTyConApp_maybe ty1+ , Just con <- tyConSingleDataCon_maybe tc+ , let arg_tys = dataConInstArgTys con tc_args+ strict_marks = dataConRepStrictness con+ = Just DataConAppContext { dcac_dc = con+ , dcac_tys = tc_args+ , dcac_arg_tys = zip (map irrelevantMult arg_tys) strict_marks+ , dcac_co = co }++deepSplitProductType _ _ = Nothing+++-----------------------------------------------------------------------------------------+-- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum)+-----------------------------------------------------------------------------------------+classBinds :: TCEmb TyCon -> SpecType -> [(Symbol, SortedReft)]+classBinds _ (RApp c ts _ _)+ | isFracCls c+ = [(symbol a, trueSortedReft FFrac) | (RVar a _) <- ts]+ | isNumCls c+ = [(symbol a, trueSortedReft FNum) | (RVar a _) <- ts]+classBinds emb (RApp c [_, _, RVar a _, t] _ _)+ | isEqual c+ = [(symbol a, rTypeSortedReft emb t)]+classBinds emb ty@(RApp c [_, RVar a _, t] _ _)+ | isEqualityConstr ty+ = [(symbol a, rTypeSortedReft emb t)]+ | otherwise+ = notracepp ("CLASSBINDS-0: " ++ showpp c) []+classBinds _ t+ = notracepp ("CLASSBINDS-1: " ++ showpp (toType False t, isEqualityConstr t)) []++isEqualityConstr :: SpecType -> Bool+isEqualityConstr (toType False -> ty) = Ghc.isEqPred ty || Ghc.isEqPrimPred ty++--------------------------------------------------------------------------------+-- | Termination Predicates ----------------------------------------------------+--------------------------------------------------------------------------------++makeNumEnv :: (Foldable t, TyConable c) => t (RType c b t1) -> [b]+makeNumEnv = concatMap go+ where+ go (RApp c ts _ _) | isNumCls c || isFracCls c = [ a | (RVar a _) <- ts]+ go _ = []++isDecreasing :: S.HashSet TyCon -> [RTyVar] -> SpecType -> Bool+isDecreasing autoenv _ (RApp c _ _ _)+ = isJust (sizeFunction (rtc_info c)) -- user specified size or+ || isSizeable autoenv tc+ where tc = rtc_tc c+isDecreasing _ cenv (RVar v _)+ = v `elem` cenv+isDecreasing _ _ _+ = False++makeDecrType :: Symbolic a+ => S.HashSet TyCon+ -> Maybe (a, (Symbol, RType RTyCon t (UReft Reft)))+ -> Either (Symbol, RType RTyCon t (UReft Reft)) String+makeDecrType autoenv (Just (v, (x, t)))+ = Left (x, t `strengthen` tr)+ where+ tr = uTop $ Reft (vv', pOr [r])+ r = cmpLexRef (v', vv', f)+ v' = symbol v+ f = mkDecrFun autoenv t+ vv' = "vvRec"++makeDecrType _ _+ = Right "RefType.makeDecrType called on invalid input"++isSizeable :: S.HashSet TyCon -> TyCon -> Bool+isSizeable autoenv tc = S.member tc autoenv -- Ghc.isAlgTyCon tc -- && Ghc.isRecursiveTyCon tc++mkDecrFun :: S.HashSet TyCon -> RType RTyCon t t1 -> Symbol -> Expr+mkDecrFun autoenv (RApp c _ _ _)+ | Just f <- szFun <$> sizeFunction (rtc_info c)+ = f+ | isSizeable autoenv $ rtc_tc c+ = \v -> F.mkEApp lenLocSymbol [F.EVar v]+mkDecrFun _ (RVar _ _)+ = EVar+mkDecrFun _ _+ = panic Nothing "RefType.mkDecrFun called on invalid input"++-- | [NOTE]: THIS IS WHERE THE TERMINATION METRIC REFINEMENTS ARE CREATED.+cmpLexRef :: (t, t, t -> Expr) -> Expr+cmpLexRef (v, x, g)+ = pAnd [PAtom Lt (g x) (g v), PAtom Ge (g x) zero]+ where zero = ECon $ I 0++makeLexRefa :: [Located Expr] -> [Located Expr] -> UReft Reft+makeLexRefa es' es = uTop $ Reft (vv', PIff (EVar vv') $ pOr rs)+ where+ rs = makeLexReft [] [] (val <$> es) (val <$> es')+ vv' = "vvRec"++makeLexReft :: [(Expr, Expr)] -> [Expr] -> [Expr] -> [Expr] -> [Expr]+makeLexReft _ acc [] []+ = acc+makeLexReft old acc (e:es) (e':es')+ = makeLexReft ((e,e'):old) (r:acc) es es'+ where+ r = pAnd $ PAtom Lt e' e+ : PAtom Ge e' zero+ : [PAtom Eq o' o | (o,o') <- old]+ ++ [PAtom Ge o' zero | (_,o') <- old]+ zero = ECon $ I 0+makeLexReft _ _ _ _+ = panic Nothing "RefType.makeLexReft on invalid input"++--------------------------------------------------------------------------------+mkTyConInfo :: TyCon -> VarianceInfo -> VarianceInfo -> Maybe SizeFun -> TyConInfo+mkTyConInfo c userTv userPv f = TyConInfo tcTv userPv f+ 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+++-------------------------------------------------------------------------------+-- | tyVarsPosition t returns the type variables appearing+-- | (in positive positions, in negative positions, in undetermined positions)+-- | undetermined positions are due to type constructors and type application+-------------------------------------------------------------------------------+tyVarsPosition :: RType RTyCon tv r -> Positions tv+tyVarsPosition = go (Just True)+ where+ go p (RVar t _) = report p t+ go p (RFun _ _ t1 t2 _) = go (flip' p) t1 <> go p t2+ go p (RAllT _ t _) = go p t+ go p (RAllP _ t) = go p t+ go p (RApp c ts _ _) = mconcat (zipWith go (getPosition p <$> varianceTyArgs (rtc_info c)) ts)+ go p (RAllE _ t1 t2) = go p t1 <> go p t2+ go p (REx _ t1 t2) = go p t1 <> go p t2+ go _ (RExprArg _) = mempty+ go p (RAppTy t1 t2 _) = go p t1 <> go p t2+ go p (RRTy _ _ _ t) = go p t+ go _ (RHole _) = mempty++ getPosition :: Maybe Bool -> Variance -> Maybe Bool+ getPosition b Contravariant = not <$> b+ getPosition b _ = b++ report (Just True) v = Pos [v] [] []+ report (Just False) v = Pos [] [v] []+ report Nothing v = Pos [] [] [v]+ flip' = fmap not++data Positions a = Pos {ppos :: [a], pneg :: [a], punknown :: [a]}++instance Monoid (Positions a) where+ mempty = Pos [] [] []+instance Semigroup (Positions a) where+ (Pos x1 x2 x3) <> (Pos y1 y2 y3) = Pos (x1 ++ y1) (x2 ++ y2) (x3 ++ y3)
+ src/Language/Haskell/Liquid/Types/Specs.hs view
@@ -0,0 +1,873 @@+{-# LANGUAGE DeriveAnyClass #-}+-- | This module contains the top-level structures that hold+-- information about specifications.++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Haskell.Liquid.Types.Specs (+ -- * Different types of specifications+ -- $differentSpecTypes+ -- * TargetInfo+ -- $targetInfo+ TargetInfo(..)+ -- * Gathering information about a module+ , TargetSrc(..)+ -- * TargetSpec+ -- $targetSpec+ , TargetSpec(..)+ -- * BareSpec+ -- $bareSpec+ , BareSpec(..)+ -- * LiftedSpec+ -- $liftedSpec+ , LiftedSpec(..)+ -- * Tracking dependencies+ -- $trackingDeps+ , TargetDependencies(..)+ , dropDependency+ -- * Predicates on spec types+ -- $predicates+ , isPLEVar+ , isExportedVar+ -- * Other types+ , QImports(..)+ , Spec(..)+ , GhcSpecVars(..)+ , GhcSpecSig(..)+ , GhcSpecNames(..)+ , GhcSpecTerm(..)+ , GhcSpecRefl(..)+ , GhcSpecLaws(..)+ , GhcSpecData(..)+ , GhcSpecQual(..)+ , BareDef+ , BareMeasure+ , SpecMeasure+ , VarOrLocSymbol+ , LawInstance(..)+ -- * Legacy data structures+ -- $legacyDataStructures+ , GhcSrc(..)+ , GhcSpec(..)+ -- * Provisional compatibility exports & optics+ -- $provisionalBackCompat+ , toTargetSrc+ , fromTargetSrc+ , toTargetSpec+ , toBareSpec+ , fromBareSpec+ , toLiftedSpec+ , unsafeFromLiftedSpec+ , emptyLiftedSpec+ ) where++import GHC.Generics hiding (to, moduleName)+import Data.Binary+import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Misc (sortNub)+import Data.Hashable+import qualified Data.HashSet as S+import Data.HashSet (HashSet)+import qualified Data.HashMap.Strict as M+import Data.HashMap.Strict (HashMap)+import Language.Haskell.Liquid.Types.Types+import Language.Haskell.Liquid.Types.Generics+import Language.Haskell.Liquid.Types.Variance+import Language.Haskell.Liquid.Types.Bounds+import Liquid.GHC.API hiding (text, (<+>))+import Language.Haskell.Liquid.GHC.Types+import Text.PrettyPrint.HughesPJ (text, (<+>))+import Text.PrettyPrint.HughesPJ as HughesPJ (($$))+++{- $differentSpecTypes++There are different types or \"flavours\" for a specification, depending on its lifecycle. The main goal+is always the same, i.e. refining the Haskell types and produce a final statement (i.e. safe or unsafe)+about the input program. In order to do so, a /specification/ is transformed in the way described by this+picture:++@+ +---------------+ +-------------------++ | BareSpec | | | checked by liquid/liquidOne+ | | ------------| TargetSpec |----------------------------- ..+ |(input module) | / | |+ +---------------+ makeTargetSpec / +-------------------++ + -----------------/+ +---------------+ \\ +-------------------++ | {LiftedSpec} | \\ | | serialised on disk+ | | -------------| LiftedSpec |----------------------------- ..+ |(dependencies) | | |+ +---------------+ +-------------------++ ^ |+ | used-as |+ +----------------------------------------------------++@++More specifically, we distinguish:++* 'BareSpec' - is the specification obtained by parsing the Liquid annotations of the input Haskell file.+ It typically contains information about the associated input Haskell module, with the exceptions of+ /assumptions/ that can refer to functions defined in other modules.++* 'LiftedSpec' - is the specification we obtain by \"lifting\" the 'BareSpec'. Most importantly, a+ 'LiftedSpec' gets serialised on disk and becomes a /dependency/ for the verification of other 'BareSpec's.++ Lifting in this context consist of:++ 1. Perform name-resolution (e.g. make all the relevant GHC's 'Var's qualified, resolve GHC's 'Name's, etc);+ 2. Strip the final 'LiftedSpec' with information which are relevant (read: local) to just the input+ 'BareSpec'. An example would be /local signatures/, used to annotate internal, auxiliary functions+ within a 'Module';+ 3. Strip termination checks, which are /required/ (if specified) for a 'BareSpec' but not for the+ 'LiftedSpec'.++* 'TargetSpec' - is the specification we /actually use for refinement/, and is conceptually an+ \"augmented\" 'BareSpec'. You can create a 'TargetSpec' by calling 'makeTargetSpec'.++In order to produce these spec types we have to gather information about the module being compiled by using+the GHC API and retain enough context of the compiled 'Module' in order to be able to construct the types+introduced aboves. The rest of this module introduced also these intermediate structures.+-}++-- $targetInfo+-- The following is the overall type for /specifications/ obtained from+-- parsing the target source and dependent libraries.+-- /IMPORTANT/: A 'TargetInfo' is what is /checked/ by LH itself and it /NEVER/ contains the 'LiftedSpec',+-- because the checking happens only on the 'BareSpec' of the target module.+data TargetInfo = TargetInfo+ { giSrc :: !TargetSrc+ -- ^ The 'TargetSrc' of the module being checked.+ , giSpec :: !TargetSpec+ -- ^ The 'TargetSpec' of the module being checked.+ }++instance HasConfig TargetInfo where+ getConfig = getConfig . giSpec++-- | The 'TargetSrc' type is a collection of all the things we know about a module being currently+-- checked. It include things like the name of the module, the list of 'CoreBind's,+-- the 'TyCon's declared in this module (that includes 'TyCon's for classes), typeclass instances+-- and so and so forth. It might be consider a sort of 'ModGuts' embellished with LH-specific+-- information (for example, 'giDefVars' are populated with datacons from the module plus the+-- let vars derived from the A-normalisation).+data TargetSrc = TargetSrc+ { giTarget :: !FilePath -- ^ Source file for module+ , giTargetMod :: !ModName -- ^ Name for module+ , giCbs :: ![CoreBind] -- ^ Source Code+ , gsTcs :: ![TyCon] -- ^ All used Type constructors+ , gsCls :: !(Maybe [ClsInst]) -- ^ Class instances?+ , giDerVars :: !(HashSet Var) -- ^ Binders created by GHC eg dictionaries+ , giImpVars :: ![Var] -- ^ Binders that are _read_ in module (but not defined?)+ , giDefVars :: ![Var] -- ^ (Top-level) binders that are _defined_ in module+ , giUseVars :: ![Var] -- ^ Binders that are _read_ in module+ , gsExports :: !(HashSet StableName) -- ^ `Name`s exported by the module being verified+ , 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.+data QImports = QImports+ { qiModules :: !(S.HashSet F.Symbol) -- ^ All the modules that are imported qualified+ , qiNames :: !(M.HashMap F.Symbol [F.Symbol]) -- ^ Map from qualification to full module name+ } deriving Show++-- $targetSpec++-- | A 'TargetSpec' is what we /actually check via LiquidHaskell/. It is created as part of 'mkTargetSpec'+-- alongside the 'LiftedSpec'. It shares a similar structure with a 'BareSpec', but manipulates and+-- transforms the data in preparation to the checking process.+data TargetSpec = TargetSpec+ { gsSig :: !GhcSpecSig+ , gsQual :: !GhcSpecQual+ , gsData :: !GhcSpecData+ , gsName :: !GhcSpecNames+ , gsVars :: !GhcSpecVars+ , gsTerm :: !GhcSpecTerm+ , gsRefl :: !GhcSpecRefl+ , gsLaws :: !GhcSpecLaws+ , gsImps :: ![(F.Symbol, F.Sort)] -- ^ Imported Environment+ , gsConfig :: !Config+ }++instance HasConfig TargetSpec where+ getConfig = gsConfig++-- | The collection of GHC 'Var's that a 'TargetSpec' needs to verify (or skip).+data GhcSpecVars = SpVar+ { gsTgtVars :: ![Var] -- ^ Top-level Binders To Verify (empty means ALL binders)+ , gsIgnoreVars :: !(S.HashSet Var) -- ^ Top-level Binders To NOT Verify (empty means ALL binders)+ , gsLvars :: !(S.HashSet Var) -- ^ Variables that should be checked "lazily" in the environment they are used+ , gsCMethods :: ![Var] -- ^ Refined Class methods+ }++instance Semigroup GhcSpecVars where+ sv1 <> sv2 = SpVar+ { gsTgtVars = gsTgtVars sv1 <> gsTgtVars sv2+ , gsIgnoreVars = gsIgnoreVars sv1 <> gsIgnoreVars sv2+ , gsLvars = gsLvars sv1 <> gsLvars sv2+ , gsCMethods = gsCMethods sv1 <> gsCMethods sv2+ }++instance Monoid GhcSpecVars where+ mempty = SpVar mempty mempty mempty mempty++data GhcSpecQual = SpQual+ { gsQualifiers :: ![F.Qualifier] -- ^ Qualifiers in Source/Spec files e.g tests/pos/qualTest.hs+ , gsRTAliases :: ![F.Located SpecRTAlias] -- ^ Refinement type aliases (only used for qualifiers)+ }++data GhcSpecSig = SpSig+ { gsTySigs :: ![(Var, LocSpecType)] -- ^ Asserted Reftypes+ , gsAsmSigs :: ![(Var, LocSpecType)] -- ^ Assumed Reftypes+ , gsRefSigs :: ![(Var, LocSpecType)] -- ^ Reflected Reftypes+ , gsInSigs :: ![(Var, LocSpecType)] -- ^ Auto generated Signatures+ , gsNewTypes :: ![(TyCon, LocSpecType)] -- ^ Mapping of 'newtype' type constructors with their refined types.+ , gsDicts :: !(DEnv Var LocSpecType) -- ^ Refined Classes from Instances+ , gsMethods :: ![(Var, MethodType LocSpecType)] -- ^ Refined Classes from Classes+ , gsTexprs :: ![(Var, LocSpecType, [F.Located F.Expr])] -- ^ Lexicographically ordered expressions for termination+ , gsRelation :: ![(Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]+ , gsAsmRel :: ![(Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]+ }++instance Semigroup GhcSpecSig where+ x <> y = SpSig+ { gsTySigs = gsTySigs x <> gsTySigs y+ , gsAsmSigs = gsAsmSigs x <> gsAsmSigs y+ , gsRefSigs = gsRefSigs x <> gsRefSigs y+ , gsInSigs = gsInSigs x <> gsInSigs y+ , gsNewTypes = gsNewTypes x <> gsNewTypes y+ , gsDicts = gsDicts x <> gsDicts y+ , gsMethods = gsMethods x <> gsMethods y+ , gsTexprs = gsTexprs x <> gsTexprs y+ , gsRelation = gsRelation x <> gsRelation y+ , gsAsmRel = gsAsmRel x <> gsAsmRel y+ }++++++++instance Monoid GhcSpecSig where+ mempty = SpSig mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty++data GhcSpecData = SpData+ { gsCtors :: ![(Var, LocSpecType)] -- ^ Data Constructor Measure Sigs+ , gsMeas :: ![(F.Symbol, LocSpecType)] -- ^ Measure Types eg. len :: [a] -> Int+ , 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+ , gsUnsorted :: ![UnSortedExpr]+ }+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+ , 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+ , gsADTs :: ![F.DataDecl] -- ^ ADTs extracted from Haskell 'data' definitions+ , gsTyconEnv :: !TyConMap+ }++data GhcSpecTerm = SpTerm+ { gsStTerm :: !(S.HashSet Var) -- ^ Binders to CHECK by structural termination+ , gsAutosize :: !(S.HashSet TyCon) -- ^ Binders to IGNORE during termination checking+ , gsLazy :: !(S.HashSet Var) -- ^ Binders to IGNORE during termination checking+ , gsFail :: !(S.HashSet (F.Located Var)) -- ^ Binders to fail type checking+ , gsNonStTerm :: !(S.HashSet Var) -- ^ Binders to CHECK using REFINEMENT-TYPES/termination metrics+ }++instance Semigroup GhcSpecTerm where+ t1 <> t2 = SpTerm+ { gsStTerm = gsStTerm t1 <> gsStTerm t2+ , gsAutosize = gsAutosize t1 <> gsAutosize t2+ , gsLazy = gsLazy t1 <> gsLazy t2+ , gsFail = gsFail t1 <> gsFail t2+ , gsNonStTerm = gsNonStTerm t1 <> gsNonStTerm t2+ }++instance Monoid GhcSpecTerm where+ mempty = SpTerm mempty mempty mempty mempty mempty+data GhcSpecRefl = SpRefl+ { gsAutoInst :: !(M.HashMap Var (Maybe Int)) -- ^ 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]+ }++instance Semigroup GhcSpecRefl where+ x <> y = SpRefl+ { gsAutoInst = gsAutoInst x <> gsAutoInst y+ , gsHAxioms = gsHAxioms x <> gsHAxioms y+ , gsImpAxioms = gsImpAxioms x <> gsImpAxioms y+ , 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+ }++instance Monoid GhcSpecRefl where+ mempty = SpRefl mempty mempty mempty+ mempty mempty mempty+ mempty mempty mempty+data GhcSpecLaws = SpLaws+ { gsLawDefs :: ![(Class, [(Var, LocSpecType)])]+ , gsLawInst :: ![LawInstance]+ }++data LawInstance = LawInstance+ { lilName :: Class+ , liSupers :: [LocSpecType]+ , lilTyArgs :: [LocSpecType]+ , lilEqus :: [(VarOrLocSymbol, (VarOrLocSymbol, Maybe LocSpecType))]+ , lilPos :: SrcSpan+ }++type VarOrLocSymbol = Either Var LocSymbol+type BareMeasure = Measure LocBareType F.LocSymbol+type BareDef = Def LocBareType F.LocSymbol+type SpecMeasure = Measure LocSpecType DataCon++-- $bareSpec++-- | A 'BareSpec' is the spec we derive by parsing the Liquid Haskell annotations of a single file. As+-- such, it contains things which are relevant for validation and lifting; it contains things like+-- the pragmas the user defined, the termination condition (if termination-checking is enabled) and so+-- on and so forth. /Crucially/, as a 'BareSpec' is still subject to \"preflight checks\", it may contain+-- duplicates (e.g. duplicate measures, duplicate type declarations etc.) and therefore most of the fields+-- for a 'BareSpec' are lists, so that we can report these errors to the end user: it would be an error+-- to silently ignore the duplication and leave the duplicate resolution to whichever 'Eq' instance is+-- implemented for the relevant field.+--+-- 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++-- | 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+ , 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+ , 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)++instance (Show ty, Show bndr, F.PPrint ty, F.PPrint bndr) => F.PPrint (Spec ty bndr) where+ pprintTidy k sp = text "dataDecls = " <+> pprintTidy k (dataDecls sp)+ HughesPJ.$$+ text "classes = " <+> pprintTidy k (classes sp)+ HughesPJ.$$+ text "sigs = " <+> pprintTidy k (sigs sp)++-- /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+ s1 <> s2+ = Spec { measures = measures s1 ++ measures s2+ , impSigs = impSigs s1 ++ impSigs s2+ , expSigs = expSigs s1 ++ expSigs s2+ , asmSigs = asmSigs s1 ++ asmSigs 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+ , 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+ , embeds = mappend (embeds s1) (embeds s2)+ , lvars = S.union (lvars s1) (lvars s2)+ , lazy = S.union (lazy s1) (lazy s2)+ , rewrites = S.union (rewrites s1) (rewrites s2)+ , rewriteWith = M.union (rewriteWith s1) (rewriteWith s2)+ , fails = S.union (fails s1) (fails s2)+ , reflects = S.union (reflects s1) (reflects 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)+ }++instance Monoid (Spec ty bndr) where+ mappend = (<>)+ mempty+ = Spec { measures = []+ , impSigs = []+ , expSigs = []+ , asmSigs = []+ , sigs = []+ , localSigs = []+ , reflSigs = []+ , invariants = []+ , ialiases = []+ , imports = []+ , dataDecls = []+ , newtyDecls = []+ , includes = []+ , aliases = []+ , ealiases = []+ , embeds = mempty+ , qualifiers = []+ , lvars = S.empty+ , lazy = S.empty+ , rewrites = S.empty+ , rewriteWith = M.empty+ , fails = S.empty+ , autois = M.empty+ , hmeas = S.empty+ , reflects = S.empty+ , hbounds = S.empty+ , inlines = S.empty+ , ignores = S.empty+ , autosize = S.empty+ , pragmas = []+ , cmeasures = []+ , imeasures = []+ , classes = []+ , claws = []+ , relational = []+ , asmRel = []+ , termexprs = []+ , rinstance = []+ , ilaws = []+ , dvariance = []+ , dsize = []+ , axeqs = []+ , bounds = M.empty+ , defs = M.empty+ }++-- $liftedSpec++-- | A 'LiftedSpec' is derived from an input 'BareSpec' and a set of its dependencies.+-- The general motivations for lifting a spec are (a) name resolution, (b) the fact that some info is+-- only relevant for checking the body of functions but does not need to be exported, e.g.+-- termination measures, or the fact that a type signature was assumed.+-- A 'LiftedSpec' is /what we serialise on disk and what the clients should will be using/.+--+-- 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;+-- * The 'termexprs', we don't do termination checking in lifted specs;+--+-- 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)+ -- ^ Assumed (unchecked) types; including reflected signatures+ , liftedSigs :: HashSet (F.LocSymbol, LocBareType)+ -- ^ Imported functions and types+ , liftedInvariants :: HashSet (Maybe F.LocSymbol, LocBareType)+ -- ^ Data type invariants; the Maybe is the generating measure+ , liftedIaliases :: HashSet (LocBareType, LocBareType)+ -- ^ Data type invariants to be checked+ , liftedImports :: HashSet F.Symbol+ -- ^ Loaded spec module names+ , liftedDataDecls :: HashSet DataDecl+ -- ^ Predicated data definitions+ , liftedNewtyDecls :: HashSet DataDecl+ -- ^ Predicated new type definitions+ , liftedAliases :: HashSet (F.Located (RTAlias F.Symbol BareType))+ -- ^ RefType aliases+ , liftedEaliases :: HashSet (F.Located (RTAlias F.Symbol F.Expr))+ -- ^ Expression aliases+ , liftedEmbeds :: F.TCEmb F.LocSymbol+ -- ^ GHC-Tycon-to-fixpoint Tycon map+ , liftedQualifiers :: HashSet F.Qualifier+ -- ^ Qualifiers in source/spec files+ , liftedLvars :: HashSet F.LocSymbol+ -- ^ 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+ -- ^ Type Constructors that get automatically sizing info+ , liftedCmeasures :: HashSet (Measure LocBareType ())+ -- ^ Measures attached to a type-class+ , liftedImeasures :: HashSet (Measure LocBareType F.LocSymbol)+ -- ^ Mappings from (measure,type) -> measure+ , liftedClasses :: HashSet (RClass LocBareType)+ -- ^ 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])+ -- ^ ? 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+ -- ^ Equalities used for Proof-By-Evaluation+ } deriving (Eq, Generic, Show)+ deriving Hashable via Generically LiftedSpec+ deriving Binary via Generically LiftedSpec++instance Binary F.Equation++emptyLiftedSpec :: LiftedSpec+emptyLiftedSpec = LiftedSpec+ { liftedMeasures = mempty+ , liftedImpSigs = mempty+ , liftedExpSigs = mempty+ , liftedAsmSigs = mempty+ , liftedSigs = mempty+ , liftedInvariants = mempty+ , liftedIaliases = mempty+ , liftedImports = mempty+ , liftedDataDecls = mempty+ , liftedNewtyDecls = mempty+ , liftedAliases = mempty+ , liftedEaliases = mempty+ , liftedEmbeds = mempty+ , liftedQualifiers = mempty+ , liftedLvars = mempty+ , liftedAutois = mempty+ , liftedAutosize = mempty+ , liftedCmeasures = mempty+ , liftedImeasures = mempty+ , liftedClasses = mempty+ , liftedClaws = mempty+ , liftedRinstance = mempty+ , liftedIlaws = mempty+ , liftedDvariance = mempty+ , liftedDsize = mempty+ , liftedBounds = mempty+ , liftedDefs = mempty+ , liftedAxeqs = mempty+ }++-- $trackingDeps++-- | 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 Binary via Generically TargetDependencies++-- instance S.Store TargetDependencies++instance Semigroup TargetDependencies where+ x <> y = TargetDependencies+ { getDependencies = getDependencies x <> getDependencies y+ }+++instance Monoid TargetDependencies where+ mempty = TargetDependencies mempty++-- | Drop the given 'StableModule' from the dependencies.+dropDependency :: StableModule -> TargetDependencies -> TargetDependencies+dropDependency sm (TargetDependencies deps) = TargetDependencies (M.delete sm deps)++-- $predicates++-- | Returns 'True' if the input 'Var' is a /PLE/ one.+isPLEVar :: TargetSpec -> Var -> Bool+isPLEVar sp x = M.member x (gsAutoInst (gsRefl sp))++-- | Returns 'True' if the input 'Var' was exported in the module the input 'TargetSrc' represents.+isExportedVar :: TargetSrc -> Var -> Bool+isExportedVar src v = mkStableName n `S.member` ns+ where+ n = getName v+ ns = gsExports src++--+-- $legacyDataStructures+--+{-+data GhcInfo = GI+ { _giSrc :: !GhcSrc+ , _giSpec :: !GhcSpec -- ^ All specification information for module+ }+-}++data GhcSrc = Src+ { _giTarget :: !FilePath -- ^ Source file for module+ , _giTargetMod :: !ModName -- ^ Name for module+ , _giCbs :: ![CoreBind] -- ^ Source Code+ , _gsTcs :: ![TyCon] -- ^ All used Type constructors+ , _gsCls :: !(Maybe [ClsInst]) -- ^ Class instances?+ , _giDerVars :: !(S.HashSet Var) -- ^ Binders created by GHC eg dictionaries+ , _giImpVars :: ![Var] -- ^ Binders that are _read_ in module (but not defined?)+ , _giDefVars :: ![Var] -- ^ (Top-level) binders that are _defined_ in module+ , _giUseVars :: ![Var] -- ^ Binders that are _read_ in module+ , _gsExports :: !(HashSet StableName) -- ^ `Name`s exported by the module being verified+ , _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+ { _gsSig :: !GhcSpecSig+ , _gsQual :: !GhcSpecQual+ , _gsData :: !GhcSpecData+ , _gsName :: !GhcSpecNames+ , _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+ }++instance HasConfig GhcSpec where+ getConfig = _gsConfig+++toTargetSrc :: GhcSrc -> TargetSrc+toTargetSrc a = TargetSrc+ { giTarget = _giTarget a+ , giTargetMod = _giTargetMod a+ , giCbs = _giCbs a+ , gsTcs = _gsTcs a+ , gsCls = _gsCls a+ , giDerVars = _giDerVars a+ , giImpVars = _giImpVars a+ , giDefVars = _giDefVars a+ , giUseVars = _giUseVars a+ , gsExports = _gsExports a+ , gsFiTcs = _gsFiTcs a+ , gsFiDcs = _gsFiDcs a+ , gsPrimTcs = _gsPrimTcs a+ , gsQualImps = _gsQualImps a+ , gsAllImps = _gsAllImps a+ , gsTyThings = _gsTyThings a+ }++fromTargetSrc :: TargetSrc -> GhcSrc+fromTargetSrc a = Src+ { _giTarget = giTarget a+ , _giTargetMod = giTargetMod a+ , _giCbs = giCbs a+ , _gsTcs = gsTcs a+ , _gsCls = gsCls a+ , _giDerVars = giDerVars a+ , _giImpVars = giImpVars a+ , _giDefVars = giDefVars a+ , _giUseVars = giUseVars a+ , _gsExports = gsExports a+ , _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+ { gsSig = _gsSig ghcSpec+ , gsQual = _gsQual ghcSpec+ , gsData = _gsData ghcSpec+ , gsName = _gsName ghcSpec+ , 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 a = LiftedSpec+ { liftedMeasures = S.fromList . measures $ a+ , liftedImpSigs = S.fromList . impSigs $ a+ , liftedExpSigs = S.fromList . expSigs $ a+ , liftedAsmSigs = S.fromList . asmSigs $ 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+ , liftedEaliases = S.fromList . ealiases $ a+ , liftedEmbeds = embeds a+ , liftedQualifiers = S.fromList . qualifiers $ a+ , liftedLvars = lvars a+ , liftedAutois = autois a+ , liftedAutosize = autosize a+ , liftedCmeasures = S.fromList . cmeasures $ a+ , liftedImeasures = S.fromList . imeasures $ 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+ }++-- 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 a = Spec+ { measures = S.toList . liftedMeasures $ a+ , impSigs = S.toList . liftedImpSigs $ a+ , expSigs = S.toList . liftedExpSigs $ a+ , asmSigs = S.toList . liftedAsmSigs $ a+ , 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+ , qualifiers = S.toList . liftedQualifiers $ a+ , lvars = liftedLvars a+ , lazy = mempty+ , fails = mempty+ , rewrites = mempty+ , rewriteWith = mempty+ , reflects = mempty+ , autois = liftedAutois a+ , hmeas = mempty+ , hbounds = mempty+ , inlines = mempty+ , ignores = mempty+ , autosize = liftedAutosize a+ , pragmas = mempty+ , cmeasures = S.toList . liftedCmeasures $ a+ , imeasures = S.toList . liftedImeasures $ 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+ }
+ src/Language/Haskell/Liquid/Types/Types.hs view
@@ -0,0 +1,2515 @@+{-# 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 (foldl', 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.Types.Generics+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, τ)]+ , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`+ } 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 = isFunTyCon . 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 = isFunTyCon+ 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 -> DynFlags -> Warning -> IO ()+printWarning logger dyn (Warning srcSpan doc) = GHC.putWarnMsg logger dyn 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
+ src/Language/Haskell/Liquid/Types/Variance.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Haskell.Liquid.Types.Variance (+ Variance(..), VarianceInfo, makeTyConVariance, flipVariance+ ) where++import Prelude hiding (error)+import Control.DeepSeq+import Data.Typeable hiding (TyCon)+import Data.Data hiding (TyCon)+import GHC.Generics+import Data.Binary+import Data.Hashable+import Text.PrettyPrint.HughesPJ++import Data.Maybe (fromJust)+import qualified Data.List as L+import qualified Data.HashSet as S++import qualified Language.Fixpoint.Types as F++import Language.Haskell.Liquid.Types.Generics+import qualified Language.Haskell.Liquid.GHC.Misc as GM+import Liquid.GHC.API as Ghc hiding (text)++type VarianceInfo = [Variance]++data Variance = Invariant | Bivariant | Contravariant | Covariant+ deriving (Eq, Data, Typeable, Show, Generic)+ deriving Hashable via Generically Variance++flipVariance :: Variance -> Variance+flipVariance Invariant = Invariant+flipVariance Bivariant = Bivariant+flipVariance Contravariant = Covariant+flipVariance Covariant = Contravariant++instance Semigroup Variance where+ Bivariant <> _ = Bivariant+ _ <> Bivariant = Bivariant+ Invariant <> v = v+ v <> Invariant = v+ Covariant <> v = v+ Contravariant <> v = flipVariance v++instance Monoid Variance where+ mempty = Bivariant++instance Binary Variance+instance NFData Variance+instance F.PPrint Variance where+ pprintTidy _ = text . show++++makeTyConVariance :: TyCon -> VarianceInfo+makeTyConVariance tyCon = varSignToVariance <$> tvs+ where+ tvs = GM.tyConTyVarsDef tyCon++ varsigns = if Ghc.isTypeSynonymTyCon tyCon+ then go True (fromJust $ Ghc.synTyConRhs_maybe tyCon)+ else L.nub $ concatMap goDCon $ Ghc.tyConDataCons tyCon++ varSignToVariance v = case filter (\p -> GM.showPpr (fst p) == GM.showPpr v) varsigns of+ [] -> Invariant+ [(_, b)] -> if b then Covariant else Contravariant+ _ -> Bivariant+++ goDCon dc = concatMap (go True . irrelevantMult) (Ghc.dataConOrigArgTys dc)++ go pos (FunTy _ _ t1 t2) = go (not pos) t1 ++ go pos t2+ go pos (ForAllTy _ t) = go pos t+ go pos (TyVarTy v) = [(v, pos)]+ go pos (AppTy t1 t2) = go pos t1 ++ go pos t2+ go pos (TyConApp c' ts)+ | tyCon == c'+ = []++-- NV fix that: what happens if we have mutually recursive data types?+-- now just provide "default" Bivariant for mutually rec types.+-- but there should be a finer solution+ | mutuallyRecursive tyCon c'+ = concatMap (goTyConApp pos Bivariant) ts+ | otherwise+ = concat $ zipWith (goTyConApp pos) (makeTyConVariance c') ts++ go _ (LitTy _) = []+ go _ (CoercionTy _) = []+ go pos (CastTy t _) = go pos t++ goTyConApp _ Invariant _ = []+ goTyConApp pos Bivariant t = goTyConApp pos Contravariant t ++ goTyConApp pos Covariant t+ goTyConApp pos Covariant t = go pos t+ goTyConApp pos Contravariant t = go (not pos) t++ mutuallyRecursive c c' = c `S.member` dataConsOfTyCon c'+++dataConsOfTyCon :: TyCon -> S.HashSet TyCon+dataConsOfTyCon = dcs S.empty+ where+ dcs vis c = mconcat $ go vis <$> [irrelevantMult t | dc <- Ghc.tyConDataCons c, t <- Ghc.dataConOrigArgTys dc]+ go vis (FunTy _ _ t1 t2) = go vis t1 `S.union` go vis t2+ go vis (ForAllTy _ t) = go vis t+ go _ (TyVarTy _) = S.empty+ go vis (AppTy t1 t2) = go vis t1 `S.union` go vis t2+ go vis (TyConApp c ts)+ | c `S.member` vis+ = S.empty+ | otherwise+ = S.insert c (mconcat $ go vis <$> ts) `S.union` dcs (S.insert c vis) c+ go _ (LitTy _) = S.empty+ go _ (CoercionTy _) = S.empty+ go vis (CastTy t _) = go vis t+
+ src/Language/Haskell/Liquid/Types/Visitors.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Haskell.Liquid.Types.Visitors (++ CBVisitable (..)++ -- * visitors+ , coreVisitor+ , CoreVisitor (..)++ ) where++import Data.Hashable++import Data.List (foldl', (\\), delete)+import qualified Data.HashSet as S+import Prelude hiding (error)+import Language.Fixpoint.Misc+import Liquid.GHC.API+import Language.Haskell.Liquid.GHC.Misc ()+++------------------------------------------------------------------------------+-------------------------------- A CoreBind Visitor --------------------------+------------------------------------------------------------------------------++-- TODO: syb-shrinkage++class CBVisitable a where+ freeVars :: S.HashSet Var -> a -> [Var]+ readVars :: a -> [Var]+ letVars :: a -> [Var]+ literals :: a -> [Literal]++instance CBVisitable [CoreBind] where+ freeVars env cbs = sortNub xs \\ ys+ where xs = concatMap (freeVars env) cbs+ ys = concatMap bindings cbs++ readVars = concatMap readVars+ letVars = concatMap letVars+ literals = concatMap literals++instance CBVisitable CoreBind where+ freeVars env (NonRec x e) = freeVars (extendEnv env [x]) e+ freeVars env (Rec xes) = concatMap (freeVars env') es+ where (xs,es) = unzip xes+ env' = extendEnv env xs++ readVars (NonRec _ e) = readVars e+ readVars (Rec xes) = concat [x `delete` nubReadVars e |(x, e) <- xes]+ where nubReadVars = sortNub . readVars++ letVars (NonRec x e) = x : letVars e+ letVars (Rec xes) = xs ++ concatMap letVars es+ where+ (xs, es) = unzip xes++ literals (NonRec _ e) = literals e+ literals (Rec xes) = concatMap (literals . snd) xes++instance CBVisitable (Expr Var) where+ freeVars = exprFreeVars+ readVars = exprReadVars+ letVars = exprLetVars+ literals = exprLiterals++exprFreeVars :: S.HashSet Id -> Expr Id -> [Id]+exprFreeVars = go+ where+ go env (Var x) = [x | not (x `S.member` env)]+ go env (App e a) = go env e ++ go env a+ go env (Lam x e) = go (extendEnv env [x]) e+ go env (Let b e) = freeVars env b ++ go (extendEnv env (bindings b)) e+ go env (Tick _ e) = go env e+ go env (Cast e _) = go env e+ go env (Case e x _ cs) = go env e ++ concatMap (freeVars (extendEnv env [x])) cs+ go _ _ = []++exprReadVars :: (CBVisitable (Alt t), CBVisitable (Bind t)) => Expr t -> [Id]+exprReadVars = go+ where+ go (Var x) = [x]+ go (App e a) = concatMap go [e, a]+ go (Lam _ e) = go e+ go (Let b e) = readVars b ++ go e+ go (Tick _ e) = go e+ go (Cast e _) = go e+ go (Case e _ _ cs) = go e ++ concatMap readVars cs+ go _ = []++exprLetVars :: Expr Var -> [Var]+exprLetVars = go+ where+ go (Var _) = []+ go (App e a) = concatMap go [e, a]+ go (Lam x e) = x : go e+ go (Let b e) = letVars b ++ go e+ go (Tick _ e) = go e+ go (Cast e _) = go e+ go (Case e x _ cs) = x : go e ++ concatMap letVars cs+ go _ = []++exprLiterals :: (CBVisitable (Alt t), CBVisitable (Bind t))+ => Expr t -> [Literal]+exprLiterals = go+ where+ go (Lit l) = [l]+ go (App e a) = concatMap go [e, a]+ go (Let b e) = literals b ++ go e+ go (Lam _ e) = go e+ go (Tick _ e) = go e+ go (Cast e _) = go e+ go (Case e _ _ cs) = go e ++ concatMap literals cs+ go (Type t) = go' t+ go _ = []++ go' (LitTy tl) = [tyLitToLit tl]+ go' _ = []+++ tyLitToLit (CharTyLit c) = LitChar c+ tyLitToLit (StrTyLit fs) = LitString (bytesFS fs)+ tyLitToLit (NumTyLit i) = LitNumber LitNumInt (fromIntegral i)++++instance CBVisitable (Alt Var) where+ freeVars env (Alt a xs e) = freeVars env a ++ freeVars (extendEnv env xs) e+ readVars (Alt _ _ e) = readVars e+ letVars (Alt _ xs e) = xs ++ letVars e+ literals (Alt c _ e) = literals c ++ literals e++instance CBVisitable AltCon where+ freeVars _ (DataAlt dc) = [ x | AnId x <- dataConImplicitTyThings dc]+ freeVars _ _ = []+ readVars _ = []+ letVars _ = []+ literals (LitAlt l) = [l]+ literals _ = []++extendEnv :: (Eq a, Hashable a) => S.HashSet a -> [a] -> S.HashSet a+extendEnv = foldl' (flip S.insert)++bindings :: Bind t -> [t]+bindings (NonRec x _) = [x]+bindings (Rec xes ) = map fst xes++----------------------------------------------------------------------------------------+-- | @BindVisitor@ allows for generic, context sensitive traversals over the @CoreBinds@ +----------------------------------------------------------------------------------------+data CoreVisitor env acc = CoreVisitor+ { envF :: env -> Var -> env+ , bindF :: env -> acc -> Var -> acc+ , exprF :: env -> acc -> CoreExpr -> acc+ }++coreVisitor :: CoreVisitor env acc -> env -> acc -> [CoreBind] -> acc+coreVisitor vis cenv cacc cbs = snd (foldl' step (cenv, cacc) cbs)+ where+ stepXE (env, acc) (x,e) = (env', stepE env' acc' e)+ where+ env' = envF vis env x+ acc' = bindF vis env acc x++ step ea (NonRec x e) = stepXE ea (x, e)+ step ea (Rec xes) = foldl' stepXE ea xes++ -- step (env, acc) (NonRec x e) = stepXE env acc x e + -- step (env, acc) (Rec xes) = (env', foldl' (stepE env') acc' es) + -- where + -- acc' = foldl' (bindF vis env') acc xs+ -- env' = foldl' (envF vis) env xs + -- xs = fst <$> xes + -- es = snd <$> xes+ -- foldl' (\(env, acc) (x, e) -> )++ stepE env acc e = goE env (exprF vis env acc e) e++ goE _ acc (Var _) = acc+ goE env acc (App e1 e2) = stepE env (stepE env acc e1) e2+ goE env acc (Tick _ e) = stepE env acc e+ goE env acc (Cast e _) = stepE env acc e+ goE env acc (Lam x e) = snd (stepXE (env, acc) (x, e))+ goE env acc (Let b e) = stepE env' acc' e where (env', acc') = step (env, acc) b+ goE env acc (Case e _ _ cs) = foldl' (goC env) (stepE env acc e) cs+ goE _ acc _ = acc++ goC env acc (Alt _ xs e) = stepE env' acc' e+ where+ env' = foldl' (envF vis) env xs+ acc' = foldl' (bindF vis env) acc xs
+ src/Language/Haskell/Liquid/UX/ACSS.hs view
@@ -0,0 +1,299 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations+module Language.Haskell.Liquid.UX.ACSS (+ hscolour+ , hsannot+ , AnnMap (..)+ , breakS+ , srcModuleName+ , Status (..)+ , tokeniseWithLoc+ ) where++import Prelude hiding (error)+import qualified Liquid.GHC.API as SrcLoc++import Language.Haskell.HsColour.Anchors+import Language.Haskell.HsColour.Classify as Classify+import Language.Haskell.HsColour.HTML (renderAnchors, escape)+import qualified Language.Haskell.HsColour.CSS as CSS++import Data.Either (partitionEithers)+import Data.Maybe (fromMaybe)+import qualified Data.HashMap.Strict as M+import Data.List (find, isPrefixOf, findIndex, elemIndices, intercalate, elemIndex)+import Data.Char (isSpace)+import Text.Printf+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.Errors (panic, impossible)++data AnnMap = Ann+ { types :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)+ , errors :: [(Loc, Loc, String)] -- ^ List of error intervals+ , status :: !Status+ , sptypes :: ![(SrcLoc.RealSrcSpan, (String, String)) ]-- ^ Type information with spans+ }++data Status = Safe | Unsafe | Error | Crash+ deriving (Eq, Ord, Show)++data Annotation = A {+ typ :: Maybe String -- ^ type string+ , err :: Maybe String -- ^ error string+ , lin :: Maybe (Int, Int) -- ^ line number, total width of lines i.e. max (length (show lineNum))+ } deriving (Show)+++-- | Formats Haskell source code using HTML and mouse-over annotations+hscolour :: Bool -- ^ Whether to include anchors.+ -> Bool -- ^ Whether input document is literate haskell or not+ -> String -- ^ Haskell source code, Annotations as comments at end+ -> String -- ^ Coloured Haskell source code.++hscolour anchor lhs = hsannot anchor Nothing lhs . splitSrcAndAnns++type CommentTransform = Maybe (String -> [(TokenType, String)])++-- | Formats Haskell source code using HTML and mouse-over annotations+hsannot :: Bool -- ^ Whether to include anchors.+ -> CommentTransform -- ^ Function to refine comment tokens+ -> Bool -- ^ Whether input document is literate haskell or not+ -> (String, AnnMap) -- ^ Haskell Source, Annotations+ -> String -- ^ Coloured Haskell source code.++hsannot anchor tx False z = hsannot' Nothing anchor tx z+hsannot anchor tx True (s, m) = concatMap chunk $ litSpans $ joinL $ classify $ inlines s+ where chunk (Code c, l) = hsannot' (Just l) anchor tx (c, m)+ chunk (Lit c , _) = c++litSpans :: [Lit] -> [(Lit, Loc)]+litSpans lits = zip lits $ spans lits+ where spans = tokenSpans Nothing . map unL++hsannot' :: Maybe Loc+ -> Bool -> CommentTransform -> (String, AnnMap) -> String+hsannot' baseLoc anchor tx =+ CSS.pre+ . (if anchor then concatMap (renderAnchors renderAnnotToken)+ . insertAnnotAnchors+ else concatMap renderAnnotToken)+ . annotTokenise baseLoc tx++tokeniseWithLoc :: CommentTransform -> String -> [(TokenType, String, Loc)]+tokeniseWithLoc tx str = zipWith (\(x,y) z -> (x, y, z)) toks spans+ where+ toks = tokeniseWithCommentTransform tx str+ spans = tokenSpans Nothing $ map snd toks++-- | annotTokenise is absurdly slow: O(#tokens x #errors)++annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)]+annotTokenise baseLoc tx (src, annm) = zipWith (\(x,y) z -> (x,y,z)) toks annots+ where+ toks = tokeniseWithCommentTransform tx src+ spans = tokenSpans baseLoc $ map snd toks+ annots = fmap (spanAnnot linWidth annm) spans+ linWidth = length $ show $ length $ lines src++spanAnnot :: Int -> AnnMap -> Loc -> Annotation+spanAnnot w (Ann ts es _ _) loc = A t e b+ where+ t = fmap snd (M.lookup loc ts)+ e = "ERROR" <$ find (loc `inRange`) [(x,y) | (x,y,_) <- es]+ b = spanLine w loc++spanLine :: t -> Loc -> Maybe (Int, t)+spanLine w (L (l, c))+ | c == 1 = Just (l, w)+ | otherwise = Nothing++inRange :: Loc -> (Loc, Loc) -> Bool+inRange (L (l0, c0)) (L (l, c), L (l', c'))+ = l <= l0 && c <= c0 && l0 <= l' && c0 < c'++tokeniseWithCommentTransform :: Maybe (String -> [(TokenType, String)]) -> String -> [(TokenType, String)]+tokeniseWithCommentTransform Nothing = tokenise+tokeniseWithCommentTransform (Just g) = concatMap (expand g) . tokenise+ where expand f (Comment, s) = f s+ expand _ z = [z]++tokenSpans :: Maybe Loc -> [String] -> [Loc]+tokenSpans = scanl plusLoc . fromMaybe (L (1, 1))++plusLoc :: Loc -> String -> Loc+plusLoc (L (l, c)) s+ = case '\n' `elemIndices` s of+ [] -> L (l, c + n)+ is -> L (l + length is, n - maximum is)+ where n = length s++renderAnnotToken :: (TokenType, String, Annotation) -> String+renderAnnotToken (x, y, a) = renderLinAnnot (lin a)+ $ renderErrAnnot (err a)+ $ renderTypAnnot (typ a)+ $ CSS.renderToken (x, y)++++renderTypAnnot :: (PrintfArg t, PrintfType t) => Maybe String -> t -> t+renderTypAnnot (Just ann) s = printf "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>" (escape ann) s+renderTypAnnot Nothing s = s++renderErrAnnot :: (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1+renderErrAnnot (Just _) s = printf "<span class=hs-error>%s</span>" s+renderErrAnnot Nothing s = s++renderLinAnnot :: (Show t, PrintfArg t1, PrintfType t1)+ => Maybe (t, Int) -> t1 -> t1+renderLinAnnot (Just d) s = printf "<span class=hs-linenum>%s: </span>%s" (lineString d) s+renderLinAnnot Nothing s = s++lineString :: Show t => (t, Int) -> [Char]+lineString (i, w) = replicate (w - length is) ' ' ++ is+ where is = show i++{- Example Annotation:+<a class=annot href="#"><span class=annottext>x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)}</span>+<span class='hs-definition'>NOWTRYTHIS</span></a>+-}+++insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]+insertAnnotAnchors toks+ = stitch (zip toks' toks) $ insertAnchors toks'+ where toks' = [(x,y) | (x,y,_) <- toks]++stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c]+stitch xys ((Left a) : rest)+ = Left a : stitch xys rest+stitch ((x,y):xys) ((Right x'):rest)+ | x == x'+ = Right y : stitch xys rest+ | otherwise+ = panic Nothing "stitch"+stitch _ []+ = []+stitch _ _+ = impossible Nothing "stitch: cannot happen"++splitSrcAndAnns :: String -> (String, AnnMap)+splitSrcAndAnns s =+ let ls = lines s in+ case elemIndex breakS ls of+ Nothing -> (s, Ann M.empty [] Safe mempty)+ Just i -> (src, ann)+ where (codes, _:mname:annots) = splitAt i ls+ ann = annotParse mname $ dropWhile isSpace $ unlines annots+ src = unlines codes++srcModuleName :: String -> String+srcModuleName = fromMaybe "Main" . tokenModule . tokenise++tokenModule :: [(TokenType, [Char])] -> Maybe [Char]+tokenModule toks+ = do i <- elemIndex (Keyword, "module") toks+ let (_, toks') = splitAt (i+2) toks+ j <- findIndex ((Space ==) . fst) toks'+ let (toks'', _) = splitAt j toks'+ return $ concatMap snd toks''++breakS :: [Char]+breakS = "MOUSEOVER ANNOTATIONS"++annotParse :: String -> String -> AnnMap+annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe mempty+ where+ (ts, es) = partitionEithers $ parseLines mname 0 $ lines s+++parseLines :: [Char]+ -> Int+ -> [[Char]]+ -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]+parseLines _ _ []+ = []++parseLines mname i ("":ls)+ = parseLines mname (i+1) ls++parseLines mname i (_:_:l:c:"0":l':c':rest')+ = Right (L (line, col), L (line', col')) : parseLines mname (i + 7) rest'+ where line = read l :: Int+ col = read c :: Int+ line' = read l' :: Int+ col' = read c' :: Int++parseLines mname i (x:f:l:c:n:rest)+ | f /= mname+ = parseLines mname (i + 5 + num) rest'+ | otherwise+ = Left (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest'+ where line = read l :: Int+ col = read c :: Int+ num = read n :: Int+ anns = intercalate "\n" $ take num rest+ rest' = drop num rest++parseLines _ i _+ = panic Nothing $ "Error Parsing Annot Input on Line: " ++ show i++instance Show AnnMap where+ show (Ann ts es _ _) = "\n\n"+ ++ concatMap ppAnnotTyp (M.toList ts)+ ++ concatMap ppAnnotErr [(x,y) | (x,y,_) <- es]++ppAnnotTyp :: (PrintfArg t, PrintfType t1) => (Loc, (t, String)) -> t1+ppAnnotTyp (L (l, c), (x, s)) = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s++ppAnnotErr :: PrintfType t => (Loc, Loc) -> t+ppAnnotErr (L (l, c), L (l', c')) = printf " \n%d\n%d\n0\n%d\n%d\n\n\n\n" l c l' c'+++---------------------------------------------------------------------------------+---- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour --+---------------------------------------------------------------------------------++-- | Separating literate files into code\/comment chunks.+data Lit = Code {unL :: String} | Lit {unL :: String} deriving (Show)++-- Re-implementation of 'lines', for better efficiency (but decreased laziness).+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.+-- And retains the trailing '\n' character in each resultant string.+inlines :: String -> [String]+inlines str = lines' str id+ where+ lines' [] acc = [acc []]+ lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id -- DOS+ lines' ('\n':s) acc = acc ['\n'] : lines' s id -- Unix+ lines' (c:s) acc = lines' s (acc . (c:))+++-- | The code for classify is largely stolen from Language.Preprocessor.Unlit.+classify :: [String] -> [Lit]+classify [] = []+classify (x:xs) | "\\begin{code}"`isPrefixOf`x+ = Lit x: allProg "code" xs+classify (x:xs) | "\\begin{spec}"`isPrefixOf`x+ = Lit x: allProg "spec" xs+classify (('>':x):xs) = Code ('>':x) : classify xs+classify (x:xs) = Lit x: classify xs+++allProg :: [Char] -> [[Char]] -> [Lit]+allProg name = go+ where+ end = "\\end{" ++ name ++ "}"+ go [] = [] -- Should give an error message,+ -- but I have no good position information.+ go (x:xs) | end `isPrefixOf `x+ = Lit x: classify xs+ go (x:xs) = Code x: go xs+++-- | Join up chunks of code\/comment that are next to each other.+joinL :: [Lit] -> [Lit]+joinL [] = []+joinL (Code c:Code c2:xs) = joinL (Code (c++c2):xs)+joinL (Lit c :Lit c2 :xs) = joinL (Lit (c++c2):xs)+joinL (lit:xs) = lit: joinL xs
+ src/Language/Haskell/Liquid/UX/Annotate.hs view
@@ -0,0 +1,526 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++---------------------------------------------------------------------------+-- | This module contains the code that uses the inferred types to generate+-- 1. HTMLized source with Inferred Types in mouseover annotations.+-- 2. Annotations files (e.g. for vim/emacs)+-- 3. JSON files for the web-demo etc.+---------------------------------------------------------------------------++module Language.Haskell.Liquid.UX.Annotate+ ( mkOutput+ , annotate+ , tokeniseWithLoc+ , annErrors+ ) where++import Data.Hashable+import Data.String+import GHC ( SrcSpan (..)+ , srcSpanStartCol+ , srcSpanEndCol+ , srcSpanStartLine+ , srcSpanEndLine)+import GHC.Exts (groupWith, sortWith)+import Prelude hiding (error)+import Text.PrettyPrint.HughesPJ hiding (first)+import Text.Printf++import Data.Char (isSpace)+import Data.Function (on)+import Data.List (sortBy)+import Data.Maybe (mapMaybe)++import Data.Aeson+import Control.Arrow hiding ((<+>))+-- import Control.Applicative ((<$>))+import Control.Monad (when, forM_)++import System.Exit (ExitCode (..))+import System.FilePath (takeFileName, dropFileName, (</>))+import System.Directory (findExecutable)+import qualified System.Directory as Dir+import qualified Data.List as L+import qualified Data.Vector as V+import qualified Data.ByteString.Lazy as B+import qualified Data.Text as T+import qualified Data.HashMap.Strict as M+import qualified Language.Haskell.Liquid.Misc as Misc+import qualified Language.Haskell.Liquid.UX.ACSS as ACSS+import Language.Haskell.HsColour.Classify+import Language.Fixpoint.Utils.Files+import Language.Fixpoint.Misc+import Language.Haskell.Liquid.GHC.Misc+import qualified Liquid.GHC.API as SrcLoc+import Language.Fixpoint.Types hiding (panic, Error, Loc, Constant (..), Located (..))+import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.Types.PrettyPrint+import Language.Haskell.Liquid.Types.RefType++import Language.Haskell.Liquid.UX.Tidy+import Language.Haskell.Liquid.Types hiding (Located(..), Def(..))+-- import Language.Haskell.Liquid.Types.Specifications+++-- | @output@ creates the pretty printed output+--------------------------------------------------------------------------------------------+mkOutput :: Config -> ErrorResult -> FixSolution -> AnnInfo (Annot SpecType) -> Output Doc+--------------------------------------------------------------------------------------------+mkOutput cfg res sol anna+ = O { o_vars = Nothing+ -- , o_errors = []+ , o_types = toDoc <$> annTy+ , o_templs = toDoc <$> annTmpl+ , o_bots = mkBots annTy+ , o_result = res+ }+ where+ annTmpl = closeAnnots anna+ annTy = tidySpecType Lossy <$> applySolution sol annTmpl+ toDoc = rtypeDoc tidy+ tidy = if shortNames cfg then Lossy else Full++-- | @annotate@ actually renders the output to files+-------------------------------------------------------------------+annotate :: Config -> [FilePath] -> Output Doc -> IO ACSS.AnnMap+-------------------------------------------------------------------+annotate cfg srcFs out+ -- TODO(matt.walker): Make this obey json!+ = do when showWarns $ forM_ bots (printf "WARNING: Found false in %s\n" . showPpr)+ when doAnnotate $ mapM_ (doGenerate cfg tplAnnMap typAnnMap annTyp) srcFs+ return typAnnMap+ where+ tplAnnMap = mkAnnMap cfg res annTpl+ typAnnMap = mkAnnMap cfg res annTyp+ annTpl = o_templs out+ annTyp = o_types out+ res = o_result out+ bots = o_bots out+ showWarns = not $ nowarnings cfg+ doAnnotate = not $ noannotations cfg++doGenerate :: Config -> ACSS.AnnMap -> ACSS.AnnMap -> AnnInfo Doc -> FilePath -> IO ()+doGenerate cfg tplAnnMap typAnnMap annTyp srcF+ = do generateHtml pandocF srcF tpHtmlF tplAnnMap+ generateHtml pandocF srcF tyHtmlF typAnnMap+ writeFile vimF $ vimAnnot cfg annTyp+ B.writeFile jsonF $ encode typAnnMap+ where+ pandocF = pandocHtml cfg+ tyHtmlF = extFileName Html srcF+ tpHtmlF = extFileName Html $ extFileName Cst srcF+ _annF = extFileName Annot srcF+ jsonF = extFileName Json srcF+ vimF = extFileName Vim srcF++mkBots :: Reftable r => AnnInfo (RType c tv r) -> [GHC.SrcSpan]+mkBots (AI m) = [ src | (src, (Just _, t) : _) <- sortBy (ordSrcSpan `on` fst) $ M.toList m+ , isFalse (rTypeReft t) ]++-- | Like 'copyFile' from 'System.Directory', but ensure that the parent /temporary/ directory+-- (i.e. \".liquid\") exists on disk, creating it if necessary.+copyFileCreateParentDirIfMissing :: FilePath -> FilePath -> IO ()+copyFileCreateParentDirIfMissing src tgt = do+ Dir.createDirectoryIfMissing False $ tempDirectory tgt+ Dir.copyFile src tgt++writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO ()+writeFilesOrStrings tgtFile = mapM_ $ either (`copyFileCreateParentDirIfMissing` tgtFile) (tgtFile `appendFile`)++generateHtml :: Bool -> FilePath -> FilePath -> ACSS.AnnMap -> IO ()+generateHtml pandocF srcF htmlF annm = do+ src <- Misc.sayReadFile srcF+ let lhs = isExtFile LHs srcF+ let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)+ cssFile <- getCssPath+ copyFileCreateParentDirIfMissing cssFile (dropFileName htmlF </> takeFileName cssFile)+ renderHtml (pandocF && lhs) htmlF srcF (takeFileName cssFile) body++renderHtml :: Bool -> FilePath -> String -> String -> String -> IO ()+renderHtml True = renderPandoc+renderHtml False = renderDirect++-------------------------------------------------------------------------+-- | Pandoc HTML Rendering (for lhs + markdown source) ------------------+-------------------------------------------------------------------------+renderPandoc :: FilePath -> String -> String -> String -> IO ()+renderPandoc htmlFile srcFile css body = do+ renderFn <- maybe renderDirect renderPandoc' <$> findExecutable "pandoc"+ renderFn htmlFile srcFile css body++renderPandoc' :: FilePath -> FilePath -> FilePath -> String -> String -> IO ()+renderPandoc' pandocPath htmlFile srcFile css body = do+ _ <- writeFile mdFile $ pandocPreProc body+ ec <- executeShellCommand "pandoc" cmd+ writeFilesOrStrings htmlFile [Right (cssHTML css)]+ checkExitCode cmd ec+ where+ mdFile = extFileName Mkdn srcFile+ cmd = pandocCmd pandocPath mdFile htmlFile++checkExitCode :: Monad m => String -> ExitCode -> m ()+checkExitCode _ ExitSuccess = return ()+checkExitCode cmd (ExitFailure n) = panic Nothing $ "cmd: " ++ cmd ++ " failure code " ++ show n++pandocCmd :: FilePath -> FilePath -> FilePath -> String+pandocCmd -- pandocPath mdFile htmlFile+ = printf "%s -f markdown -t html %s > %s" -- pandocPath mdFile htmlFile++pandocPreProc :: String -> String+pandocPreProc = T.unpack+ . strip beg code+ . strip end code+ . strip beg spec+ . strip end spec+ . T.pack+ where+ beg, end, code, spec :: String+ beg = "begin"+ end = "end"+ code = "code"+ spec = "spec"+ strip x y = T.replace (T.pack $ printf "\\%s{%s}" x y) T.empty+++-------------------------------------------------------------------------+-- | Direct HTML Rendering (for non-lhs/markdown source) ----------------+-------------------------------------------------------------------------++-- More or less taken from hscolour++renderDirect :: FilePath -> String -> String -> String -> IO ()+renderDirect htmlFile srcFile css body+ = writeFile htmlFile $! (topAndTail full srcFile css $! body)+ where full = True -- False -- TODO: command-line-option++-- | @topAndTail True@ is used for standalone HTML; @topAndTail False@ for embedded HTML+topAndTail :: Bool -> String -> String -> String -> String+topAndTail True title css = (htmlHeader title css ++) . (++ htmlClose)+topAndTail False _ _ = id++-- Use this for standalone HTML+htmlHeader :: String -> String -> String+htmlHeader title css = unlines+ [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"+ , "<html>"+ , "<head>"+ , "<title>" ++ title ++ "</title>"+ , "</head>"+ , cssHTML css+ , "<body>"+ , "<hr>"+ , "Put mouse over identifiers to see inferred types"+ ]++htmlClose :: IsString a => a+htmlClose = "\n</body>\n</html>"++cssHTML :: String -> String+cssHTML css = unlines+ [ "<head>"+ , "<link type='text/css' rel='stylesheet' href='"++ css ++ "' />"+ , "</head>"+ ]++------------------------------------------------------------------------------+-- | Building Annotation Maps ------------------------------------------------+------------------------------------------------------------------------------++-- | This function converts our annotation information into that which+-- is required by `Language.Haskell.Liquid.ACSS` to generate mouseover+-- annotations.++mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap+mkAnnMap cfg res ann = ACSS.Ann+ { ACSS.types = mkAnnMapTyp cfg ann+ , ACSS.errors = mkAnnMapErr res+ , ACSS.status = mkStatus res+ , ACSS.sptypes = mkAnnMapBinders cfg ann+ }++mkStatus :: FixResult t -> ACSS.Status+mkStatus (Safe _) = ACSS.Safe+mkStatus (Unsafe _ _) = ACSS.Unsafe+mkStatus (Crash _ _) = ACSS.Error++++mkAnnMapErr :: PPrint (TError t)+ => FixResult (TError t) -> [(Loc, Loc, String)]+mkAnnMapErr (Unsafe _ ls) = mapMaybe cinfoErr ls+mkAnnMapErr (Crash ls _) = mapMaybe (cinfoErr . fst) ls+mkAnnMapErr _ = []++cinfoErr :: PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)+cinfoErr e = case pos e of+ SrcLoc.RealSrcSpan l _ -> Just (srcSpanStartLoc l, srcSpanEndLoc l, showpp e)+ _ -> Nothing+++-- mkAnnMapTyp :: (RefTypable a c tv r, RefTypable a c tv (), PPrint tv, PPrint a) =>Config-> AnnInfo (RType a c tv r) -> M.HashMap Loc (String, String)+mkAnnMapTyp :: Config -> AnnInfo Doc -> M.HashMap Loc (String, String)+mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z++mkAnnMapBinders :: Config -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))]+mkAnnMapBinders cfg (AI m)+ = map (second bindStr . head . sortWith (srcSpanEndCol . fst))+ $ groupWith (lineCol . fst) locBinds+ where+ locBinds = [ (l, x) | (SrcLoc.RealSrcSpan l _, x:_) <- M.toList m, oneLine l]+ bindStr (x, v) = (maybe "_" (symbolString . shorten . symbol) x, render v)+ shorten = if shortNames cfg then dropModuleNames else id++closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType+closeAnnots = closeA . filterA . collapseA++closeA :: AnnInfo (Annot b) -> AnnInfo b+closeA a@(AI m) = cf <$> a+ where+ cf (AnnLoc l) = case m `mlookup` l of+ [(_, AnnUse t)] -> t+ [(_, AnnDef t)] -> t+ [(_, AnnRDf t)] -> t+ _ -> panic Nothing $ "malformed AnnInfo: " ++ showPpr l+ cf (AnnUse t) = t+ cf (AnnDef t) = t+ cf (AnnRDf t) = t++filterA :: AnnInfo (Annot t) -> AnnInfo (Annot t)+filterA (AI m) = AI (M.filter ff m)+ where+ ff [(_, AnnLoc l)] = l `M.member` m+ ff _ = True++collapseA :: AnnInfo (Annot t) -> AnnInfo (Annot t)+collapseA (AI m) = AI (fmap pickOneA m)++pickOneA :: [(t, Annot t1)] -> [(t, Annot t1)]+pickOneA xas = case (rs, ds, ls, us) of+ (x:_, _, _, _) -> [x]+ (_, x:_, _, _) -> [x]+ (_, _, x:_, _) -> [x]+ (_, _, _, x:_) -> [x]+ (_, _, _, _ ) -> [ ]+ where+ rs = [x | x@(_, AnnRDf _) <- xas]+ ds = [x | x@(_, AnnDef _) <- xas]+ ls = [x | x@(_, AnnLoc _) <- xas]+ us = [x | x@(_, AnnUse _) <- xas]++------------------------------------------------------------------------------+-- | Tokenizing Refinement Type Annotations in @-blocks ----------------------+------------------------------------------------------------------------------++-- | The token used for refinement symbols inside the highlighted types in @-blocks.+refToken :: TokenType+refToken = Keyword++-- | The top-level function for tokenizing @-block annotations. Used to+-- tokenize comments by ACSS.+tokAnnot :: String -> [(TokenType, String)]+tokAnnot s+ = case trimLiquidAnnot s of+ Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)]+ Nothing -> [(Comment, s)]++trimLiquidAnnot :: String -> Maybe (String, String, String)+trimLiquidAnnot ('{':'-':'@':ss)+ | drop (length ss - 3) ss == "@-}"+ = Just (liquidBegin, take (length ss - 3) ss, liquidEnd)+trimLiquidAnnot _+ = Nothing++tokBody :: String -> [(TokenType, String)]+tokBody s+ | isData s = tokenise s+ | isType s = tokenise s+ | isIncl s = tokenise s+ | isMeas s = tokenise s+ | otherwise = tokeniseSpec s++isMeas :: String -> Bool+isMeas = spacePrefix "measure"++isData :: String -> Bool+isData = spacePrefix "data"++isType :: String -> Bool+isType = spacePrefix "type"++isIncl :: String -> Bool+isIncl = spacePrefix "include"++{-@ spacePrefix :: String -> s:String -> Bool / [len s] @-}+spacePrefix :: String -> String -> Bool+spacePrefix str s@(c:cs)+ | isSpace c = spacePrefix str cs+ | otherwise = take (length str) s == str+spacePrefix _ _ = False+++tokeniseSpec :: String -> [(TokenType, String)]+tokeniseSpec = tokAlt . chopAltDBG+ where+ tokAlt (s:ss) = tokenise s ++ tokAlt' ss+ tokAlt _ = []+ tokAlt' (s:ss) = (refToken, s) : tokAlt ss+ tokAlt' _ = []++chopAltDBG :: String -> [String]+chopAltDBG y = filter (/= "")+ $ concatMap (chopAlts [("{", ":"), ("|", "}")])+ $ chopAlts [("<{", "}>"), ("{", "}")] y+++------------------------------------------------------------------------+-- | JSON: Annotation Data Types ---------------------------------------+------------------------------------------------------------------------++newtype Assoc k a = Asc (M.HashMap k a)+type AnnTypes = Assoc Int (Assoc Int Annot1)+newtype AnnErrors = AnnErrors [(Loc, Loc, String)]+data Annot1 = A1 { ident :: String+ , ann :: String+ , row :: Int+ , col :: Int+ }++------------------------------------------------------------------------+-- | Creating Vim Annotations ------------------------------------------+------------------------------------------------------------------------+vimAnnot :: Config -> AnnInfo Doc -> String+vimAnnot cfg = L.intercalate "\n" . map vimBind . mkAnnMapBinders cfg++vimBind :: (Show a, PrintfType t) => (SrcLoc.RealSrcSpan, (String, a)) -> t+vimBind (sp, (v, ann)) = printf "%d:%d-%d:%d::%s" l1 c1 l2 c2 (v ++ " :: " ++ show ann)+ where+ l1 = srcSpanStartLine sp+ c1 = srcSpanStartCol sp+ l2 = srcSpanEndLine sp+ c2 = srcSpanEndCol sp++------------------------------------------------------------------------+-- | JSON Instances ----------------------------------------------------+------------------------------------------------------------------------++instance ToJSON ACSS.Status where+ toJSON ACSS.Safe = "safe"+ toJSON ACSS.Unsafe = "unsafe"+ toJSON ACSS.Error = "error"+ toJSON ACSS.Crash = "crash"++instance ToJSON Annot1 where+ toJSON (A1 i a r c) = object [ "ident" .= i+ , "ann" .= a+ , "row" .= r+ , "col" .= c+ ]++instance ToJSON Loc where+ toJSON (L (l, c)) = object [ "line" .= toJSON l+ , "column" .= toJSON c ]++instance ToJSON AnnErrors where+ toJSON (AnnErrors errors) = Array $ V.fromList (toJ <$> errors)+ where+ toJ (l,l',s) = object [ "start" .= toJSON l+ , "stop" .= toJSON l'+ , "message" .= toJSON (dropErrorLoc s)+ ]+++++dropErrorLoc :: String -> String+dropErrorLoc msg+ | null msg' = msg+ | otherwise = tail msg'+ where+ (_, msg') = break (' ' ==) msg++instance (Show k, ToJSON a) => ToJSON (Assoc k a) where+ toJSON (Asc kas) = object [ tshow' k .= toJSON a | (k, a) <- M.toList kas ]+ where+ tshow' = fromString . show++instance ToJSON ACSS.AnnMap where+ toJSON a = object [ "types" .= toJSON (annTypes a)+ , "errors" .= toJSON (annErrors a)+ , "status" .= toJSON (ACSS.status a)+ , "sptypes" .= (toJ <$> ACSS.sptypes a)+ ]+ where+ toJ (sp, (x,t)) = object [ "start" .= toJSON (srcSpanStartLoc sp)+ , "stop" .= toJSON (srcSpanEndLoc sp)+ , "ident" .= toJSON x+ , "ann" .= toJSON t+ ]++annErrors :: ACSS.AnnMap -> AnnErrors+annErrors = AnnErrors . ACSS.errors++annTypes :: ACSS.AnnMap -> AnnTypes+annTypes a = grp [(l, c, ann1 l c x s) | (l, c, x, s) <- binders']+ where+ ann1 l c x s = A1 x s l c+ grp = L.foldl' (\m (r,c,x) -> ins r c x m) (Asc M.empty)+ binders' = [(l, c, x, s) | (L (l, c), (x, s)) <- M.toList $ ACSS.types a]++ins :: (Eq k, Eq k1, Hashable k, Hashable k1)+ => k -> k1 -> a -> Assoc k (Assoc k1 a) -> Assoc k (Assoc k1 a)+ins r c x (Asc m) = Asc (M.insert r (Asc (M.insert c x rm)) m)+ where+ Asc rm = M.lookupDefault (Asc M.empty) r m++tokeniseWithLoc :: String -> [(TokenType, String, Loc)]+tokeniseWithLoc = ACSS.tokeniseWithLoc (Just tokAnnot)++--------------------------------------------------------------------------------+-- | LH Related Stuff ----------------------------------------------------------+--------------------------------------------------------------------------------++{-@ LIQUID "--diffcheck" @-}++{-@ type ListNE a = {v:[a] | 0 < len v} @-}+{-@ type ListN a N = {v:[a] | len v == N} @-}+{-@ type ListXs a Xs = ListN a {len Xs} @-}++{-@ assume GHC.Exts.sortWith :: Ord b => (a -> b) -> xs:[a] -> ListXs a xs @-}+{-@ assume GHC.Exts.groupWith :: Ord b => (a -> b) -> [a] -> [ListNE a] @-}++--------------------------------------------------------------------------------+-- | A Little Unit Test --------------------------------------------------------+--------------------------------------------------------------------------------++_anns :: AnnTypes+_anns =+ mkAssoc+ [ (5, mkAssoc+ [ ( 14, A1 { ident = "foo"+ , ann = "int -> int"+ , row = 5+ , col = 14+ })+ ]+ )+ , (9, mkAssoc+ [ ( 22, A1 { ident = "map"+ , ann = "(a -> b) -> [a] -> [b]"+ , row = 9+ , col = 22+ })+ , ( 28, A1 { ident = "xs"+ , ann = "[b]"+ , row = 9+ , col = 28+ })+ ])+ ]++mkAssoc :: (Eq k, Hashable k) => [(k, a)] -> Assoc k a+mkAssoc = Asc . M.fromList
+ src/Language/Haskell/Liquid/UX/CTags.hs view
@@ -0,0 +1,76 @@+-- | This module contains the code for generating "tags" for constraints+-- based on their source, i.e. the top-level binders under which the+-- constraint was generated. These tags are used by fixpoint to+-- prioritize constraints by the "source-level" function.++{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.UX.CTags (+ -- * Type for constraint tags+ TagKey, TagEnv++ -- * Default tag value+ , defaultTag++ -- * Constructing @TagEnv@+ , makeTagEnv++ -- * Accessing @TagEnv@+ , getTag+ , memTagEnv++) where++import Prelude hiding (error)++import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import qualified Data.Graph as G++import Language.Fixpoint.Types (Tag)+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++type TagKey = Var+type TagEnv = M.HashMap TagKey Tag++-- TODO: use the "callgraph" SCC to do this numbering.++defaultTag :: Tag+defaultTag = [0]++memTagEnv :: TagKey -> TagEnv -> Bool+memTagEnv = M.member++makeTagEnv :: [CoreBind] -> TagEnv+makeTagEnv = {- tracepp "TAGENV" . -} M.map (:[]) . callGraphRanks . makeCallGraph++-- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns++getTag :: TagKey -> TagEnv -> Tag+getTag = M.lookupDefault defaultTag++------------------------------------------------------------------------------------------------------++type CallGraph = [(Var, [Var])] -- caller-callee pairs++callGraphRanks :: CallGraph -> M.HashMap Var Int+-- callGraphRanks cg = traceShow ("CallGraph Ranks: " ++ show cg) $ callGraphRanks' cg++callGraphRanks = M.fromList . concat . index . mkScc+ where mkScc cg = G.stronglyConnComp [(u, u, vs) | (u, vs) <- cg]+ index = zipWith (\i -> map (, i) . G.flattenSCC) [1..]++makeCallGraph :: [CoreBind] -> CallGraph+makeCallGraph cbs = mapSnd calls `fmap` xes+ where xes = concatMap bindEqns cbs+ xs = S.fromList $ map fst xes+ calls = filter (`S.member` xs) . freeVars S.empty++bindEqns :: Bind t -> [(t, Expr t)]+bindEqns (NonRec x e) = [(x, e)]+bindEqns (Rec xes) = xes
+ src/Language/Haskell/Liquid/UX/CmdLine.hs view
@@ -0,0 +1,869 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wwarn=deprecations #-}+{-# OPTIONS_GHC -fno-cse #-}+{-# LANGUAGE FlexibleContexts #-}++-- | This module contains all the code needed to output the result which+-- is either: `SAFE` or `WARNING` with some reasonable error message when+-- something goes wrong. All forms of errors/exceptions should go through+-- here. The idea should be to report the error, the source position that+-- causes it, generate a suitable .json file and then exit.++module Language.Haskell.Liquid.UX.CmdLine (+ -- * Get Command Line Configuration+ getOpts, mkOpts, defConfig, config++ -- * Update Configuration With Pragma+ , withPragmas++ -- * Canonicalize Paths in Config+ , canonicalizePaths++ -- * Exit Function+ , exitWithResult+ , addErrors++ -- * Reporting the output of the checking+ , OutputResult(..)+ , reportResult++ -- * Diff check mode+ , diffcheck++ -- * Show info about this version of LiquidHaskell+ , printLiquidHaskellBanner++) where++import Prelude hiding (error)+++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Functor ((<&>))+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy.Char8 as B+import Development.GitRev (gitCommitCount)+import qualified Paths_liquidhaskell_boot as Meta+import System.Directory+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.Text+import GitHash++import Data.List (nub)+++import System.FilePath (isAbsolute, takeDirectory, (</>))++import qualified Language.Fixpoint.Types.Config as FC+import Language.Fixpoint.Misc+import Language.Fixpoint.Types.Names+import Language.Fixpoint.Types hiding (panic, Error, Result, saveQuery)+import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Solver.Stats as Solver+import Language.Haskell.Liquid.UX.Annotate+import Language.Haskell.Liquid.UX.Config+import Language.Haskell.Liquid.UX.SimpleVersion (simpleVersion)+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.PrettyPrint ()+import Language.Haskell.Liquid.Types hiding (typ)+import qualified Language.Haskell.Liquid.UX.ACSS as ACSS++import qualified Liquid.GHC.API as GHC+import Language.Haskell.TH.Syntax.Compat (fromCode, toCode)++import Text.PrettyPrint.HughesPJ hiding (Mode, (<>))++++---------------------------------------------------------------------------------+-- Config Magic Numbers----------------------------------------------------------+---------------------------------------------------------------------------------++defaultMaxParams :: Int+defaultMaxParams = 2++---------------------------------------------------------------------------------+-- Parsing Command Line----------------------------------------------------------+---------------------------------------------------------------------------------+config :: Mode (CmdArgs Config)+config = cmdArgsMode $ Config {+ loggingVerbosity+ = enum [ Quiet &= name "quiet" &= help "Minimal logging verbosity"+ , Normal &= name "normal" &= help "Normal logging verbosity"+ , CmdArgs.Loud &= name "verbose" &= help "Verbose logging"+ ]++ , files+ = def &= typ "TARGET"+ &= args+ &= typFile++ , idirs+ = def &= typDir+ &= help "Paths to Spec Include Directory "++ , fullcheck+ = def+ &= help "Full Checking: check all binders (DEFAULT)"++ , diffcheck+ = def+ &= help "Incremental Checking: only check changed binders"++ , higherorder+ = def+ &= help "Allow higher order binders into the logic"++ , smtTimeout+ = def+ &= help "Timeout of smt queries in msec"++ , higherorderqs+ = def+ &= help "Allow higher order qualifiers to get automatically instantiated"++ , linear+ = def+ &= help "Use uninterpreted integer multiplication and division"++ , stringTheory+ = def+ &= help "Interpretation of Strings by z3"++ , saveQuery+ = def &= help "Save fixpoint query to file (slow)"++ , checks+ = def &= help "Check a specific (top-level) binder"+ &= name "check-var"++ , pruneUnsorted+ = def &= help "Disable prunning unsorted Predicates"+ &= name "prune-unsorted"++ , notermination+ = def+ &= help "Disable Termination Check"+ &= name "no-termination-check"++ , nopositivity+ = def+ &= help "Disable Data Type Positivity Check"+ &= name "no-positivity-check"++ , rankNTypes+ = def &= help "Adds precise reasoning on presence of rankNTypes"+ &= name "rankNTypes"++ , noclasscheck+ = def+ &= help "Disable Class Instance Check"+ &= name "no-class-check"++ , nostructuralterm+ = def &= name "no-structural-termination"+ &= help "Disable structural termination check"++ , gradual+ = def &= help "Enable gradual refinement type checking"+ &= name "gradual"++ , bscope+ = def &= help "scope of the outer binders on the inner refinements"+ &= name "bscope"++ , gdepth+ = 1+ &= help "Size of gradual conretizations, 1 by default"+ &= name "gradual-depth"++ , ginteractive+ = def &= help "Interactive Gradual Solving"+ &= name "ginteractive"++ , totalHaskell+ = def &= help "Check for termination and totality; overrides no-termination flags"+ &= name "total-Haskell"++ , nowarnings+ = def &= help "Don't display warnings, only show errors"+ &= name "no-warnings"++ , noannotations+ = def &= help "Don't create intermediate annotation files"+ &= name "no-annotations"++ , checkDerived+ = def &= help "Check GHC generated binders (e.g. Read, Show instances)"+ &= name "check-derived"++ , caseExpandDepth+ = 2 &= help "Maximum depth at which to expand DEFAULT in case-of (default=2)"+ &= name "max-case-expand"++ , notruetypes+ = def &= help "Disable Trueing Top Level Types"+ &= name "no-true-types"++ , nototality+ = def &= help "Disable totality check"+ &= name "no-totality"++ , cores+ = def &= help "Use m cores to solve logical constraints"++ , minPartSize+ = FC.defaultMinPartSize+ &= help "If solving on multiple cores, ensure that partitions are of at least m size"++ , maxPartSize+ = FC.defaultMaxPartSize+ &= help ("If solving on multiple cores, once there are as many partitions " +++ "as there are cores, don't merge partitions if they will exceed this " +++ "size. Overrides the minpartsize option.")++ , smtsolver+ = def &= help "Name of SMT-Solver"++ , noCheckUnknown+ = def &= explicit+ &= name "no-check-unknown"+ &= help "Don't complain about specifications for unexported and unused values "++ , maxParams+ = defaultMaxParams &= help "Restrict qualifier mining to those taking at most `m' parameters (2 by default)"++ , shortNames+ = def &= name "short-names"+ &= help "Print shortened names, i.e. drop all module qualifiers."++ , shortErrors+ = def &= name "short-errors"+ &= help "Don't show long error messages, just line numbers."++ , cabalDir+ = def &= name "cabal-dir"+ &= help "Find and use .cabal to add paths to sources for imported files"++ , ghcOptions+ = def &= name "ghc-option"+ &= typ "OPTION"+ &= help "Pass this option to GHC"++ , cFiles+ = def &= name "c-files"+ &= typ "OPTION"+ &= help "Tell GHC to compile and link against these files"++ , port+ = defaultPort+ &= name "port"+ &= help "Port at which lhi should listen"++ , exactDC+ = def &= help "Exact Type for Data Constructors"+ &= name "exact-data-cons"++ , noADT+ = def &= help "Do not generate ADT representations in refinement logic"+ &= name "no-adt"++ , expectErrorContaining+ = def &= help "Expect an error which containing the provided string from verification (can be provided more than once)"+ &= name "expect-error-containing"++ , expectAnyError+ = 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"++ , elimBound+ = Nothing+ &= name "elimBound"+ &= help "Maximum chain length for eliminating KVars"++ , noslice+ = False+ &= name "noSlice"+ &= help "Disable non-concrete KVar slicing"++ , noLiftedImport+ = False+ &= name "no-lifted-imports"+ &= help "Disable loading lifted specifications (for legacy libs)"++ , json+ = False &= name "json"+ &= help "Print results in JSON (for editor integration)"++ , counterExamples+ = False &= name "counter-examples"+ &= help "Attempt to generate counter-examples to type errors (experimental!)"++ , timeBinds+ = False &= name "time-binds"+ &= help "Solve each (top-level) asserted type signature separately & time solving."++ , untidyCore+ = False &= name "untidy-core"+ &= help "Print fully qualified identifier names in verbose mode"++ , eliminate+ = FC.Some+ &= name "eliminate"+ &= help "Use elimination for 'all' (use TRUE for cut-kvars), 'some' (use quals for cut-kvars) or 'none' (use quals for all kvars)."++ , noPatternInline+ = False &= name "no-pattern-inline"+ &= help "Don't inline special patterns (e.g. `>>=` and `return`) during constraint generation."++ , noSimplifyCore+ = False &= name "no-simplify-core"+ &= help "Don't simplify GHC core before constraint generation"++ -- PLE-OPT , autoInstantiate+ -- PLE-OPT = def+ -- PLE-OPT &= help "How to instantiate axiomatized functions `smtinstances` for SMT instantiation, `liquidinstances` for terminating instantiation"+ -- PLE-OPT &= name "automatic-instances"++ , proofLogicEval+ = def+ &= help "Enable Proof-by-Logical-Evaluation"+ &= name "ple"++ , pleWithUndecidedGuards+ = def+ &= help "Unfold invocations with undecided guards in PLE"+ &= name "ple-with-undecided-guards"+ &= explicit++ , oldPLE+ = def+ &= help "Enable Proof-by-Logical-Evaluation"+ &= name "oldple"++ , interpreter+ = def+ &= help "Use an interpreter to assist PLE in solving constraints"+ &= name "interpreter"++ , proofLogicEvalLocal+ = def+ &= help "Enable Proof-by-Logical-Evaluation locally, per function"+ &= name "ple-local"++ , extensionality+ = def+ &= help "Enable extensional interpretation of function equality"+ &= name "extensionality"++ , nopolyinfer+ = def+ &= help "No inference of polymorphic type application. Gives imprecision, but speedup."+ &= name "fast"++ , reflection+ = def+ &= help "Enable reflection of Haskell functions and theorem proving"+ &= name "reflection"++ , compileSpec+ = def+ &= name "compile-spec"+ &= help "Only compile specifications (into .bspec file); skip verification"++ , noCheckImports+ = def+ &= name "no-check-imports"+ &= help "Do not check the transitive imports; only check the target files."++ , typeclass+ = def+ &= help "Enable Typeclass"+ &= name "typeclass"+ , auxInline+ = def+ &= help "Enable inlining of class methods"+ &= name "aux-inline"+ ,+ rwTerminationCheck+ = def+ &= name "rw-termination-check"+ &= help ( "Enable the rewrite divergence checker. "+ ++ "Can speed up verification if rewriting terminates, but can also cause divergence."+ )+ ,+ skipModule+ = def+ &= name "skip-module"+ &= help "Completely skip this module, don't even compile any specifications in it."+ ,+ noLazyPLE+ = def+ &= name "no-lazy-ple"+ &= help "Don't use Lazy PLE"++ , fuel+ = Nothing+ &= help "Maximum fuel (per-function unfoldings) for PLE"++ , environmentReduction+ = def+ &= explicit+ &= name "environment-reduction"+ &= help "perform environment reduction (disabled by default)"+ , noEnvironmentReduction+ = def+ &= explicit+ &= name "no-environment-reduction"+ &= help "Don't perform environment reduction"+ , inlineANFBindings+ = False+ &= explicit+ &= name "inline-anf-bindings"+ &= help (unwords+ [ "Inline ANF bindings."+ , "Sometimes improves performance and sometimes worsens it."+ , "Disabled by --no-environment-reduction"+ ])+ , pandocHtml+ = False+ &= name "pandoc-html"+ &= help "Use pandoc to generate html."+ , excludeAutomaticAssumptionsFor+ = []+ &= explicit+ &= name "exclude-automatic-assumptions-for"+ &= help "Stop loading LHAssumptions modules for imports in these packages."+ &= typ "PACKAGE"+ } &= program "liquid"+ &= help "Refinement Types for Haskell"+ &= summary copyright+ &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"+ , ""+ , "To check a Haskell file foo.hs, type:"+ , " liquid foo.hs "+ ]++defaultPort :: Int+defaultPort = 3000++getOpts :: [String] -> IO Config+getOpts as = do+ cfg0 <- envCfg+ cfg1 <- mkOpts =<< cmdArgsRun'+ config { modeValue = (modeValue config)+ { cmdArgsValue = cfg0+ }+ }+ 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++cmdArgsRun' :: Mode (CmdArgs a) -> [String] -> IO a+cmdArgsRun' md as+ = case parseResult of+ Left e -> putStrLn (helpMsg e) >> exitFailure+ Right a -> cmdArgsApply a+ where+ helpMsg e = showText defaultWrap $ helpText [e] HelpFormatDefault md+ parseResult = process md (wideHelp as)+ wideHelp = map (\a -> if a == "--help" || a == "-help" then "--help=120" else a)+++--------------------------------------------------------------------------------+withSmtSolver :: Config -> IO Config+--------------------------------------------------------------------------------+withSmtSolver cfg =+ case smtsolver cfg of+ Just smt -> do found <- findSmtSolver smt+ case found of+ Just _ -> return cfg+ Nothing -> panic Nothing (missingSmtError smt)+ Nothing -> do smts <- mapM findSmtSolver [FC.Z3, FC.Cvc4, FC.Mathsat]+ case catMaybes smts of+ (s:_) -> return (cfg {smtsolver = Just s})+ _ -> panic Nothing noSmtError+ where+ noSmtError = "LiquidHaskell requires an SMT Solver, i.e. z3, cvc4, or mathsat to be installed."+ 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)++fixConfig :: Config -> IO Config+fixConfig config' = do+ pwd <- getCurrentDirectory+ cfg <- canonicalizePaths pwd config'+ return $ canonConfig cfg++-- | Attempt to canonicalize all `FilePath's in the `Config' so we don't have+-- to worry about relative paths.+canonicalizePaths :: FilePath -> Config -> IO Config+canonicalizePaths pwd cfg = do+ tgt <- canonicalizePath pwd+ isdir <- doesDirectoryExist tgt+ is <- mapM (canonicalize tgt isdir) $ idirs cfg+ cs <- mapM (canonicalize tgt isdir) $ cFiles cfg+ return $ cfg { idirs = is, cFiles = cs }++canonicalize :: FilePath -> Bool -> FilePath -> IO FilePath+canonicalize tgt isdir f+ | isAbsolute f = return f+ | isdir = canonicalizePath (tgt </> f)+ | otherwise = canonicalizePath (takeDirectory tgt </> f)++envCfg :: IO Config+envCfg = do+ so <- lookupEnv "LIQUIDHASKELL_OPTS"+ case so of+ Nothing -> return defConfig+ Just s -> parsePragma $ envLoc s+ where+ envLoc = Loc l l+ l = safeSourcePos "ENVIRONMENT" 1 1++copyright :: String+copyright = concat $ concat+ [ ["LiquidHaskell "]+ , [$(simpleVersion Meta.version)]+ , [gitInfo]+ -- , [" (" ++ _commitCount ++ " commits)" | _commitCount /= ("1"::String) &&+ -- _commitCount /= ("UNKNOWN" :: String)]+ , ["\nCopyright 2013-19 Regents of the University of California. All Rights Reserved.\n"]+ ]+ where+ _commitCount = $gitCommitCount++gitInfo :: String+gitInfo = msg+ where+ giTry :: Either String GitInfo+ giTry = $$(fromCode (toCode tGitInfoCwdTry))+ msg = case giTry of+ Left _ -> " no git information"+ Right gi -> gitMsg gi++gitMsg :: GitInfo -> String+gitMsg gi = concat+ [ " [", giBranch gi, "@", giHash gi+ , " (", giCommitDate gi, ")"+ -- , " (", show (giCommitCount gi), " commits in HEAD)"+ , "] "+ ]+++-- [NOTE:searchpath]+-- 1. we used to add the directory containing the file to the searchpath,+-- but this is bad because GHC does NOT do this, and it causes spurious+-- "duplicate module" errors in the following scenario+-- > tree+-- .+-- ├── Bar.hs+-- └── Foo+-- ├── Bar.hs+-- └── Goo.hs+-- If we run `liquid Foo/Goo.hs` and that imports Bar, GHC will not know+-- whether we mean to import Bar.hs or Foo/Bar.hs+-- 2. tests fail if you flip order of idirs'++mkOpts :: Config -> IO Config+mkOpts cfg = do+ let files' = sortNub $ files cfg+ return $ cfg { files = files'+ -- See NOTE [searchpath]+ }++--------------------------------------------------------------------------------+-- | Updating options+--------------------------------------------------------------------------------+canonConfig :: Config -> Config+canonConfig cfg = cfg+ { diffcheck = diffcheck cfg && not (fullcheck cfg)+ -- , eliminate = if higherOrderFlag cfg then FC.All else eliminate cfg+ }++--------------------------------------------------------------------------------+withPragmas :: MonadIO m => Config -> FilePath -> [Located String] -> (Config -> m a) -> m a+--------------------------------------------------------------------------------+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')+ res <- action cfg'+ liftIO $ setVerbosity (loggingVerbosity cfg) -- restore the original verbosity.+ pure res++processPragmas :: Config -> [Located String] -> IO Config+processPragmas c pragmas =+ processValueIO+ config { modeValue = (modeValue config) { cmdArgsValue = c } }+ (val <$> pragmas)+ >>=+ cmdArgsApply++-- | Note that this function doesn't process list arguments properly, like+-- 'cFiles' or 'expectErrorContaining'+-- TODO: This is only used to parse the contents of the env var LIQUIDHASKELL_OPTS+-- so it should be able to parse multiple arguments instead. See issue #1990.+parsePragma :: Located String -> IO Config+parsePragma = processPragmas defConfig . (:[])++defConfig :: Config+defConfig = Config+ { loggingVerbosity = Quiet+ , files = def+ , idirs = def+ , fullcheck = def+ , linear = def+ , stringTheory = def+ , higherorder = def+ , smtTimeout = def+ , higherorderqs = def+ , diffcheck = def+ , saveQuery = def+ , checks = def+ , nostructuralterm = def+ , noCheckUnknown = def+ , notermination = False+ , nopositivity = False+ , rankNTypes = False+ , noclasscheck = False+ , gradual = False+ , bscope = False+ , gdepth = 1+ , ginteractive = False+ , totalHaskell = def -- True+ , nowarnings = def+ , noannotations = def+ , checkDerived = False+ , caseExpandDepth = 2+ , notruetypes = def+ , nototality = False+ , pruneUnsorted = def+ , exactDC = def+ , noADT = def+ , expectErrorContaining = def+ , expectAnyError = False+ , cores = def+ , minPartSize = FC.defaultMinPartSize+ , maxPartSize = FC.defaultMaxPartSize+ , maxParams = defaultMaxParams+ , smtsolver = def+ , shortNames = def+ , shortErrors = def+ , cabalDir = def+ , ghcOptions = def+ , cFiles = def+ , port = defaultPort+ , scrapeInternals = False+ , scrapeImports = False+ , scrapeUsedImports = False+ , elimStats = False+ , elimBound = Nothing+ , json = False+ , counterExamples = False+ , timeBinds = False+ , untidyCore = False+ , eliminate = FC.Some+ , noPatternInline = False+ , noSimplifyCore = False+ -- PLE-OPT , autoInstantiate = def+ , noslice = False+ , noLiftedImport = False+ , proofLogicEval = False+ , pleWithUndecidedGuards = False+ , oldPLE = False+ , interpreter = False+ , proofLogicEvalLocal = False+ , reflection = False+ , extensionality = False+ , nopolyinfer = False+ , compileSpec = False+ , noCheckImports = False+ , typeclass = False+ , auxInline = False+ , rwTerminationCheck = False+ , skipModule = False+ , noLazyPLE = False+ , fuel = Nothing+ , environmentReduction = False+ , noEnvironmentReduction = False+ , inlineANFBindings = False+ , pandocHtml = False+ , excludeAutomaticAssumptionsFor = []+ }++-- | Write the annotations (i.e. the files in the \".liquid\" hidden folder) and+-- report the result of the checking using a supplied function, or using an+-- implicit JSON function, if @json@ flag is set.+reportResult :: MonadIO m+ => (OutputResult -> m ())+ -> Config+ -> [FilePath]+ -> Output Doc+ -> m ()+reportResult logResultFull cfg targets out = do+ annm <- {-# SCC "annotate" #-} liftIO $ annotate cfg targets out+ liftIO $ whenNormal $ donePhase Loud "annotate"+ if json cfg then+ liftIO $ reportResultJson annm+ else do+ let r = o_result out+ liftIO $ writeCheckVars $ o_vars out+ cr <- liftIO $ resultWithContext r+ 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)+ 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)++------------------------------------------------------------------------+exitWithResult :: Config -> [FilePath] -> Output Doc -> IO ()+------------------------------------------------------------------------+exitWithResult cfg targets out = void $ reportResult writeResultStdout cfg targets out++reportResultJson :: ACSS.AnnMap -> IO ()+reportResultJson annm = do+ putStrLn "LIQUID"+ B.putStrLn . encode . annErrors $ annm++resultWithContext :: F.FixResult UserError -> IO (FixResult CError)+resultWithContext (F.Unsafe s es) = F.Unsafe s <$> errorsWithContext es+resultWithContext (F.Safe stats) = return (F.Safe stats)+resultWithContext (F.Crash es s) = do+ let (userErrs, msgs) = unzip es+ errs' <- errorsWithContext userErrs+ return (F.Crash (zip errs' msgs) s)+++++instance Show (CtxError Doc) where+ show = showpp++writeCheckVars :: Symbolic a => Maybe [a] -> IO ()+writeCheckVars Nothing = return ()+writeCheckVars (Just []) = colorPhaseLn Loud "Checked Binders: None" ""+writeCheckVars (Just ns) = colorPhaseLn Loud "Checked Binders:" ""+ >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)++type CError = CtxError Doc++data OutputResult = OutputResult {+ orHeader :: Doc+ -- ^ The \"header\" like \"LIQUID: SAFE\", or \"LIQUID: UNSAFE\".+ , orMessages :: [(GHC.SrcSpan, Doc)]+ -- ^ The list of pretty-printable messages (typically errors) together with their+ -- source locations.+ }++-- | Writes the result of this LiquidHaskell run to /stdout/.+writeResultStdout :: OutputResult -> IO ()+writeResultStdout (orMessages -> messages) = do+ forM_ messages $ \(sSpan, doc) -> putStrLn (render $ mkErrorDoc sSpan doc {- pprint sSpan <> (text ": error: " <+> doc)-})++mkErrorDoc :: PPrint a => a -> Doc -> Doc+mkErrorDoc sSpan doc =+ -- Gross on screen, nice for Ghcid+ -- pprint sSpan <> (text ": error: " <+> doc)++ -- Nice on screen, invisible in Ghcid ...+ (pprint sSpan <> text ": error: ") $+$ nest 4 doc+++-- | Given a 'FixResult' parameterised over a 'CError', this function returns the \"header\" to show to+-- the user (i.e. \"SAFE\" or \"UNSAFE\") plus a list of 'Doc's together with the 'SrcSpan' they refer to.+resDocs :: F.Tidy -> F.FixResult CError -> OutputResult+resDocs _ (F.Safe stats) =+ OutputResult {+ orHeader = text $ "LIQUID: SAFE (" <> show (Solver.numChck stats) <> " constraints checked)"+ , orMessages = mempty+ }+resDocs _k (F.Crash [] s) =+ OutputResult {+ orHeader = text "LIQUID: ERROR"+ , orMessages = [(GHC.noSrcSpan, text s)]+ }+resDocs k (F.Crash xs s) =+ OutputResult {+ orHeader = text "LIQUID: ERROR:" <+> text s+ , orMessages = map (cErrToSpanned k . errToFCrash) xs+ }+resDocs k (F.Unsafe _ xs) =+ OutputResult {+ orHeader = text "LIQUID: UNSAFE"+ , orMessages = map (cErrToSpanned k) (nub xs)+ }++-- | Renders a 'CError' into a 'Doc' and its associated 'SrcSpan'.+cErrToSpanned :: F.Tidy -> CError -> (GHC.SrcSpan, Doc)+cErrToSpanned k CtxError{ctErr} = (pos ctErr, pprintTidy k ctErr)++errToFCrash :: (CError, Maybe String) -> CError+errToFCrash (ce, Just msg) = ce { ctErr = ErrOther (pos (ctErr ce)) (fixMessageDoc msg) }+errToFCrash (ce, Nothing) = ce { ctErr = tx $ ctErr ce}+ where+ tx (ErrSubType l m _ g t t') = ErrFCrash l m g t t'+ tx e = F.notracepp "errToFCrash?" e++fixMessageDoc :: String -> Doc+fixMessageDoc msg = vcat (text <$> lines msg)++{-+ TODO: Never used, do I need to exist?+reportUrl = text "Please submit a bug report at: https://github.com/ucsd-progsys/liquidhaskell" -}++addErrors :: FixResult a -> [a] -> FixResult a+addErrors r [] = r+addErrors (Safe s) errors = Unsafe s errors+addErrors (Unsafe s xs) errors = Unsafe s (xs ++ errors)+addErrors r _ = r++instance Fixpoint (F.FixResult CError) where+ toFix = vcat . map snd . orMessages . resDocs F.Full
+ src/Language/Haskell/Liquid/UX/Config.hs view
@@ -0,0 +1,165 @@+-- | Command Line Configuration Options ----------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Language.Haskell.Liquid.UX.Config (+ Config (..)+ , HasConfig (..)+ , allowPLE, allowLocalPLE, allowGlobalPLE+ , patternFlag+ , higherOrderFlag+ , pruneFlag+ , maxCaseExpand+ , exactDCFlag+ , hasOpt+ , totalityCheck+ , terminationCheck+ , structuralTerm+ ) where++import Prelude hiding (error)+import Language.Fixpoint.Types.Config hiding (Config)+import GHC.Generics+import System.Console.CmdArgs++-- NOTE: adding strictness annotations breaks the help message+data Config = Config+ { loggingVerbosity :: Verbosity -- ^ the logging verbosity to use (defaults to 'Quiet')+ , 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+ , linear :: Bool -- ^ uninterpreted integer multiplication and division+ , stringTheory :: Bool -- ^ interpretation of string theory in the logic+ , higherorder :: Bool -- ^ allow higher order binders into the logic+ , higherorderqs :: Bool -- ^ allow higher order qualifiers+ , smtTimeout :: Maybe Int -- ^ smt timeout+ , fullcheck :: Bool -- ^ check all binders (overrides diffcheck)+ , saveQuery :: Bool -- ^ save fixpoint query+ , checks :: [String] -- ^ set of binders to check+ , noCheckUnknown :: Bool -- ^ whether to complain about specifications for unexported and unused values+ , notermination :: Bool -- ^ disable termination check+ , nopositivity :: Bool -- ^ disable positivity check+ , rankNTypes :: Bool -- ^ Adds precise reasoning on presence of rankNTypes+ , noclasscheck :: Bool -- ^ disable checking class instances+ -- , structuralTerm :: Bool -- ^ use structural termination checker+ , nostructuralterm :: Bool -- ^ disable structural termination check+ , gradual :: Bool -- ^ enable gradual type checking+ , bscope :: Bool -- ^ scope of the outer binders on the inner refinements+ , gdepth :: Int -- ^ depth of gradual concretization+ , ginteractive :: Bool -- ^ interactive gradual solving+ , totalHaskell :: Bool -- ^ Check for termination and totality, Overrides no-termination flags+ , nowarnings :: Bool -- ^ disable warnings output (only show errors)+ , noannotations :: Bool -- ^ disable creation of intermediate annotation files+ , checkDerived :: Bool -- ^ check internal (GHC-derived) binders+ , caseExpandDepth :: Int -- ^ maximum case expand nesting depth.+ , notruetypes :: Bool -- ^ disable truing top level types+ , nototality :: Bool -- ^ disable totality check in definitions+ , pruneUnsorted :: Bool -- ^ enable prunning unsorted Refinements+ , cores :: Maybe Int -- ^ number of cores used to solve constraints+ , minPartSize :: Int -- ^ Minimum size of a partition+ , maxPartSize :: Int -- ^ Maximum size of a partition. Overrides minPartSize+ , maxParams :: Int -- ^ the maximum number of parameters to accept when mining qualifiers+ , smtsolver :: Maybe SMTSolver -- ^ name of smtsolver to use [default: try z3, cvc4, mathsat in order]+ , shortNames :: Bool -- ^ drop module qualifers from pretty-printed names.+ , shortErrors :: Bool -- ^ don't show subtyping errors and contexts.+ , cabalDir :: Bool -- ^ find and use .cabal file to include paths to sources for imported modules+ , ghcOptions :: [String] -- ^ command-line options to pass to GHC+ , cFiles :: [String] -- ^ .c files to compile and link against (for GHC)+ , eliminate :: Eliminate -- ^ eliminate (i.e. don't use qualifs for) for "none", "cuts" or "all" kvars+ , port :: Int -- ^ port at which lhi should listen+ , exactDC :: Bool -- ^ Automatically generate singleton types for data constructors+ , 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+ , counterExamples :: Bool -- ^ attempt to generate counter-examples to type errors+ , timeBinds :: Bool -- ^ check and time each (asserted) type-sig separately+ , noPatternInline :: Bool -- ^ treat code patterns (e.g. e1 >>= \x -> e2) specially for inference+ , untidyCore :: Bool -- ^ print full blown core (with untidy names) in verbose mode+ , noSimplifyCore :: Bool -- ^ simplify GHC core before constraint-generation+ -- PLE-OPT , autoInst ntiate :: Instantiate -- ^ How to instantiate axioms+ , noslice :: Bool -- ^ Disable non-concrete KVar slicing+ , noLiftedImport :: Bool -- ^ Disable loading lifted specifications (for "legacy" libs)+ , proofLogicEval :: Bool -- ^ Enable proof-by-logical-evaluation+ , pleWithUndecidedGuards :: Bool -- ^ Unfold invocations with undecided guards in PLE+ , 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+ , 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"+ , compileSpec :: Bool -- ^ Only "compile" the spec -- into .bspec file -- don't do any checking.+ , noCheckImports :: Bool -- ^ Do not check the transitive imports+ , typeclass :: Bool -- ^ enable typeclass support.+ , auxInline :: Bool -- ^ + , rwTerminationCheck :: Bool -- ^ Enable termination checking for rewriting+ , skipModule :: Bool -- ^ Skip this module entirely (don't even compile any specs in it)+ , noLazyPLE :: Bool+ , fuel :: Maybe Int -- ^ Maximum PLE "fuel" (unfold depth) (default=infinite) + , environmentReduction :: Bool -- ^ Perform environment reduction+ , noEnvironmentReduction :: Bool -- ^ Don't perform environment reduction+ , inlineANFBindings :: Bool -- ^ Inline ANF bindings.+ -- Sometimes improves performance and sometimes worsens it.+ , pandocHtml :: Bool -- ^ Use pandoc to generate html+ , excludeAutomaticAssumptionsFor :: [String]+ } deriving (Generic, Data, Typeable, Show, Eq)++allowPLE :: Config -> Bool+allowPLE cfg+ = allowGlobalPLE cfg+ || allowLocalPLE cfg++allowGlobalPLE :: Config -> Bool+allowGlobalPLE cfg = proofLogicEval cfg++allowLocalPLE :: Config -> Bool+allowLocalPLE cfg = proofLogicEvalLocal cfg++instance HasConfig Config where+ getConfig x = x++class HasConfig t where+ getConfig :: t -> Config++patternFlag :: (HasConfig t) => t -> Bool+patternFlag = not . noPatternInline . getConfig++higherOrderFlag :: (HasConfig t) => t -> Bool+higherOrderFlag x = higherorder cfg || reflection cfg+ where+ cfg = getConfig x++exactDCFlag :: (HasConfig t) => t -> Bool+exactDCFlag x = exactDC cfg || reflection cfg+ where+ cfg = getConfig x++pruneFlag :: (HasConfig t) => t -> Bool+pruneFlag = pruneUnsorted . getConfig++maxCaseExpand :: (HasConfig t) => t -> Int+maxCaseExpand = caseExpandDepth . getConfig++hasOpt :: (HasConfig t) => t -> (Config -> Bool) -> Bool+hasOpt t f = f (getConfig t)++totalityCheck :: (HasConfig t) => t -> Bool+totalityCheck = totalityCheck' . getConfig++terminationCheck :: (HasConfig t) => t -> Bool+terminationCheck = terminationCheck' . getConfig++totalityCheck' :: Config -> Bool+totalityCheck' cfg = not (nototality cfg) || totalHaskell cfg++terminationCheck' :: Config -> Bool+terminationCheck' cfg = totalHaskell cfg || not (notermination cfg)++structuralTerm :: (HasConfig a) => a -> Bool+structuralTerm = not . nostructuralterm . getConfig
+ src/Language/Haskell/Liquid/UX/DiffCheck.hs view
@@ -0,0 +1,618 @@+-- | This module contains the code for Incremental checking, which finds the+-- part of a target file (the subset of the @[CoreBind]@ that have been+-- modified since it was last checked, as determined by a diff against+-- a saved version of the file.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.UX.DiffCheck (++ -- * Changed binders + Unchanged Errors+ DiffCheck (..)++ -- * Use previously saved info to generate DiffCheck target+ , slice++ -- * Use target binders to generate DiffCheck target+ , thin -- , ThinDeps (..)++ -- * Save current information for next time+ , saveResult++ -- * Names of top-level binders that are rechecked+ , checkedVars++ -- * CoreBinds defining given set of Var+ , filterBinds+ , coreDeps+ , dependsOn+ , Def(..)+ , coreDefs+ )+ where+++import Prelude hiding (error)+import Data.Aeson+import qualified Data.Text as T+import Data.Algorithm.Diff+import Data.Maybe (maybeToList, listToMaybe, mapMaybe, fromMaybe)+import qualified Data.IntervalMap.FingerTree as IM+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import System.Directory (copyFile, doesFileExist)+import Language.Fixpoint.Types (atLoc, FixResult (..), SourcePos(..), safeSourcePos, unPos)+-- import qualified Language.Fixpoint.Misc as Misc+import Language.Fixpoint.Utils.Files+import Language.Fixpoint.Solver.Stats ()+import Language.Haskell.Liquid.Misc (mkGraph)+import Language.Haskell.Liquid.GHC.Misc+import Liquid.GHC.API as Ghc hiding ( Located+ , sourceName+ , text+ , panic+ , showPpr+ )+import Text.PrettyPrint.HughesPJ (text, render, Doc)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB++import Language.Haskell.Liquid.Types hiding (Def, LMap)++--------------------------------------------------------------------------------+-- | Data Types ----------------------------------------------------------------+--------------------------------------------------------------------------------++-- | Main type of value returned for diff-check.+data DiffCheck = DC+ { newBinds :: [CoreBind]+ , oldOutput :: !(Output Doc)+ , newSpec :: !TargetSpec+ }++instance PPrint DiffCheck where+ pprintTidy k dc = pprintTidy k (checkedVars dc) <> pprintTidy k (oldOutput dc)+++-- | Variable definitions+data Def = D+ { start :: Int -- ^ line at which binder definition starts+ , end :: Int -- ^ line at which binder definition ends+ , binder :: Var -- ^ name of binder+ }+ deriving (Eq, Ord)++-- | Variable dependencies "call-graph"+type Deps = M.HashMap Var (S.HashSet Var)++-- | Map from saved-line-num ---> current-line-num+type LMap = IM.IntervalMap Int Int++-- | Intervals of line numbers that have been re-checked+type ChkItv = IM.IntervalMap Int ()++instance Show Def where+ show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j++--------------------------------------------------------------------------------+-- | `checkedNames` returns the names of the top-level binders that will be checked+--------------------------------------------------------------------------------+checkedVars :: DiffCheck -> [Var]+checkedVars = concatMap names . newBinds+ where+ names (NonRec v _ ) = [v]+ names (Rec xs) = fst <$> xs++--------------------------------------------------------------------------------+-- | `slice` returns a subset of the @[CoreBind]@ of the input `target`+-- file which correspond to top-level binders whose code has changed+-- and their transitive dependencies.+--------------------------------------------------------------------------------+slice :: FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)+--------------------------------------------------------------------------------+slice target cbs sp = do+ ex <- doesFileExist savedFile+ if ex+ then doDiffCheck+ else return Nothing+ where+ savedFile = extFileName Saved target+ doDiffCheck = sliceSaved target savedFile cbs sp++sliceSaved :: FilePath -> FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)+sliceSaved target savedFile coreBinds spec = do+ (is, lm) <- lineDiff target savedFile+ result <- loadResult target+ return $ sliceSaved' target is lm (DC coreBinds result spec)++sliceSaved' :: FilePath -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck+sliceSaved' srcF is lm (DC coreBinds result spec)+ | gDiff = Nothing+ | otherwise = Just $ DC cbs' res' sp'+ where+ gDiff = globalDiff srcF is spec+ sp' = assumeSpec sigm spec+ res' = adjustOutput lm cm result+ cm = checkedItv (coreDefs cbs')+ cbs' = thinWith sigs coreBinds (diffVars is defs)+ defs = coreDefs coreBinds ++ specDefs srcF spec+ sigs = S.fromList $ M.keys sigm+ sigm = sigVars srcF is spec++-- | Add the specified signatures for vars-with-preserved-sigs,+-- whose bodies have been pruned from [CoreBind] into the "assumes"++assumeSpec :: M.HashMap Var LocSpecType -> TargetSpec -> TargetSpec+assumeSpec sigm sp = sp { gsSig = gsig { gsAsmSigs = M.toList $ M.union sigm assm } }+ where+ assm = M.fromList (gsAsmSigs gsig)+ gsig = gsSig sp++diffVars :: [Int] -> [Def] -> [Var]+diffVars ls defs' = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $+ go (L.sort ls) defs+ where+ defs = L.sort defs'+ go _ [] = []+ go [] _ = []+ go (i:is) (d:ds)+ | i < start d = go is (d:ds)+ | i > end d = go (i:is) ds+ | otherwise = binder d : go (i:is) ds++sigVars :: FilePath -> [Int] -> TargetSpec -> M.HashMap Var LocSpecType+sigVars srcF ls sp = M.fromList $ filter (ok . snd) $ specSigs sp+ where+ ok = not . isDiff srcF ls++globalDiff :: FilePath -> [Int] -> TargetSpec -> Bool+globalDiff srcF ls gspec = measDiff || invsDiff || dconsDiff+ where+ measDiff = any (isDiff srcF ls) (snd <$> gsMeas spec)+ invsDiff = any (isDiff srcF ls) (snd <$> gsInvariants spec)+ dconsDiff = any (isDiff srcF ls) [ atLoc ldc () | ldc <- gsDconsP (gsName gspec) ]+ spec = gsData gspec++isDiff :: FilePath -> [Int] -> Located a -> Bool+isDiff srcF ls x = file x == srcF && any hits ls+ where+ hits i = line x <= i && i <= lineE x++--------------------------------------------------------------------------------+-- | @thin cbs sp vs@ returns a subset of the @cbs :: [CoreBind]@ which+-- correspond to the definitions of @vs@ and the functions transitively+-- called therein for which there are *no* type signatures. Callees with+-- type signatures are assumed to satisfy those signatures.+--------------------------------------------------------------------------------++{- data ThinDeps = Trans [Var] -- ^ Check all transitive dependencies+ | None Var -- ^ Check only the given binders+ -}++--------------------------------------------------------------------------------+thin :: [CoreBind] -> TargetSpec -> [Var] -> DiffCheck+--------------------------------------------------------------------------------+-- thin cbs sp (Trans vs) = DC (thinWith S.empty cbs vs ) mempty sp+thin cbs sp vs = DC (filterBinds cbs vs') mempty sp'+ where+ vs' = txClosure (coreDeps cbs) xs (S.fromList vs)+ sp' = assumeSpec sigs' sp+ sigs' = foldr M.delete (M.fromList xts) vs+ xts = specSigs sp+ xs = S.fromList $ fst <$> xts++thinWith :: S.HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]+thinWith sigs cbs xs = filterBinds cbs calls+ where+ calls = txClosure cbDeps sigs (S.fromList xs)+ cbDeps = coreDeps cbs++coreDeps :: [CoreBind] -> Deps+coreDeps bs = mkGraph $ calls ++ calls'+ where+ calls = concatMap deps bs+ calls' = [(y, x) | (x, y) <- calls]+ deps b = [(x, y) | x <- bindersOf b+ , y <- freeVars S.empty b+ , S.member y defVars+ ]+ defVars = S.fromList (letVars bs)++-- | Given a call graph, and a list of vars, `dependsOn`+-- checks all functions to see if they call any of the+-- functions in the vars list.+-- If any do, then they must also be rechecked.++dependsOn :: Deps -> [Var] -> S.HashSet Var+dependsOn cg vars = S.fromList results+ where+ preds = map S.member vars+ filteredMaps = M.filter <$> preds <*> pure cg+ results = map fst $ M.toList $ M.unions filteredMaps++txClosure :: Deps -> S.HashSet Var -> S.HashSet Var -> S.HashSet Var+txClosure d sigs = go S.empty+ where+ next = S.unions . fmap deps . S.toList+ deps x = M.lookupDefault S.empty x d+ go seen new+ | S.null new = seen+ | otherwise = let seen' = S.union seen new+ new' = next new `S.difference` seen'+ new'' = new' `S.difference` sigs+ in go seen' new''++++--------------------------------------------------------------------------------+filterBinds :: [CoreBind] -> S.HashSet Var -> [CoreBind]+--------------------------------------------------------------------------------+filterBinds cbs ys = filter f cbs+ where+ f (NonRec x _) = x `S.member` ys+ f (Rec xes) = any (`S.member` ys) $ fst <$> xes+++--------------------------------------------------------------------------------+specDefs :: FilePath -> TargetSpec -> [Def]+--------------------------------------------------------------------------------+specDefs srcF = map def . filter sameFile . specSigs+ where+ def (x, t) = D (line t) (lineE t) x+ sameFile = (srcF ==) . file . snd++specSigs :: TargetSpec -> [(Var, LocSpecType)]+specSigs sp = gsTySigs (gsSig sp)+ ++ gsAsmSigs (gsSig sp)+ ++ gsCtors (gsData sp)++instance PPrint Def where+ pprintTidy _ d = text (show d)+++--------------------------------------------------------------------------------+coreDefs :: [CoreBind] -> [Def]+--------------------------------------------------------------------------------+coreDefs cbs = coreExprDefs xm xes+ where+ xes = coreVarExprs cbs+ xm = varBounds xes++coreExprDefs :: M.HashMap Var (Int, Int) -> [(Var, CoreExpr)]-> [Def]+coreExprDefs xm xes =+ L.sort+ [ D l l' x+ | (x, e) <- xes+ , (l, l') <- maybeToList $ coreExprDef xm (x, e)+ ]++coreExprDef :: M.HashMap Var (Int, Int) -> (Var, CoreExpr) -> Maybe (Int, Int)+coreExprDef m (x, e) = meetSpans eSp vSp+ where+ eSp = lineSpan x $ catSpans x $ exprSpans e+ vSp = M.lookup x m+ -- vSp = lineSpan x (getSrcSpan x)++coreVarExprs :: [CoreBind] -> [(Var, CoreExpr)]+coreVarExprs = filter ok . concatMap varExprs+ where+ ok = isGoodSrcSpan . getSrcSpan . fst++varExprs :: Bind a -> [(a, Expr a)]+varExprs (NonRec x e) = [(x, e)]+varExprs (Rec xes) = xes++-- | varBounds computes upper and lower bounds on where each top-level binder's+-- definition can be by using ONLY the lines where the binder is defined.+varBounds :: [(Var, CoreExpr)] -> M.HashMap Var (Int, Int)+varBounds = M.fromList . defBounds . varDefs++varDefs :: [(Var, CoreExpr)] -> [(Int, Var)]+varDefs xes =+ L.sort [ (l, x) | (x,_) <- xes, let Just (l, _) = lineSpan x (getSrcSpan x) ]++defBounds :: [(Int, Var)] -> [(Var, (Int, Int) )]+defBounds ((l, x) : lxs@((l', _) : _ )) = (x, (l, l' - 1)) : defBounds lxs+defBounds _ = []++{-+--------------------------------------------------------------------------------+coreDefs :: [CoreBind] -> [Def]+--------------------------------------------------------------------------------+coreDefs cbs = tracepp "coreDefs" $+ L.sort [D l l' x | b <- cbs+ , x <- bindersOf b+ , isGoodSrcSpan (getSrcSpan x)+ , (l, l') <- coreDef b]++coreDef :: CoreBind -> [(Int, Int)]+coreDef b+ | True = tracepp ("coreDef: " ++ showpp (vs, vSp)) $ maybeToList vSp+ | False = tracepp ("coreDef: " ++ showpp (b, eSp, vSp)) $ meetSpans b eSp vSp+ where+ eSp = lineSpan b $ catSpans b $ bindSpans b+ vSp = lineSpan b $ catSpans b $ getSrcSpan <$> vs+ vs = bindersOf b++meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)+meetSpans Nothing _+ = Nothing+meetSpans (Just (l,l')) Nothing+ = Just (l, l')+meetSpans (Just (l,l')) (Just (m,_))+ = Just (max l m, l')+-}+--------------------------------------------------------------------------------+-- | `meetSpans` cuts off the start-line to be no less than the line at which+-- the binder is defined. Without this, i.e. if we ONLY use the ticks and+-- spans appearing inside the definition of the binder (i.e. just `eSp`)+-- then the generated span can be WAY before the actual definition binder,+-- possibly due to GHC INLINE pragmas or dictionaries OR ...+-- for an example: see the "INCCHECK: Def" generated by+-- liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs+-- where `spanEnd` is a single line function around 1092 but where+-- the generated span starts mysteriously at 222 where Data.List is imported.++meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)+meetSpans Nothing _+ = Nothing+meetSpans (Just (l,l')) Nothing+ = Just (l, l')+meetSpans (Just (l,l')) (Just (m, m'))+ = Just (max l m, min l' m')++-- spanLower :: Maybe (Int, Int) -> Maybe Int -> Maybe (Int, Int)+-- spanLower Nothing _ = Nothing+-- spanLower sp Nothing = sp+-- spanLower (Just (l, l')) (Just m) = Just (max l m, l')++-- spanUpper :: Maybe (Int, Int) -> Maybe Int -> Maybe (Int, Int)+-- spanUpper Nothing _ = Nothing+-- spanUpper sp Nothing = sp+-- spanUpper (Just (l, l')) (Just m) = Just (l, min l' m)++++lineSpan :: t -> SrcSpan -> Maybe (Int, Int)+lineSpan _ (RealSrcSpan sp _) = Just (srcSpanStartLine sp, srcSpanEndLine sp)+lineSpan _ _ = Nothing++catSpans :: Var -> [SrcSpan] -> SrcSpan+catSpans b [] = panic Nothing $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b+catSpans b xs = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z _) <- xs, varFile b == srcSpanFile z]++-- bindFile+-- :: (Outputable r, NamedThing r) =>+-- Bind r -> FastString+-- bindFile (NonRec x _) = varFile x+-- bindFile (Rec xes) = varFile $ fst $ head xes++varFile :: (Outputable a, NamedThing a) => a -> FastString+varFile b = case getSrcSpan b of+ RealSrcSpan z _ -> srcSpanFile z+ _ -> panic Nothing $ "DIFFCHECK: getFile: no file found for: " ++ showPpr b+++bindSpans :: NamedThing a => Bind a -> [SrcSpan]+bindSpans (NonRec x e) = getSrcSpan x : exprSpans e+bindSpans (Rec xes) = map getSrcSpan xs ++ concatMap exprSpans es+ where+ (xs, es) = unzip xes++exprSpans :: NamedThing a => Expr a -> [SrcSpan]+exprSpans (Tick t e)+ | isJunkSpan sp = exprSpans e+ | otherwise = [sp]+ where+ sp = tickSrcSpan t++exprSpans (Var x) = [getSrcSpan x]+exprSpans (Lam x e) = getSrcSpan x : exprSpans e+exprSpans (App e a) = exprSpans e ++ exprSpans a+exprSpans (Let b e) = bindSpans b ++ exprSpans e+exprSpans (Cast e _) = exprSpans e+exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs+exprSpans _ = []++altSpans :: (NamedThing b) => Alt b -> [SrcSpan]+altSpans (Alt _ xs e) = map getSrcSpan xs ++ exprSpans e++isJunkSpan :: SrcSpan -> Bool+isJunkSpan RealSrcSpan{} = False+isJunkSpan _ = True++--------------------------------------------------------------------------------+-- | Diff Interface ------------------------------------------------------------+--------------------------------------------------------------------------------+-- | `lineDiff new old` compares the contents of `src` with `dst`+-- and returns the lines of `src` that are different.+--------------------------------------------------------------------------------+lineDiff :: FilePath -> FilePath -> IO ([Int], LMap)+--------------------------------------------------------------------------------+lineDiff new old = lineDiff' <$> getLines new <*> getLines old+ where+ getLines = fmap lines . readFile++lineDiff' :: [String] -> [String] -> ([Int], LMap)+lineDiff' new old = (changedLines, lm)+ where+ changedLines = diffLines 1 diffLineCount+ lm = foldr setShift IM.empty $ diffShifts diffLineCount+ diffLineCount = diffMap length <$> getGroupedDiff new old++diffMap :: (a -> b) -> Diff a -> Diff b+diffMap f (First x) = First (f x)+diffMap f (Second x) = Second (f x)+diffMap f (Both x y) = Both (f x) (f y)++-- | Identifies lines that have changed+diffLines :: Int -- ^ Starting line+ -> [Diff Int] -- ^ List of lengths of diffs+ -> [Int] -- ^ List of changed line numbers+diffLines _ [] = []+diffLines curr (Both lnsUnchgd _ : d) = diffLines toSkip d+ where toSkip = curr + lnsUnchgd+diffLines curr (First lnsChgd : d) = [curr..(toTake-1)] ++ diffLines toTake d+ where toTake = curr + lnsChgd+diffLines curr (_ : d) = diffLines curr d++diffShifts :: [Diff Int] -> [(Int, Int, Int)]+diffShifts = go 1 1+ where+ go old new (Both n _ : d) = (old, old + n - 1, new - old) : go (old + n)+ (new + n)+ d+ go old new (Second n : d) = go (old + n) new d+ go old new (First n : d) = go old (new + n) d+ go _ _ [] = []+++-- | @save@ creates an .saved version of the @target@ file, which will be+-- used to find what has changed the /next time/ @target@ is checked.+--------------------------------------------------------------------------------+saveResult :: FilePath -> Output Doc -> IO ()+--------------------------------------------------------------------------------+saveResult target res = do+ copyFile target saveF+ B.writeFile errF $ LB.toStrict $ encode res+ where+ saveF = extFileName Saved target+ errF = extFileName Cache target++--------------------------------------------------------------------------------+loadResult :: FilePath -> IO (Output Doc)+--------------------------------------------------------------------------------+loadResult f = do+ ex <- doesFileExist jsonF+ if ex+ then convert <$> B.readFile jsonF+ else return mempty+ where+ convert = fromMaybe mempty . decode . LB.fromStrict+ jsonF = extFileName Cache f++--------------------------------------------------------------------------------+adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc+--------------------------------------------------------------------------------+adjustOutput lm cm o = mempty { o_types = adjustTypes lm cm (o_types o) }+ { o_result = adjustResult lm cm (o_result o) }++adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a+adjustTypes lm cm (AI m) = AI $ if True then mempty else M.fromList -- FIXME PLEASE+ [(sp', v) | (sp, v) <- M.toList m+ , Just sp' <- [adjustSrcSpan lm cm sp]]++adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult+adjustResult lm cm (Unsafe s es) = errorsResult (Unsafe s) $ mapMaybe (adjustError lm cm) es+adjustResult lm cm (Crash es z) = errorsResult (`Crash` z) $ (, Nothing) <$>mapMaybe (adjustError lm cm . fst) es+adjustResult _ _ r = r++errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b+errorsResult _ [] = Safe mempty+errorsResult f es = f es++adjustError :: (PPrint (TError a)) => LMap -> ChkItv -> TError a -> Maybe (TError a)+adjustError lm cm e = case adjustSrcSpan lm cm (pos e) of+ Just sp' -> Just (e {pos = sp'})+ Nothing -> Nothing++--------------------------------------------------------------------------------+adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan+--------------------------------------------------------------------------------+adjustSrcSpan lm cm sp+ = do sp' <- adjustSpan lm sp+ if isCheckedSpan cm sp'+ then Nothing+ else Just sp'++isCheckedSpan :: IM.IntervalMap Int a -> SrcSpan -> Bool+isCheckedSpan cm (RealSrcSpan sp _) = isCheckedRealSpan cm sp+isCheckedSpan _ _ = False++isCheckedRealSpan :: IM.IntervalMap Int a -> RealSrcSpan -> Bool+isCheckedRealSpan cm = not . null . (`IM.search` cm) . srcSpanStartLine++adjustSpan :: LMap -> SrcSpan -> Maybe SrcSpan+adjustSpan lm (RealSrcSpan rsp _) = RealSrcSpan <$> adjustReal lm rsp <*> pure Nothing+adjustSpan _ sp = Just sp++adjustReal :: LMap -> RealSrcSpan -> Maybe RealSrcSpan+adjustReal lm rsp+ | Just δ <- sh = Just $ packRealSrcSpan f (l1 + δ) c1 (l2 + δ) c2+ | otherwise = Nothing+ where+ (f, l1, c1, l2, c2) = unpackRealSrcSpan rsp+ sh = getShift l1 lm+++-- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@+-- in the diff and returns @Nothing@ otherwise.+getShift :: Int -> LMap -> Maybe Int+getShift old = fmap snd . listToMaybe . IM.search old++-- | @setShift (lo, hi, δ) lm@ updates the interval map @lm@ appropriately+setShift :: (Int, Int, Int) -> LMap -> LMap+setShift (l1, l2, δ) = IM.insert (IM.Interval l1 l2) δ+++checkedItv :: [Def] -> ChkItv+checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is+ where+ is = [IM.Interval l1 l2 | D l1 l2 _ <- chDefs]+++--------------------------------------------------------------------------------+-- | Aeson instances -----------------------------------------------------------+--------------------------------------------------------------------------------++instance ToJSON SourcePos where+ toJSON p = object [ "sourceName" .= f+ , "sourceLine" .= unPos l+ , "sourceColumn" .= unPos c+ ]+ where+ f = sourceName p+ l = sourceLine p+ c = sourceColumn p++instance FromJSON SourcePos where+ parseJSON (Object v) = safeSourcePos <$> v .: "sourceName"+ <*> v .: "sourceLine"+ <*> v .: "sourceColumn"+ parseJSON _ = mempty++instance FromJSON ErrorResult++instance ToJSON Doc where+ toJSON = String . T.pack . render++instance FromJSON Doc where+ parseJSON (String s) = return $ text $ T.unpack s+ parseJSON _ = mempty++instance ToJSON a => ToJSON (AnnInfo a) where+ toJSON = genericToJSON defaultOptions+ toEncoding = genericToEncoding defaultOptions+instance FromJSON a => FromJSON (AnnInfo a)++instance ToJSON (Output Doc) where+ toJSON = genericToJSON defaultOptions+ toEncoding = genericToEncoding defaultOptions+instance FromJSON (Output Doc) where+ parseJSON = genericParseJSON defaultOptions++file :: Located a -> FilePath+file = sourceName . loc++line :: Located a -> Int+line = unPos . sourceLine . loc++lineE :: Located a -> Int+lineE = unPos . sourceLine . locE
+ src/Language/Haskell/Liquid/UX/Errors.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}++-- | This module contains the functions related to @Error@ type,+-- in particular, to @tidyError@ using a solution, and @pprint@ errors.++module Language.Haskell.Liquid.UX.Errors ( tidyError ) where++import Control.Arrow (second)+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 Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Transforms.Simplify+import Language.Haskell.Liquid.UX.Tidy+import Language.Haskell.Liquid.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++type Ctx = M.HashMap F.Symbol SpecType+type CtxM = M.HashMap F.Symbol (WithModel SpecType)++------------------------------------------------------------------------+tidyError :: Config -> F.FixSolution -> Error -> Error+------------------------------------------------------------------------+tidyError cfg sol+ = fmap (tidySpecType tidy)+ . tidyErrContext tidy sol+ where+ tidy = configTidy cfg++configTidy :: Config -> F.Tidy+configTidy cfg+ | shortNames cfg = F.Lossy+ | otherwise = F.Full++tidyErrContext :: F.Tidy -> F.FixSolution -> Error -> Error+tidyErrContext k _ e@(ErrSubType {})+ = e { ctx = c', tact = F.subst θ tA, texp = F.subst θ tE }+ where+ (θ, c') = tidyCtx k xs (ctx e)+ xs = F.syms tA ++ F.syms tE+ tA = tact e+ tE = texp e++tidyErrContext _ _ e@(ErrSubTypeModel {})+ = e { ctxM = c', tactM = fmap (F.subst θ) tA, texp = fmap (F.subst θ) tE }+ where+ (θ, c') = tidyCtxM xs $ ctxM e+ xs = F.syms tA ++ F.syms tE+ tA = tactM e+ tE = texp e++tidyErrContext k _ e@(ErrAssType {})+ = e { ctx = c', cond = F.subst θ p }+ where+ m = ctx e+ (θ, c') = tidyCtx k xs m+ xs = F.syms p+ p = cond e++tidyErrContext _ _ e+ = e++--------------------------------------------------------------------------------+tidyCtx :: F.Tidy -> [F.Symbol] -> Ctx -> (F.Subst, Ctx)+--------------------------------------------------------------------------------+tidyCtx k xs m = (θ1 `mappend` θ2, M.fromList yts)+ where+ yts = [tBind x (tidySpecType k t) | (x, t) <- xt2s]+ (θ2, xt2s) = tidyREnv xt1s+ (θ1, xt1s) = tidyTemps xts+ xts = sliceREnv xs m+ tBind x t = (x', shiftVV t x') where x' = F.tidySymbol x++tidyCtxM :: [F.Symbol] -> CtxM -> (F.Subst, CtxM)+tidyCtxM xs m = (θ, M.fromList yts)+ where+ yts = [tBind x t | (x, t) <- xts]+ (θ, xts) = tidyTemps $ second (fmap stripReft) <$> tidyREnvM xs m+ tBind x t = (x', fmap (`shiftVV` x') t) where x' = F.tidySymbol x++tidyREnv :: [(F.Symbol, SpecType)] -> (F.Subst, [(F.Symbol, SpecType)])+tidyREnv xts = (θ, second (F.subst θ) <$> zts)+ where+ θ = expandVarDefs yes+ (yes, zts) = Misc.mapEither isInline xts++-- | 'expandVarDefs [(x1, e1), ... ,(xn, en)] returns a `Subst` that +-- contains the fully substituted definitions for each `xi`. For example, +-- expandVarDefs [(x1, 'x2 + x3'), (x5, 'x1 + 1')] +-- should return +-- [x1 := 'x2 + x3, x5 := (x2 + x3) + 1]++expandVarDefs :: [(F.Symbol, F.Expr)] -> F.Subst+expandVarDefs = go mempty+ where+ go !su xes+ | null yes = su `mappend` F.mkSubst xes+ | otherwise = go (su `mappend` su') xes''+ where+ xes'' = [(z, F.subst su' e) | (z, e) <- zes]+ xs = S.fromList [x | (x, _) <- xes]+ su' = F.mkSubst yes+ (yes, zes) = L.partition (isDef xs . snd) xes+ 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' :: 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)+ where+ (t', ro) = stripRType t++stripReft :: SpecType -> SpecType+stripReft t = maybe t' (strengthen t') ro+ where+ (t', ro) = stripRType t++stripRType :: SpecType -> (SpecType, Maybe RReft)+stripRType st = (t', ro)+ where+ t' = fmap (const (uTop mempty)) t+ ro = stripRTypeBase t+ t = simplifyBounds st++sliceREnv :: [F.Symbol] -> Ctx -> [(F.Symbol, SpecType)]+sliceREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]+ where+ xs' = expandFix deps xs+ deps y = maybe [] (F.syms . rTypeReft) (M.lookup y m)+ ok = not . isFunTy++tidyREnvM :: [F.Symbol] -> CtxM -> [(F.Symbol, WithModel SpecType)]+tidyREnvM xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]+ where+ xs' = expandFix deps xs+ deps y = maybe [] (F.syms . rTypeReft . dropModel) (M.lookup y m)+ ok = not . isFunTy . dropModel++expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a]+expandFix f = S.toList . go S.empty+ where+ go seen [] = seen+ go seen (x:xs)+ | x `S.member` seen = go seen xs+ | otherwise = go (S.insert x seen) (f x ++ xs)++tidyTemps :: (F.Subable t) => [(F.Symbol, t)] -> (F.Subst, [(F.Symbol, t)])+tidyTemps xts = (θ, [(txB x, txTy t) | (x, t) <- xts])+ where+ txB x = M.lookupDefault x x m+ txTy = F.subst θ+ m = M.fromList yzs+ θ = F.mkSubst [(y, F.EVar z) | (y, z) <- yzs]+ yzs = zip ys niceTemps+ ys = [ x | (x,_) <- xts, GM.isTmpSymbol x]++niceTemps :: [F.Symbol]+niceTemps = mkSymbol <$> xs ++ ys+ where+ mkSymbol = F.symbol . ('?' :)+ xs = Misc.single <$> ['a' .. 'z']+ ys = ("a" ++) <$> [show n | n <- [(0::Int) ..]]
+ src/Language/Haskell/Liquid/UX/QuasiQuoter.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.UX.QuasiQuoter+-- (+-- -- * LiquidHaskell Specification QuasiQuoter+-- lq++-- -- * QuasiQuoter Annotations+-- , LiquidQuote(..)+-- ) + where++import Data.Data+import Data.List++import qualified Data.Text as T++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote++import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan)+import qualified Language.Fixpoint.Types as F++import Language.Haskell.Liquid.GHC.Misc (fSrcSpan)+import Liquid.GHC.API (SrcSpan)+import Language.Haskell.Liquid.Parse+import Language.Haskell.Liquid.Types++import System.IO+import Text.Megaparsec.Error++--------------------------------------------------------------------------------+-- LiquidHaskell Specification QuasiQuoter -------------------------------------+--------------------------------------------------------------------------------++lq :: QuasiQuoter+lq = QuasiQuoter+ { quoteExp = bad+ , quotePat = bad+ , quoteType = bad+ , quoteDec = lqDec+ }+ where+ -- FIME(adinapoli) Should we preserve 'fail' here?+ bad = error "`lq` quasiquoter can only be used as a top-level declaration"++lqDec :: String -> Q [Dec]+lqDec src = do+ pos <- locSourcePos <$> location+ case singleSpecP pos src of+ Left peb -> do+ runIO (hPutStrLn stderr (errorBundlePretty peb))+ fail "LH quasiquoter parse error"+ Right spec -> do+ prg <- pragAnnD ModuleAnnotation $+ conE 'LiquidQuote `appE` dataToExpQ' spec+ case mkSpecDecs spec of+ Left uerr ->+ throwErrorInQ uerr+ Right decs ->+ return $ prg : decs++throwErrorInQ :: UserError -> Q a+throwErrorInQ uerr =+ fail . showpp =<< runIO (errorsWithContext [uerr])++--------------------------------------------------------------------------------+-- Liquid Haskell to Template Haskell ------------------------------------------+--------------------------------------------------------------------------------++-- Spec to Dec -----------------------------------------------------------------++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)+mkSpecDecs (Asrts (names, (ty, _))) =+ (\t -> (`SigD` t) . symbolName <$> names)+ <$> simplifyBareType (head names) (quantifyFreeRTy $ val ty)+mkSpecDecs (Alias rta) =+ return . TySynD name tvs <$> simplifyBareType lsym (rtBody (val rta))+ where+ lsym = F.atLoc rta n+ name = symbolName n+ n = rtName (val rta)+ tvs = (\a -> PlainTV (symbolName a) ()) <$> rtTArgs (val rta)+mkSpecDecs _ =+ Right []++-- Symbol to TH Name -----------------------------------------------------------++symbolName :: Symbolic s => s -> Name+symbolName = mkName . symbolString . symbol++-- BareType to TH Type ---------------------------------------------------------++simplifyBareType :: LocSymbol -> BareType -> Either UserError Type+simplifyBareType s t = case simplifyBareType' t of+ Simplified t' ->+ Right t'+ FoundExprArg l ->+ Left $ ErrTySpec l Nothing (pprint $ val s) (pprint t)+ "Found expression argument in bad location in type"+ FoundHole ->+ Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint t)+ "Can't write LiquidHaskell type with hole in a quasiquoter"++simplifyBareType' :: BareType -> Simpl Type+simplifyBareType' = simplifyBareType'' ([], [])++simplifyBareType'' :: ([BTyVar], [BareType]) -> BareType -> Simpl Type++simplifyBareType'' ([], []) (RVar v _) =+ return $ VarT $ symbolName v+simplifyBareType'' ([], []) (RAppTy t1 t2 _) =+ AppT <$> simplifyBareType' t1 <*> simplifyBareType' t2+simplifyBareType'' ([], []) (RFun _ _ i o _) =+ (\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+ in foldl' AppT c' <$> sequenceA (filterExprArgs $ simplifyBareType' <$> as)++simplifyBareType'' _ (RExprArg e) =+ FoundExprArg $ fSrcSpan e+simplifyBareType'' _ (RHole _) =+ FoundHole++simplifyBareType'' s(RAllP _ t) =+ simplifyBareType'' s t+simplifyBareType'' s (RAllE _ _ t) =+ simplifyBareType'' s t+simplifyBareType'' s (REx _ _ t) =+ simplifyBareType'' s t+simplifyBareType'' s (RRTy _ _ _ t) =+ simplifyBareType'' s t++simplifyBareType'' (tvs, cls) (RFun _ _ i o _)+ | isClassType i = simplifyBareType'' (tvs, i : cls) o+simplifyBareType'' (tvs, cls) (RAllT tv t _) =+ simplifyBareType'' (ty_var_value tv : tvs, cls) t++simplifyBareType'' (tvs, cls) bt =+ ForallT ((\t -> PlainTV (symbolName t) SpecifiedSpec) <$> reverse tvs)+ <$> mapM simplifyBareType' (reverse cls)+ <*> simplifyBareType' bt+++data Simpl a = Simplified a+ | FoundExprArg SrcSpan+ | FoundHole+ deriving (Functor)++instance Applicative Simpl where+ pure = Simplified++ Simplified f <*> Simplified x = Simplified $ f x+ _ <*> FoundExprArg l = FoundExprArg l+ _ <*> FoundHole = FoundHole+ FoundExprArg l <*> _ = FoundExprArg l+ FoundHole <*> _ = FoundHole++instance Monad Simpl where+ Simplified x >>= f = f x+ FoundExprArg l >>= _ = FoundExprArg l+ FoundHole >>= _ = FoundHole++filterExprArgs :: [Simpl a] -> [Simpl a]+filterExprArgs = filter check+ where+ check (FoundExprArg _) = False+ check _ = True++--------------------------------------------------------------------------------+-- QuasiQuoter Annotations -----------------------------------------------------+--------------------------------------------------------------------------------++newtype LiquidQuote = LiquidQuote { liquidQuoteSpec :: BPspec }+ deriving (Data, Typeable)++--------------------------------------------------------------------------------+-- Template Haskell Utility Functions ------------------------------------------+--------------------------------------------------------------------------------++locSourcePos :: Loc -> SourcePos+locSourcePos loc =+ uncurry (safeSourcePos (loc_filename loc)) (loc_start loc)++dataToExpQ' :: Data a => a -> Q Exp+dataToExpQ' = dataToExpQ (const Nothing `extQ` textToExpQ)++textToExpQ :: T.Text -> Maybe ExpQ+textToExpQ text = Just $ varE 'T.pack `appE` stringE (T.unpack text)++extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q+extQ f g a = maybe (f a) g (cast a)+
+ src/Language/Haskell/Liquid/UX/SimpleVersion.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Haskell.Liquid.UX.SimpleVersion (simpleVersion) where++import Data.Version (Version, showVersion)+import GitHash (GitInfo, giDirty, giHash, tGitInfoCwdTry)+import Language.Haskell.TH (Exp, Q)+import qualified Language.Haskell.TH.Syntax as TH.Syntax+import qualified Language.Haskell.TH.Syntax.Compat as TH.Syntax.Compat++-- | Generate a string like @Version 1.2, Git revision 1234@.+--+-- @$(simpleVersion …)@ @::@ 'String'+-- Taken from <https://hackage.haskell.org/package/optparse-simple-0.1.1.4/docs/Options-Applicative-Simple.html#v:simpleVersion>+-- so we can drop the dependency on optparse-simple.+simpleVersion :: Version -> Q Exp+simpleVersion version =+ [|+ concat+ ( [ "Version ",+ $(TH.Syntax.lift $ showVersion version)+ ]+ ++ case $(TH.Syntax.Compat.unTypeSplice tGitInfoCwdTry) :: Either String GitInfo of+ Left _ -> []+ Right gi ->+ [ ", Git revision ",+ giHash gi,+ if giDirty gi then " (dirty)" else ""+ ]+ )+ |]
+ src/Language/Haskell/Liquid/UX/Tidy.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++---------------------------------------------------------------------+-- | This module contains functions for cleaning up types before+-- they are rendered, e.g. in error messages or annoations,+-- and also some PPrint instances that rely upon tidying.+---------------------------------------------------------------------++module Language.Haskell.Liquid.UX.Tidy (++ -- * Tidying functions+ tidySpecType+ , tidySymbol++ -- * Panic and Exit+ , panicError++ -- * Final result+ , Result (..)++ -- * Error to UserError+ , errorToUserError++ -- * MOVE TO TYPES+ , cinfoError+ ) where++import Data.Hashable+import Prelude hiding (error)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import qualified Data.List as L+import qualified Data.Text as T+import qualified Control.Exception as Ex+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.Types+import Language.Haskell.Liquid.Types.RefType (rVar, subsTyVarsMeet, FreeVar)+import Language.Haskell.Liquid.Types.PrettyPrint+import Data.Generics (everywhere, mkT)+import Text.PrettyPrint.HughesPJ+++------------------------------------------------------------------------+-- | Converting Results To Answers -------------------------------------+------------------------------------------------------------------------++class Result a where+ result :: a -> FixResult UserError++instance Result UserError where+ result e = Crash [(e, Nothing)] ""++instance Result [Error] where+ result es = Crash ([ (errorToUserError e, Nothing) | e <- es]) ""++instance Result Error where+ result e = result [e] -- Crash [pprint e] ""++instance Result (FixResult Cinfo) where+ result = fmap (errorToUserError . cinfoError)++errorToUserError :: Error -> UserError+errorToUserError = fmap ppSpecTypeErr++-- TODO: move to Types.hs+cinfoError :: Cinfo -> Error+cinfoError (Ci _ (Just e) _) = e+cinfoError (Ci l _ _) = ErrOther l (text $ "Cinfo: " ++ GM.showPpr l)++-------------------------------------------------------------------------+tidySpecType :: Tidy -> SpecType -> SpecType+-------------------------------------------------------------------------+tidySpecType k+ = tidyEqual+ . tidyValueVars+ . tidyDSymbols+ . tidySymbols k+ . tidyInternalRefas+ . tidyLocalRefas k+ . tidyFunBinds+ . tidyTyVars++tidyValueVars :: SpecType -> SpecType+tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u }++tidyVV :: Reft -> Reft+tidyVV r@(Reft (va,_))+ | isJunk va = shiftVV r v'+ | otherwise = r+ where+ v' = if v `elem` xs then symbol ("v'" :: T.Text) else v+ v = symbol ("v" :: T.Text)+ xs = syms r+ isJunk = isPrefixOfSym "x"++tidySymbols :: Tidy -> SpecType -> SpecType+tidySymbols k t = substa (shortSymbol k . tidySymbol) $ mapBind dropBind t+ where+ xs = S.fromList (syms t)+ dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol++shortSymbol :: Tidy -> Symbol -> Symbol+shortSymbol Lossy = GM.dropModuleNames+shortSymbol _ = id++tidyLocalRefas :: Tidy -> SpecType -> SpecType+tidyLocalRefas k = mapReft (txReft' k)+ where+ txReft' Full = id+ txReft' Lossy = txReft+ txReft u = u { ur_reft = mapPredReft dropLocals $ ur_reft u }+ dropLocals = pAnd . filter (not . any isTmp . syms) . conjuncts+ isTmp x = any (`isPrefixOfSym` x) [anfPrefix, "ds_"]++tidyEqual :: SpecType -> SpecType+tidyEqual = mapReft txReft+ where+ txReft u = u { ur_reft = mapPredReft dropInternals $ ur_reft u }+ dropInternals = pAnd . L.nub . conjuncts++tidyInternalRefas :: SpecType -> SpecType+tidyInternalRefas = mapReft txReft+ where+ txReft u = u { ur_reft = mapPredReft dropInternals $ ur_reft u }+ dropInternals = pAnd . filter (not . any isIntern . syms) . conjuncts+ isIntern x = "is$" `isPrefixOfSym` x || "$select" `isSuffixOfSym` x+++tidyDSymbols :: SpecType -> SpecType+tidyDSymbols t = mapBind tx $ substa tx t+ where+ tx = bindersTx [x | x <- syms t, isTmp x]+ isTmp = (tempPrefix `isPrefixOfSym`)++tidyFunBinds :: SpecType -> SpecType+tidyFunBinds t = mapBind tx $ substa tx t+ where+ tx = bindersTx $ filter GM.isTmpSymbol $ funBinds t++tidyTyVars :: SpecType -> SpecType+tidyTyVars t = subsTyVarsAll αβs t+ where+ αβs = zipWith (\α β -> (α, toRSort β, β)) αs βs+ αs = L.nub (tyVars t)+ βs = map (rVar . GM.stringTyVar) pool+ pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [(1::Int)..]]+++bindersTx :: [Symbol] -> Symbol -> Symbol+bindersTx ds = \y -> M.lookupDefault y y m+ where+ m = M.fromList $ zip ds $ var <$> [(1::Int)..]+ var = symbol . ('x' :) . show+++tyVars :: RType c tv r -> [tv]+tyVars (RAllP _ t) = tyVars t+tyVars (RAllT α t _) = ty_var_value α : tyVars t+tyVars (RFun _ _ t t' _) = tyVars t ++ tyVars t'+tyVars (RAppTy t t' _) = tyVars t ++ tyVars t'+tyVars (RApp _ ts _ _) = concatMap tyVars ts+tyVars (RVar α _) = [α]+tyVars (RAllE _ _ t) = tyVars t+tyVars (REx _ _ t) = tyVars t+tyVars (RExprArg _) = []+tyVars (RRTy _ _ _ t) = tyVars t+tyVars (RHole _) = []++subsTyVarsAll+ :: (Eq k, Hashable k,+ Reftable r, TyConable c, SubsTy k (RType c k ()) c,+ SubsTy k (RType c k ()) r,+ SubsTy k (RType c k ()) k,+ SubsTy k (RType c k ()) (RType c k ()),+ SubsTy k (RType c k ()) (RTVar k (RType c k ())),+ FreeVar c k)+ => [(k, RType c k (), RType c k r)] -> RType c k r -> RType c k r+subsTyVarsAll ats = go+ where+ abm = M.fromList [(a, b) | (a, _, RVar b _) <- ats]+ go (RAllT a t r) = RAllT (makeRTVar $ M.lookupDefault (ty_var_value a) (ty_var_value a) abm) (go t) r+ go t = subsTyVarsMeet ats t+++funBinds :: RType t t1 t2 -> [Symbol]+funBinds (RAllT _ t _) = funBinds t+funBinds (RAllP _ t) = funBinds t+funBinds (RFun b _ t1 t2 _) = b : funBinds t1 ++ funBinds t2+funBinds (RApp _ ts _ _) = concatMap funBinds ts+funBinds (RAllE b t1 t2) = b : funBinds t1 ++ funBinds t2+funBinds (REx b t1 t2) = b : funBinds t1 ++ funBinds t2+funBinds (RVar _ _) = []+funBinds (RRTy _ _ _ t) = funBinds t+funBinds (RAppTy t1 t2 _) = funBinds t1 ++ funBinds t2+funBinds (RExprArg _) = []+funBinds (RHole _) = []+++--------------------------------------------------------------------------------+-- | Show an Error, then crash+--------------------------------------------------------------------------------+panicError :: {-(?callStack :: CallStack) =>-} Error -> a+--------------------------------------------------------------------------------+panicError = Ex.throw++-- ^ This function is put in this module as it depends on the Exception instance,+-- which depends on the PPrint instance, which depends on tidySpecType.++--------------------------------------------------------------------------------+-- | Pretty Printing Error Messages --------------------------------------------+--------------------------------------------------------------------------------++-- | Need to put @PPrint Error@ instance here (instead of in Types),+-- as it depends on @PPrint SpecTypes@, which lives in this module.+++instance PPrint (CtxError Doc) where+ pprintTidy k ce = ppError k (ctCtx ce) $ ctErr ce++instance PPrint (CtxError SpecType) where+ pprintTidy k ce = ppError k (ctCtx ce) $ ppSpecTypeErr <$> ctErr ce++instance PPrint Error where+ pprintTidy k = ppError k empty . fmap ppSpecTypeErr++ppSpecTypeErr :: SpecType -> Doc+ppSpecTypeErr = ppSpecType Lossy++ppSpecType :: Tidy -> SpecType -> Doc+ppSpecType k = rtypeDoc k+ . tidySpecType k+ . fmap (everywhere (mkT noCasts))+ where+ noCasts (ECst x _) = x+ noCasts e = e++instance Show Error where+ show e = render (pprint (pos e) <+> pprint e)++instance Ex.Exception Error+instance Ex.Exception [Error]
+ src/Language/Haskell/Liquid/WiredIn.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Language.Haskell.Liquid.WiredIn+ ( wiredTyCons+ , wiredDataCons+ , wiredSortedSyms++ , charDataCon++ -- * Constants for automatic proofs+ , dictionaryVar+ , dictionaryTyVar+ , dictionaryBind+ , proofTyConName+ , combineProofsName++ -- * Built in symbols+ , isWiredIn+ , isWiredInName+ , dcPrefix++ -- * Deriving classes+ , isDerivedInstance+ ) where++import Prelude hiding (error)++-- import Language.Fixpoint.Misc (mapSnd)+import Language.Haskell.Liquid.GHC.Misc+import qualified Liquid.GHC.API as Ghc+import Liquid.GHC.API (Var, Arity, TyVar, Bind(..), Boxity(..), Expr(..), ArgFlag(..))+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 as F+import qualified Data.HashSet as S++import Language.Haskell.Liquid.GHC.TypeRep ()++-- | Horrible hack to support hardwired symbols like+-- `head`, `tail`, `fst`, `snd`+-- and other LH generated symbols that+-- *do not* correspond to GHC Vars and+-- *should not* be resolved to GHC Vars.++isWiredIn :: F.LocSymbol -> Bool+isWiredIn x = isWiredInLoc x || isWiredInName (val x) || isWiredInShape x++isWiredInLoc :: F.LocSymbol -> Bool+isWiredInLoc sym = ln == ln' && ln == F.safePos 1 && c == c' && c' == F.safePos 1+ where+ (ln , c) = spe (loc sym)+ (ln', c') = spe (locE sym)+ spe l = (x, y) where (_, x, y) = F.sourcePosElts l++isWiredInName :: F.Symbol -> Bool+isWiredInName x = x `S.member` wiredInNames++wiredInNames :: S.HashSet F.Symbol+wiredInNames = S.fromList [ "head", "tail", "fst", "snd", "len"]++isWiredInShape :: F.LocSymbol -> Bool+isWiredInShape x = any (`F.isPrefixOfSym` val x) [F.anfPrefix, F.tempPrefix, dcPrefix]+ -- where s = val x+ -- dcPrefix = "lqdc"++dcPrefix :: F.Symbol+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)+--------------------------------------------------------------------------------+-- | LH Primitive TyCons -------------------------------------------------------+--------------------------------------------------------------------------------++dictionaryVar :: Var+dictionaryVar = stringVar "tmp_dictionary_var" (Ghc.ForAllTy (Ghc.Bndr dictionaryTyVar Required) $ Ghc.TyVarTy dictionaryTyVar)++dictionaryTyVar :: TyVar+dictionaryTyVar = stringTyVar "da"++dictionaryBind :: Bind Var+dictionaryBind = Rec [(v, Lam a $ App (Var v) (Type $ Ghc.TyVarTy a))]+ where+ v = dictionaryVar+ a = dictionaryTyVar++-----------------------------------------------------------------------+-- | LH Primitive TyCons ----------------------------------------------+-----------------------------------------------------------------------+++combineProofsName :: String+combineProofsName = "combineProofs"++proofTyConName :: F.Symbol+proofTyConName = "Proof"++--------------------------------------------------------------------------------+-- | Predicate Types for WiredIns ----------------------------------------------+--------------------------------------------------------------------------------++maxArity :: Arity+maxArity = 7++wiredTyCons :: [TyConP]+wiredTyCons = fst wiredTyDataCons++wiredDataCons :: [Located DataConP]+wiredDataCons = snd wiredTyDataCons++wiredTyDataCons :: ([TyConP] , [Located DataConP])+wiredTyDataCons = (concat tcs, dummyLoc <$> concat dcs)+ where+ (tcs, dcs) = unzip $ listTyDataCons : map tupleTyDataCons [2..maxArity]++charDataCon :: Located DataConP+charDataCon = dummyLoc (DataConP l0 Ghc.charDataCon [] [] [] [("charX",lt)] lt False wiredInName l0)+ where+ l0 = F.dummyPos "LH.Bare.charTyDataCons"+ c = Ghc.charTyCon+ lt = rApp c [] [] mempty++listTyDataCons :: ([TyConP] , [DataConP])+listTyDataCons = ( [TyConP l0 c [RTV tyv] [p] [Covariant] [Covariant] (Just fsize)]+ , [DataConP l0 Ghc.nilDataCon [RTV tyv] [p] [] [] lt False wiredInName l0+ , DataConP l0 Ghc.consDataCon [RTV tyv] [p] [] cargs lt False wiredInName l0])+ where+ l0 = F.dummyPos "LH.Bare.listTyDataCons"+ c = Ghc.listTyCon+ [tyv] = tyConTyVarsDef c+ t = rVar tyv :: RSort+ 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)]+ 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")++wiredInName :: F.Symbol+wiredInName = "WiredIn"++tupleTyDataCons :: Int -> ([TyConP] , [DataConP])+tupleTyDataCons n = ( [TyConP l0 c (RTV <$> tyvs) ps tyvarinfo pdvarinfo Nothing]+ , [DataConP l0 dc (RTV <$> tyvs) ps [] cargs lt False wiredInName l0])+ where+ tyvarinfo = replicate n Covariant+ pdvarinfo = replicate (n-1) Covariant+ l0 = F.dummyPos "LH.Bare.tupleTyDataCons"+ c = Ghc.tupleTyCon Boxed n+ dc = Ghc.tupleDataCon Boxed n+ tyvs@(tv:tvs) = tyConTyVarsDef c+ (ta:ts) = (rVar <$> tyvs) :: [RSort]+ flds = mks "fld_Tuple"+ fld = "fld_Tuple"+ x1:xs = mks ("x_Tuple" ++ show n)+ ps = mkps pnames (ta:ts) ((fld, F.EVar fld) : zip flds (F.EVar <$> flds))+ ups = uPVar <$> ps+ 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+ pnames = mks_ "p"+ mks x = (\i -> F.symbol (x++ show i)) <$> [1..n]+ mks_ x = (\i -> F.symbol (x++ show i)) <$> [2..n]+++mkps :: [F.Symbol]+ -> [t] -> [(F.Symbol, F.Expr)] -> [PVar t]+mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] []+mkps _ _ _ = panic Nothing "Bare : mkps"++mkps_ :: [F.Symbol]+ -> [t]+ -> [(F.Symbol, F.Expr)]+ -> [(t, F.Symbol, F.Expr)]+ -> [PVar t]+ -> [PVar t]+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+ a = (t, f, x)+mkps_ _ _ _ _ _ = panic Nothing "Bare : mkps_"+++--------------------------------------------------------------------------------+isDerivedInstance :: Ghc.ClsInst -> Bool+--------------------------------------------------------------------------------+isDerivedInstance i = F.notracepp ("IS-DERIVED: " ++ F.showpp classSym)+ $ S.member classSym derivingClasses+ where+ classSym = F.symbol . Ghc.is_cls $ i++derivingClasses :: S.HashSet F.Symbol+derivingClasses = S.fromList+ [ "GHC.Classes.Eq"+ , "GHC.Classes.Ord"+ , "GHC.Enum.Enum"+ , "GHC.Show.Show"+ , "GHC.Read.Read"+ , "GHC.Base.Monad"+ , "GHC.Base.Applicative"+ , "GHC.Base.Functor"+ , "Data.Foldable.Foldable"+ , "Data.Traversable.Traversable"+ , "GHC.Real.Fractional"+ -- , "GHC.Enum.Bounded"+ -- , "GHC.Base.Monoid"+ ]
+ src/LiquidHaskellBoot.hs view
@@ -0,0 +1,9 @@+module LiquidHaskellBoot (+ -- * LiquidHaskell Specification QuasiQuoter+ lq+ -- * LiquidHaskell as a compiler plugin+ , plugin+ ) where++import Language.Haskell.Liquid.UX.QuasiQuoter+import Language.Haskell.Liquid.GHC.Plugin (plugin)
+ syntax/liquid.css view
@@ -0,0 +1,105 @@+.hs-linenum {+ color: #B2B2B2; + font-style: italic;+}++.hs-error {+ background-color: #FF8585 ;+}++.hs-keyglyph {+ color: #007020+}++.hs-keyword {+ color: #007020;+ // font-weight: bold;+}++.hs-comment, .hs-comment a {color: green;}++.hs-str, .hs-chr {color: teal;}++.hs-conid { + color: #902000; /* color: #00FFFF; color: #0E84B5; */+ //font-weight: bold; +}++.hs-definition { + color: #06287E + /* font-weight: bold; */ +}++.hs-varid, .hs-varop, .hs-layout {+ color: black; +}++.hs-num {+ color: #40A070;+}++.hs-conop {+ color: #902000; +}++.hs-cpp {+ color: orange;+}++.hs-sel {}++a.annot {+ position:relative; + color:#000;+ text-decoration:none; + white-space: pre; +}++a.annot:hover { + z-index:25; + background-color: #D8D8D8;+}++a.annot span.annottext{display: none}++a.annot:hover span.annottext{ + + border-radius: 5px 5px;+ + -moz-border-radius: 5px; + -webkit-border-radius: 5px; + + box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); + -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);+ -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); ++ white-space:pre;+ display:block;+ position: absolute; + left: 1em; top: 2em; + z-index: 99;+ margin-left: 5; + background: #FFFFAA; + border: 3px solid #FFAD33;+ padding: 0.8em 1em;+}++code {+ /* font-weight: bold; */+ background-color: rgb(250, 250, 250); + border: 1px solid rgb(200, 200, 200);+ padding-left: 4px;+ padding-right: 4px;+}++pre {+ background-color: #f0f0f0;+ border-top: 1px solid #ccc;+ border-bottom: 1px solid #ccc;+ padding: 5px;+ // font-size: 120%;+ // font-family: Bitstream Vera Sans Mono,monospace;+ display: block;+ overflow: visible;+}+
+ tests/Parser.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Simple test suite to test the parser.+--+-- Run as:+--+-- $ stack test :liquidhaskell-parser++module Main where++import Control.Monad (filterM, unless)+import Data.Data+import Data.Char (isSpace)+import Data.Generics.Aliases+import Data.Generics.Schemes++import Language.Fixpoint.Types.Spans+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++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Runners.AntXML++-- ---------------------------------------------------------------------++-- | 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')++tests :: TestTree -> TestTree+tests extra =+ testGroup "ParserTests"+ ([ 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+testSpecP =+ testGroup "specP"+ [ testCase "assume" $+ parseSingleSpec "assume foo :: a -> a " @?==+ "assume foo :: lq_tmp$db##0:a -> a"++ , testCase "assert" $+ parseSingleSpec "assert myabs :: Int -> PosInt" @?==+ "assert myabs :: lq_tmp$db##0:Int -> PosInt"++ , testCase "autosize" $+ 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"++ , testCase "reflect" $+ parseSingleSpec "reflect map" @?==+ "reflect map"++ , testCase "measure HMeas" $+ parseSingleSpec "measure isAbs" @?==+ "measure isAbs"++ , testCase "measure Meas" $+ 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"++ , testCase "infixr" $+ parseSingleSpec "infixr 9 +++" @?==+ "fixity"++ , testCase "infix" $+ parseSingleSpec "infix 9 +++" @?==+ "fixity"++ , testCase "inline" $+ parseSingleSpec "inline eqelems" @?==+ "inline eqelems"++ , testCase "bound PBound" $+ 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"++ , testCase "instance measure" $+ parseSingleSpec "instance measure sz :: MList a -> Int" @?==+ "instance measure sz :: lq_tmp$db##0:(MList a) -> Int"++ , testCase "instance" $+ parseSingleSpec "instance VerifiedNum Int where\n - :: x:Int -> y:Int -> OkInt {x - y} " @?==+ "instance (VerifiedNum Int) where\n - :: x:Int -> y:Int -> (OkInt {x - y})"++ , testCase "class" $+ 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"++ , testCase "data" $+ parseSingleSpec "data Bob = B {foo :: Int}" @?==+ "data Bob [] =\n | B :: forall . foo : Int -> *"++ , testCase "newtype" $+ 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}"++ , testCase "using" $+ parseSingleSpec "using (Tree a) as {v:Tree a | 0 <= height v}" @?==+ "using (Tree a) as {v : (Tree a) | 0 <= height v}"++ , testCase "type" $+ parseSingleSpec "type PosInt = {v: Int | v >= 0}" @?==+ "type PosInt = {v : Int | v >= 0}"++ , testCase "predicate" $+ parseSingleSpec "predicate Pos X = X > 0" @?==+ "predicate Pos X = X > 0"++ , testCase "expression" $+ parseSingleSpec "expression Avg Xs = ((sumD Xs) / (lenD Xs))" @?==+ "predicate Avg Xs = sumD Xs / lenD Xs"++ , testCase "embed" $+ parseSingleSpec "embed Set as Set_Set" @?==+ "embed Set as Set_Set"++ , testCase "qualif" $+ parseSingleSpec "qualif Foo(v:Int): v < 0" @?==+ "qualif Foo defined at <test>:1:8"++ , testCase "lazyvar" $+ parseSingleSpec "lazyvar z" @?==+ "lazyvar z"++ , testCase "lazy" $+ parseSingleSpec "lazy eval" @?==+ "lazy eval"++ , testCase "default parser (Asrts)" $+ parseSingleSpec " assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s]" @?==+ "assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [(OkPos t s)]"+ ]++-- ---------------------------------------------------------------------++-- Test that haskell functions having the same name as liquidhaskell keywords are parsed correctly+testReservedAliases :: TestTree+testReservedAliases =+ testGroup "reserved aliases"+ [ testCase "assume" $+ parseSingleSpec "assume :: Int -> Bool " @?==+ "assume :: lq_tmp$db##0:Int -> Bool"++ , testCase "assert" $+ parseSingleSpec "assert :: Int -> Bool " @?==+ "assert :: lq_tmp$db##0:Int -> Bool"++ , testCase "autosize" $+ parseSingleSpec "autosize :: Int -> Bool " @?==+ "autosize :: lq_tmp$db##0:Int -> Bool"++ , testCase "axiomatize" $+ parseSingleSpec "axiomatize :: Int -> Bool " @?==+ "axiomatize :: lq_tmp$db##0:Int -> Bool"++ , testCase "reflect" $+ parseSingleSpec "reflect :: Int -> Bool " @?==+ "reflect :: lq_tmp$db##0:Int -> Bool"++ , testCase "measure" $+ parseSingleSpec "measure :: Int -> Bool " @?==+ "measure :: lq_tmp$db##0:Int -> Bool"++ , testCase "define 1" $+ 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"++ , testCase "inline" $+ parseSingleSpec "inline :: Int -> Bool " @?==+ "inline :: lq_tmp$db##0:Int -> Bool"++ , testCase "bound" $+ parseSingleSpec "bound :: Int -> Bool " @?==+ "bound :: lq_tmp$db##0:Int -> Bool"++ , testCase "invariant" $+ parseSingleSpec "invariant :: Int -> Bool " @?==+ "invariant :: lq_tmp$db##0:Int -> Bool"++ , testCase "predicate" $+ parseSingleSpec "predicate :: Int -> Bool " @?==+ "predicate :: lq_tmp$db##0:Int -> Bool"++ , testCase "expression" $+ parseSingleSpec "expression :: Int -> Bool " @?==+ "expression :: lq_tmp$db##0:Int -> Bool"++ , testCase "embed" $+ parseSingleSpec "embed :: Int -> Bool " @?==+ "embed :: lq_tmp$db##0:Int -> Bool"++ , testCase "qualif" $+ parseSingleSpec "qualif :: Int -> Bool " @?==+ "qualif :: lq_tmp$db##0:Int -> Bool"+ ]++-- ---------------------------------------------------------------------++testSucceeds :: TestTree+testSucceeds =+ testGroup "Should succeed"+ [ testCase "x :: Int" $+ parseSingleSpec "x :: Int" @?==+ "x :: Int"++ , testCase "x :: a" $+ parseSingleSpec "x :: a" @?==+ "x :: a"++ , testCase "x :: a -> a" $+ parseSingleSpec "x :: a -> a" @?==+ "x :: lq_tmp$db##0:a -> a"++ , testCase "x :: Int -> Int" $+ parseSingleSpec "x :: Int -> Int" @?==+ "x :: lq_tmp$db##0:Int -> Int"++ , testCase "k:Int -> Int" $+ parseSingleSpec "x :: k:Int -> Int" @?==+ "x :: k:Int -> Int"++ , testCase "type spec 1 " $+ parseSingleSpec "type IncrListD a D = [a]<{\\x y -> (x+D) <= y}>" @?==+ "type IncrListD a D = [a]<\\x##2 VV -> {y##3 : LIQUID$dummy | x##2 + D <= y##3}>"++ , testCase "type spec 2 " $+ parseSingleSpec "takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}]" @?==+ "takeL :: (Ord a) -> x:a -> lq_tmp$db##1:[a] -> [{v : a | v <= x}]"++ , testCase "type spec 3" $+ parseSingleSpec "bar :: t 'Nothing" @?==+ "bar :: t Nothing"++ , testCase "type spec 4" $+ parseSingleSpec "mapKeysWith :: (Ord k2) => (a -> a -> a) -> (k1->k2) -> OMap k1 a -> OMap k2 a" @?==+ "mapKeysWith :: (Ord k2) -> lq_tmp$db##2:(lq_tmp$db##3:a -> lq_tmp$db##4:a -> a) -> lq_tmp$db##6:(lq_tmp$db##7:k1 -> k2) -> lq_tmp$db##9:(OMap k1 a) -> (OMap k2 a)"++ , testCase "type spec 5 " $+ parseSingleSpec (unlines $+ [ "data Tree [ht] a = Nil"+ , " | Tree { key :: a"+ , " , l :: Tree {v:a | v < key }"+ , " , r :: Tree {v:a | key < v }"+ , " }" ])+ @?==+ -- "data Tree [ht] [a] =\n | Tree :: forall a . key : a ->l : (Tree {v : a | v < key}) ->r : (Tree {v : a | key < v}) -> *\n | Nil :: forall a . -> *"+ "data Tree [ht] [a] = \+ \ | Nil :: forall a . -> * \+ \ | Tree :: forall a . key : a ->l : (Tree {v : a | v < key}) ->r : (Tree {v : a | key < v}) -> *"++ , testCase "type spec 6" $+ parseSingleSpec "type AVLL a X = AVLTree {v:a | v < X}" @?==+ "type AVLL a X = (AVLTree {v : a | v < X})"++ , testCase "type spec 7" $+ parseSingleSpec "type AVLR a X = AVLTree {v:a |X< v} " @?==+ "type AVLR a X = (AVLTree {v : a | X < v})"++ , testCase "type spec 8 " $+ parseSingleSpec (unlines $+ [ "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool>."+ , " {x::a<p> |- a<q> <: {v:a| x <= v}} "+ , " {a<p> <: a<r>} "+ , " {a<q> <: a<r>} "+ , " Ord a => OList (a<p>) -> OList (a<q>) -> OList a<r> "])+ @?==+ -- "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool> .\n (Ord a) =>\n {x :: {VV : a<p> | true} |- {VV : a<q> | true} <: {v : a | x <= v}} =>\n {|- {VV : a<p> | true} <: {VV : a<r> | true}} =>\n {|- {VV : a<q> | true} <: {VV : a<r> | true}} =>\n lq_tmp$db##13:(OList {VV : a<p> | true}) -> lq_tmp$db##15:(OList {VV : a<q> | true}) -> (OList {VV : a<r> | true})"+ (unlines+ [ "assume (++) :: forall <p##1##23 :: a -> Bool, q##1##23 :: a -> Bool, r##1##23 :: a -> Bool>."+ , " (Ord a) =>"+ , " {x :: {VV : a<p##1##23> | true} |- {VV : a<q##1##23> | true} <: {v : a | x <= v}} =>"+ , " {|- {VV : a<p##1##23> | true} <: {VV : a<r##1##23> | true}} =>"+ , " {|- {VV : a<q##1##23> | true} <: {VV : a<r##1##23> | true}} =>"+ , " lq_tmp$db##13:(OList {VV : a<p##1##23> | true}) -> lq_tmp$db##15:(OList {VV : a<q##1##23> | true}) -> (OList {VV : a<r##1##23> | true})"+ ])+ , testCase "type spec 9" $+ parseSingleSpec (unlines $+ [ "data AstF f <ix :: AstIndex -> Bool>"+ , " = Lit Int (i :: AstIndex<ix>)"+ , " | Var String (i :: AstIndex<ix>)"+ , " | App (fn :: f) (arg :: f)"+ , " | Paren (ast :: f)" ])+ @?==+ unlines+ [ "data AstF [f] ="+ , " | App :: forall f . fn : f ->arg : f -> *"+ , " | Lit :: forall f . lq_tmp$db##2 : Int ->i : (AstIndex <{VV : _<ix> | true}>) -> *"+ , " | Paren :: forall f . ast : f -> *"+ , " | Var :: forall f . lq_tmp$db##4 : String ->i : (AstIndex <{VV : _<ix> | true}>) -> *"+ ]++ , testCase "type spec 10" $+ parseSingleSpec "assume :: b:_ -> a -> {v:a | b} " @?==+ "assume :: b:{VV : _ | $HOLE} -> lq_tmp$db##0:a -> {v : a | b}"++ , testCase "type spec 11" $+ parseSingleSpec (unlines $+ [ "app :: forall <p :: Int -> Bool, q :: Int -> Bool>. "+ , " {Int<q> <: Int<p>}"+ , " {x::Int<q> |- {v:Int| v = x + 1} <: Int<q>}"+ , " (Int<p> -> ()) -> x:Int<q> -> ()" ])+ @?==+ -- "app :: forall <p :: Int -> Bool, q :: Int -> Bool> .\n {|- (Int <{VV : _<q> | true}>) <: (Int <{VV : _<p> | true}>)} =>\n {x :: (Int <{VV : _<q> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q> | true}>)} =>\n lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p> | true}>) -> ()) -> x:(Int <{VV : _<q> | true}>) -> ()"+ (unlines+ [ "app :: forall <p##1##15 :: Int -> Bool, q##1##15 :: Int -> Bool>."+ , " {|- (Int <{VV : _<q##1##15> | true}>) <: (Int <{VV : _<p##1##15> | true}>)} =>"+ , " {x :: (Int <{VV : _<q##1##15> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q##1##15> | true}>)} =>"+ , " lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p##1##15> | true}>) -> ()) -> x:(Int <{VV : _<q##1##15> | true}>) -> ()"+ ])++ , testCase "type spec 12" $+ parseSingleSpec (unlines $+ [ " ssum :: forall<p :: a -> Bool, q :: a -> Bool>. "+ , " {{v:a | v == 0} <: a<q>}"+ , " {x::a<p> |- {v:a | x <= v} <: a<q>}"+ , " xs:[{v:a<p> | 0 <= v}] -> {v:a<q> | len xs >= 0 && 0 <= v } "])+ @?==+ -- "ssum :: forall <p :: a -> Bool, q :: a -> Bool> .\n {|- {v : a | v == 0} <: {VV : a<q> | true}} =>\n {x :: {VV : a<p> | true} |- {v : a | x <= v} <: {VV : a<q> | true}} =>\n xs:[{v : a<p> | 0 <= v}] -> {v : a<q> | len xs >= 0\n && 0 <= v}"+ (unlines+ [ "ssum :: forall <p##1##16 :: a -> Bool, q##1##16 :: a -> Bool>."+ , " {|- {v : a | v == 0} <: {VV : a<q##1##16> | true}} =>"+ , " {x :: {VV : a<p##1##16> | true} |- {v : a | x <= v} <: {VV : a<q##1##16> | true}} =>"+ , " xs:[{v : a<p##1##16> | 0 <= v}] -> {v : a<q##1##16> | len xs >= 0"+ , " && 0 <= v}"+ ])+ , testCase "type spec 13" $+ -- removing duplicate conjuncts also affects the order in which the+ -- surviving conjuncts are returned+ parseSingleSpec (unlines $+ [ " predicate ValidChunk V XS N "+ , " = if len XS == 0 "+ , " then (len V == 0) "+ , " else (((1 < len XS && 1 < N) => (len V < len XS)) "+ , " && ((len XS <= N ) => len V == 1)) "])+ @?==+ unlines+ [ "predicate ValidChunk V XS N = "+ , " (not (len XS == 0) =>"+ , " (1 < N && 1 < len XS => len V < len XS)"+ , " && (len XS <= N => len V == 1)"+ , " )"+ , " && (len XS == 0 => len V == 0)"+ ]+++ , testCase "type spec 14" $+ parseSingleSpec "assume (=*=.) :: Arg a => f:(a -> b) -> g:(a -> b) -> (r:a -> {f r == g r}) -> {v:(a -> b) | f == g}" @?==+ "assume (=*=.) :: (Arg a) -> f:(lq_tmp$db##1:a -> b) -> g:(lq_tmp$db##3:a -> b) -> lq_tmp$db##5:(r:a -> {VV : _ | f r == g r}) -> lq_tmp$db##6:a -> b"++ , testCase "type spec 15" $+ parseSingleSpec "sort :: (Ord a) => xs:[a] -> OListN a {len xs}" @?==+ "sort :: (Ord a) -> xs:[a] -> (OListN a {len xs})"++ , testCase "type spec 16" $+ parseSingleSpec " ==. :: x:a -> y:{a| x == y} -> {v:b | v ~~ x && v ~~ y } " @?==+ "==. :: x:a -> y:{y : a | x == y} -> {v : b | v ~~ x\n && v ~~ y}"++ , testCase "type spec 17" $+ parseSingleSpec "measure snd :: (a,b) -> b" @?==+ "measure snd :: lq_tmp$db##0:(a, b) -> b"++ , testCase "type spec 18" $+ parseSingleSpec "returnST :: xState:a \n -> ST <{\\xs xa v -> (xa = xState)}> a s " @?==+ "returnST :: xState:a -> (ST <\\xs##1 xa##2 VV -> {v##3 : LIQUID$dummy | xa##2 == xState}> a s)"++ , testCase "type spec 19" $+ parseSingleSpec "makeq :: l:_ -> r:{ _ | size r <= size l + 1} -> _ " @?==+ "makeq :: l:{VV : _ | $HOLE} -> r:{r : _ | size r <= size l + 1} -> {VV : _ | $HOLE}"++ , testCase "type spec 21" $+ parseSingleSpec "newRGRef :: forall <p :: a -> Bool, r :: a -> a -> Bool >.\n e:a<p> ->\n e2:a<r e> ->\n f:(x:a<p> -> y:a<r x> -> {v:a<p> | (v = y)}) ->\n IO (RGRef <p, r> a)" @?==+ -- "newRGRef :: forall <p :: a -> Bool, r :: a a -> Bool> .\n e:{VV : a<p> | true} -> e2:{VV : a<r e> | true} -> f:(x:{VV : a<p> | true} -> y:{VV : a<r x> | true} -> {v : a<p> | v == y}) -> (IO (RGRef <{VV : _<p> | true}, {VV : _<r> | true}> a))"+ (unlines [ "newRGRef :: forall <p##1##20 :: a -> Bool, r##1##20 :: a a -> Bool>."+ , " e:{VV : a<p##1##20> | true} -> e2:{VV : a<r##1##20 e> | true} -> f:(x:{VV : a<p##1##20> | true} -> y:{VV : a<r##1##20 x> | true} -> {v : a<p##1##20> | v == y}) -> (IO (RGRef <{VV : _<p##1##20> | true}, {VV : _<r##1##20> | true}> a))"+ ]+ )+ , testCase "type spec 21" $+ parseSingleSpec "cycle :: {v: [a] | len(v) > 0 } -> [a]" @?==+ "cycle :: v:{v : [a] | len v > 0} -> [a]"++ , testCase "type spec 22" $+ parseSingleSpec "cons :: x:a -> _ -> {v:[a] | hd v = x} " @?==+ "cons :: x:a -> lq_tmp$db##0:{VV : _ | $HOLE} -> {v : [a] | hd v == x}"++ , testCase "type spec 23" $+ parseSingleSpec "set :: a:Vector a -> i:Idx a -> a -> {v:Vector a | vlen v = vlen a}" @?==+ "set :: a:(Vector a) -> i:(Idx a) -> lq_tmp$db##0:a -> {v : (Vector a) | vlen v == vlen a}"++ , testCase "type spec 24" $+ parseSingleSpec "assume GHC.Prim.+# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}" @?==+ "assume GHC.Prim.+# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v : GHC.Prim.Int# | v == x + y}"++ , testCase "type spec 25" $+ parseSingleSpec " measure isEVar " @?==+ "measure isEVar"++ , testCase "type spec 26" $+ parseSingleSpec (unlines $+ [ "data List a where"+ , " Nil :: List a "+ , " Cons :: listHead:a -> listTail:List a -> List a "])+ @?==+ "data List [a] =\n | Cons :: forall a . listHead : a ->listTail : (List a) -> (List a)\n | Nil :: forall a . -> (List a)"++ , testCase "type spec 27" $+ parseSingleSpec (unlines $+ [ "data List2 a b <p :: a -> Bool> where"+ , " Nil2 :: List2 a "+ , " Cons2 :: listHead:a -> listTail:List a -> List2 a b"])+ @?==+ "data List2 [a, b] = \+ \ | Cons2 :: forall a b . listHead : a ->listTail : (List a) -> (List2 a b) \+ \ | Nil2 :: forall a b . -> (List2 a)"++ , testCase "type spec 28" $+ parseSingleSpec (unlines $+ [ "data Ev :: Peano -> Prop where"+ , " EZ :: Prop (Ev Z)"+ , " ESS :: n:Peano -> Prop (Ev n) -> Prop (Ev (S (S n)))"+ ])+ @?==+ "data Ev [] =\n | ESS :: forall . n : Peano ->lq_tmp$db##4 : (Prop (Ev n)) -> (Prop (Ev (S (S n))))\n | EZ :: forall . -> (Prop (Ev Z))"++ , testCase "type spec 29" $+ parseSingleSpec (unlines $+ [ "measure fst :: (a,b) -> a"+ , " fst (a,b) = a"+ ])+ @?==+ "measure fst :: lq_tmp$db##0:(a, b) -> a\n fst ((,)a b) = a"+ ]++-- ---------------------------------------------------------------------++testFails :: TestTree+testFails =+ testGroup "Does fail"+ [ testCase "Maybe k:Int -> Int" $+ parseSingleSpec "x :: Maybe k:Int -> Int" @?==+ unlines+ [ "<test>:1:13:"+ , " |"+ , "1 | x :: Maybe k:Int -> Int"+ , " | ^"+ , "unexpected ':'"+ , "expecting \"->\", \"=>\", '/', bareTyArgP, end of input, mmonoPredicateP, or monoPredicateP"+ ]+ ]+++-- ---------------------------------------------------------------------++testErrorReporting :: TestTree+testErrorReporting =+ testGroup "Error reporting"+ [ testCase "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " $+ parseSingleSpec "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " @?==+ unlines+ [ "<test>:1:45:"+ , " |"+ , "1 | assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n "+ , " | ^"+ , "unexpected '('"+ , "expecting \"->\", \"=>\", end of input, mmonoPredicateP, or predicatesP"+ ]+ , testCase "Missing |" $+ parseSingleSpec "ff :: {v:Nat v >= 0 }" @?==+ unlines+ [ "<test>:1:17:"+ , " |"+ , "1 | ff :: {v:Nat v >= 0 }"+ , " | ^^"+ , "unexpected \">=\""+ , "expecting \"->\", \"<:\", \"=>\", '|', bareTyArgP, mmonoPredicateP, or monoPredicateP"+ ]+ ]++-- ---------------------------------------------------------------------++-- | Parse a single type signature containing LH refinements. To be+-- used in the REPL.+--+parseSingleSpec :: String -> String+parseSingleSpec src =+ case LH.singleSpecP (initialPos "<test>") src of+ Left err -> errorBundlePretty err+ Right res -> F.showpp res -- show (dummyLocs res)++gadtSpec :: String+gadtSpec = unlines+ [ "data Ev where"+ , " EZ :: {v:Ev | prop v = Ev Z}"+ , " | ESS :: n:Peano -> {v:Ev | prop v = Ev n} -> {v:Ev | prop v = Ev (S (S n)) }"+ ]++deSpace :: String -> String+deSpace = filter (not . isSpace)++(@?==) :: HasCallStack => String -> String -> Assertion+actual @?== expected =+ assertEqualModuloSpace expected actual++assertEqualModuloSpace :: HasCallStack => String -> String -> Assertion+assertEqualModuloSpace expected actual =+ unless (deSpace expected == deSpace actual) (assertFailure msg)+ where+ msg =+ "expected (modulo whitespace):\n" ++ unlines (map (" | " ++) (lines expected)) ++ "\n" +++ " but got (modulo whitespace):\n" ++ unlines (map (" | " ++) (lines actual))++------------------------------------------------------------------------++dummyLocs :: (Data a) => a -> a+dummyLocs = everywhere (mkT posToDummy)+ where+ posToDummy :: SourcePos -> SourcePos+ posToDummy _ = dummyPos "Fixpoint.Types.dummyLoc"++-- ---------------------------------------------------------------------