diff --git a/ghc-api-tests/GhcApiTests.hs b/ghc-api-tests/GhcApiTests.hs new file mode 100644 --- /dev/null +++ b/ghc-api-tests/GhcApiTests.hs @@ -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 diff --git a/include/CoreToLogic.lg b/include/CoreToLogic.lg new file mode 100644 --- /dev/null +++ b/include/CoreToLogic.lg @@ -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 diff --git a/liquidhaskell-boot.cabal b/liquidhaskell-boot.cabal new file mode 100644 --- /dev/null +++ b/liquidhaskell-boot.cabal @@ -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 +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 diff --git a/src-ghc/Liquid/GHC/API.hs b/src-ghc/Liquid/GHC/API.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Liquid/GHC/API.hs @@ -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) diff --git a/src-ghc/Liquid/GHC/API/Extra.hs b/src-ghc/Liquid/GHC/API/Extra.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Liquid/GHC/API/Extra.hs @@ -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 } diff --git a/src-ghc/Liquid/GHC/API/StableModule.hs b/src-ghc/Liquid/GHC/API/StableModule.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Liquid/GHC/API/StableModule.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Axiom.hs @@ -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" diff --git a/src/Language/Haskell/Liquid/Bare/Check.hs b/src/Language/Haskell/Liquid/Bare/Check.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Check.hs @@ -0,0 +1,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))) + + + diff --git a/src/Language/Haskell/Liquid/Bare/Class.hs b/src/Language/Haskell/Liquid/Bare/Class.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Class.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/DataType.hs @@ -0,0 +1,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) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Elaborate.hs @@ -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 . 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" diff --git a/src/Language/Haskell/Liquid/Bare/Expand.hs b/src/Language/Haskell/Liquid/Bare/Expand.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Expand.hs @@ -0,0 +1,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"] diff --git a/src/Language/Haskell/Liquid/Bare/Laws.hs b/src/Language/Haskell/Liquid/Bare/Laws.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Laws.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Measure.hs @@ -0,0 +1,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 + +-} + diff --git a/src/Language/Haskell/Liquid/Bare/Misc.hs b/src/Language/Haskell/Liquid/Bare/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Misc.hs @@ -0,0 +1,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 diff --git a/src/Language/Haskell/Liquid/Bare/Plugged.hs b/src/Language/Haskell/Liquid/Bare/Plugged.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Plugged.hs @@ -0,0 +1,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 diff --git a/src/Language/Haskell/Liquid/Bare/Resolve.hs b/src/Language/Haskell/Liquid/Bare/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Resolve.hs @@ -0,0 +1,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) diff --git a/src/Language/Haskell/Liquid/Bare/Slice.hs b/src/Language/Haskell/Liquid/Bare/Slice.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Slice.hs @@ -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 + } +-} + + diff --git a/src/Language/Haskell/Liquid/Bare/ToBare.hs b/src/Language/Haskell/Liquid/Bare/ToBare.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/ToBare.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Typeclass.hs b/src/Language/Haskell/Liquid/Bare/Typeclass.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Typeclass.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Types.hs b/src/Language/Haskell/Liquid/Bare/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare/Types.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Cabal.hs b/src/Language/Haskell/Liquid/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Cabal.hs @@ -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 () } diff --git a/src/Language/Haskell/Liquid/Constraint/Constraint.hs b/src/Language/Haskell/Liquid/Constraint/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Constraint.hs @@ -0,0 +1,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) diff --git a/src/Language/Haskell/Liquid/Constraint/Env.hs b/src/Language/Haskell/Liquid/Constraint/Env.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Env.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Fresh.hs b/src/Language/Haskell/Liquid/Constraint/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Fresh.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -0,0 +1,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 diff --git a/src/Language/Haskell/Liquid/Constraint/Init.hs b/src/Language/Haskell/Liquid/Constraint/Init.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Init.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Constraint/Monad.hs b/src/Language/Haskell/Liquid/Constraint/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Monad.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Qualifier.hs b/src/Language/Haskell/Liquid/Constraint/Qualifier.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Qualifier.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Relational.hs b/src/Language/Haskell/Liquid/Constraint/Relational.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Relational.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Split.hs b/src/Language/Haskell/Liquid/Constraint/Split.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Split.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Constraint/Template.hs b/src/Language/Haskell/Liquid/Constraint/Template.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Template.hs @@ -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 γ diff --git a/src/Language/Haskell/Liquid/Constraint/Termination.hs b/src/Language/Haskell/Liquid/Constraint/Termination.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Termination.hs @@ -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" diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs @@ -0,0 +1,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 diff --git a/src/Language/Haskell/Liquid/Constraint/Types.hs b/src/Language/Haskell/Liquid/Constraint/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint/Types.hs @@ -0,0 +1,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)) diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -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" diff --git a/src/Language/Haskell/Liquid/GHC/Logging.hs b/src/Language/Haskell/Liquid/GHC/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Logging.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -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 "" +srcSpanSourcePos (RealSrcSpan s _) = realSrcSpanSourcePos s + +srcSpanSourcePosE :: SrcSpan -> SourcePos +srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "" +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 diff --git a/src/Language/Haskell/Liquid/GHC/Play.hs b/src/Language/Haskell/Liquid/GHC/Play.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Play.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/GHC/Plugin.hs b/src/Language/Haskell/Liquid/GHC/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Plugin.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs b/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs @@ -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") + ] diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs b/src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs @@ -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-\-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). +-} diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/Types.hs b/src/Language/Haskell/Liquid/GHC/Plugin/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Plugin/Types.hs @@ -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 "" + 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 + } diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/Util.hs b/src/Language/Haskell/Liquid/GHC/Plugin/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Plugin/Util.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/GHC/Resugar.hs b/src/Language/Haskell/Liquid/GHC/Resugar.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Resugar.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/GHC/SpanStack.hs b/src/Language/Haskell/Liquid/GHC/SpanStack.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/SpanStack.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/GHC/TypeRep.hs b/src/Language/Haskell/Liquid/GHC/TypeRep.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/TypeRep.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/GHC/Types.hs b/src/Language/Haskell/Liquid/GHC/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GHC/Types.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/LawInstances.hs b/src/Language/Haskell/Liquid/LawInstances.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/LawInstances.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Liquid.hs b/src/Language/Haskell/Liquid/Liquid.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Liquid.hs @@ -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 + + diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Measure.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Misc.hs b/src/Language/Haskell/Liquid/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Misc.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Parse.hs b/src/Language/Haskell/Liquid/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Parse.hs @@ -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 . TYPE" +-- or +-- "forall x y . 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 diff --git a/src/Language/Haskell/Liquid/Termination/Structural.hs b/src/Language/Haskell/Liquid/Termination/Structural.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Termination/Structural.hs @@ -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 } diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs @@ -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 γ)} diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Transforms/Rec.hs b/src/Language/Haskell/Liquid/Transforms/Rec.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/Rec.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Transforms/RefSplit.hs b/src/Language/Haskell/Liquid/Transforms/RefSplit.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/RefSplit.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Transforms/Rewrite.hs b/src/Language/Haskell/Liquid/Transforms/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/Rewrite.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Transforms/Simplify.hs b/src/Language/Haskell/Liquid/Transforms/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Transforms/Simplify.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Types.hs b/src/Language/Haskell/Liquid/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/Bounds.hs b/src/Language/Haskell/Liquid/Types/Bounds.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Bounds.hs @@ -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)) diff --git a/src/Language/Haskell/Liquid/Types/Dictionaries.hs b/src/Language/Haskell/Liquid/Types/Dictionaries.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Dictionaries.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Types/Equality.hs b/src/Language/Haskell/Liquid/Types/Equality.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Equality.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/Errors.hs b/src/Language/Haskell/Liquid/Types/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Errors.hs @@ -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)) diff --git a/src/Language/Haskell/Liquid/Types/Fresh.hs b/src/Language/Haskell/Liquid/Types/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Fresh.hs @@ -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) [] diff --git a/src/Language/Haskell/Liquid/Types/Generics.hs b/src/Language/Haskell/Liquid/Types/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Generics.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/Literals.hs b/src/Language/Haskell/Liquid/Types/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Literals.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/Meet.hs b/src/Language/Haskell/Liquid/Types/Meet.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Meet.hs @@ -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 + +-} diff --git a/src/Language/Haskell/Liquid/Types/Names.hs b/src/Language/Haskell/Liquid/Types/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Names.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Types/PredType.hs b/src/Language/Haskell/Liquid/Types/PredType.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/PredType.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs @@ -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 "" + 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 diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/RefType.hs @@ -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

===> {v:Int | p v} + + which is fine, but also converts + + Field 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

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) diff --git a/src/Language/Haskell/Liquid/Types/Specs.hs b/src/Language/Haskell/Liquid/Types/Specs.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Specs.hs @@ -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 + } diff --git a/src/Language/Haskell/Liquid/Types/Types.hs b/src/Language/Haskell/Liquid/Types/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Types.hs @@ -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

Prop, q :: Int -> Prop, r :: a -> Prop> +-- = F (a -> b

) | Q (c -> a) | G (Int -> a) +-- +-- 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 . 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 diff --git a/src/Language/Haskell/Liquid/Types/Variance.hs b/src/Language/Haskell/Liquid/Types/Variance.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Variance.hs @@ -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 + diff --git a/src/Language/Haskell/Liquid/Types/Visitors.hs b/src/Language/Haskell/Liquid/Types/Visitors.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types/Visitors.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/ACSS.hs b/src/Language/Haskell/Liquid/UX/ACSS.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/ACSS.hs @@ -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 "%s%s" (escape ann) s +renderTypAnnot Nothing s = s + +renderErrAnnot :: (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1 +renderErrAnnot (Just _) s = printf "%s" s +renderErrAnnot Nothing s = s + +renderLinAnnot :: (Show t, PrintfArg t1, PrintfType t1) + => Maybe (t, Int) -> t1 -> t1 +renderLinAnnot (Just d) s = printf "%s: %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: +x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)} +NOWTRYTHIS +-} + + +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 diff --git a/src/Language/Haskell/Liquid/UX/Annotate.hs b/src/Language/Haskell/Liquid/UX/Annotate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/Annotate.hs @@ -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 + [ "" + , "" + , "" + , "" ++ title ++ "" + , "" + , cssHTML css + , "" + , "

" + , "Put mouse over identifiers to see inferred types" + ] + +htmlClose :: IsString a => a +htmlClose = "\n\n" + +cssHTML :: String -> String +cssHTML css = unlines + [ "" + , "" + , "" + ] + +------------------------------------------------------------------------------ +-- | 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 diff --git a/src/Language/Haskell/Liquid/UX/CTags.hs b/src/Language/Haskell/Liquid/UX/CTags.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/CTags.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/CmdLine.hs b/src/Language/Haskell/Liquid/UX/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/CmdLine.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/Config.hs b/src/Language/Haskell/Liquid/UX/Config.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/Config.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/DiffCheck.hs b/src/Language/Haskell/Liquid/UX/DiffCheck.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/DiffCheck.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/Errors.hs b/src/Language/Haskell/Liquid/UX/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/Errors.hs @@ -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) ..]] diff --git a/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs b/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs @@ -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) + diff --git a/src/Language/Haskell/Liquid/UX/SimpleVersion.hs b/src/Language/Haskell/Liquid/UX/SimpleVersion.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/SimpleVersion.hs @@ -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 +-- 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 "" + ] + ) + |] diff --git a/src/Language/Haskell/Liquid/UX/Tidy.hs b/src/Language/Haskell/Liquid/UX/Tidy.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/UX/Tidy.hs @@ -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] diff --git a/src/Language/Haskell/Liquid/WiredIn.hs b/src/Language/Haskell/Liquid/WiredIn.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/WiredIn.hs @@ -0,0 +1,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" + ] diff --git a/src/LiquidHaskellBoot.hs b/src/LiquidHaskellBoot.hs new file mode 100644 --- /dev/null +++ b/src/LiquidHaskellBoot.hs @@ -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) diff --git a/syntax/liquid.css b/syntax/liquid.css new file mode 100644 --- /dev/null +++ b/syntax/liquid.css @@ -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; +} + diff --git a/tests/Parser.hs b/tests/Parser.hs new file mode 100644 --- /dev/null +++ b/tests/Parser.hs @@ -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 " @?== + "include " + + , 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 :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

Bool, q :: a -> Bool, r :: a -> Bool>." + , " {x::a

|- a <: {v:a| x <= v}} " + , " {a

<: a} " + , " {a <: a} " + , " Ord a => OList (a

) -> OList (a) -> OList a "]) + @?== + -- "assume (++) :: forall

Bool, q :: a -> Bool, r :: a -> Bool> .\n (Ord a) =>\n {x :: {VV : a

| true} |- {VV : a | true} <: {v : a | x <= v}} =>\n {|- {VV : a

| true} <: {VV : a | true}} =>\n {|- {VV : a | true} <: {VV : a | true}} =>\n lq_tmp$db##13:(OList {VV : a

| true}) -> lq_tmp$db##15:(OList {VV : a | true}) -> (OList {VV : a | true})" + (unlines + [ "assume (++) :: forall Bool, q##1##23 :: a -> Bool, r##1##23 :: a -> Bool>." + , " (Ord a) =>" + , " {x :: {VV : a | true} |- {VV : a | true} <: {v : a | x <= v}} =>" + , " {|- {VV : a | true} <: {VV : a | true}} =>" + , " {|- {VV : a | true} <: {VV : a | true}} =>" + , " lq_tmp$db##13:(OList {VV : a | true}) -> lq_tmp$db##15:(OList {VV : a | true}) -> (OList {VV : a | true})" + ]) + , testCase "type spec 9" $ + parseSingleSpec (unlines $ + [ "data AstF f Bool>" + , " = Lit Int (i :: AstIndex)" + , " | Var String (i :: AstIndex)" + , " | 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 : _ | true}>) -> *" + , " | Paren :: forall f . ast : f -> *" + , " | Var :: forall f . lq_tmp$db##4 : String ->i : (AstIndex <{VV : _ | 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

Bool, q :: Int -> Bool>. " + , " {Int <: Int

}" + , " {x::Int |- {v:Int| v = x + 1} <: Int}" + , " (Int

-> ()) -> x:Int -> ()" ]) + @?== + -- "app :: forall

Bool, q :: Int -> Bool> .\n {|- (Int <{VV : _ | true}>) <: (Int <{VV : _

| true}>)} =>\n {x :: (Int <{VV : _ | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _ | true}>)} =>\n lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _

| true}>) -> ()) -> x:(Int <{VV : _ | true}>) -> ()" + (unlines + [ "app :: forall Bool, q##1##15 :: Int -> Bool>." + , " {|- (Int <{VV : _ | true}>) <: (Int <{VV : _ | true}>)} =>" + , " {x :: (Int <{VV : _ | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _ | true}>)} =>" + , " lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _ | true}>) -> ()) -> x:(Int <{VV : _ | true}>) -> ()" + ]) + + , testCase "type spec 12" $ + parseSingleSpec (unlines $ + [ " ssum :: forall

Bool, q :: a -> Bool>. " + , " {{v:a | v == 0} <: a}" + , " {x::a

|- {v:a | x <= v} <: a}" + , " xs:[{v:a

| 0 <= v}] -> {v:a | len xs >= 0 && 0 <= v } "]) + @?== + -- "ssum :: forall

Bool, q :: a -> Bool> .\n {|- {v : a | v == 0} <: {VV : a | true}} =>\n {x :: {VV : a

| true} |- {v : a | x <= v} <: {VV : a | true}} =>\n xs:[{v : a

| 0 <= v}] -> {v : a | len xs >= 0\n && 0 <= v}" + (unlines + [ "ssum :: forall Bool, q##1##16 :: a -> Bool>." + , " {|- {v : a | v == 0} <: {VV : a | true}} =>" + , " {x :: {VV : a | true} |- {v : a | x <= v} <: {VV : a | true}} =>" + , " xs:[{v : a | 0 <= v}] -> {v : a | 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

Bool, r :: a -> a -> Bool >.\n e:a

->\n e2:a ->\n f:(x:a

-> y:a -> {v:a

| (v = y)}) ->\n IO (RGRef a)" @?== + -- "newRGRef :: forall

Bool, r :: a a -> Bool> .\n e:{VV : a

| true} -> e2:{VV : a | true} -> f:(x:{VV : a

| true} -> y:{VV : a | true} -> {v : a

| v == y}) -> (IO (RGRef <{VV : _

| true}, {VV : _ | true}> a))" + (unlines [ "newRGRef :: forall Bool, r##1##20 :: a a -> Bool>." + , " e:{VV : a | true} -> e2:{VV : a | true} -> f:(x:{VV : a | true} -> y:{VV : a | true} -> {v : a | v == y}) -> (IO (RGRef <{VV : _ | true}, {VV : _ | 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

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 + [ ":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 + [ ":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 + [ ":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 "") 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" + +-- ---------------------------------------------------------------------