From 0099c8b9341158bfe8a0ad7e807350a6d150de06 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 9 Jun 2018 12:38:03 +0300 Subject: [PATCH 1/2] Allow aeson-1.3 --- liquidhaskell.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal index dc1776fa77..005f192081 100644 --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -134,9 +134,9 @@ Library , vector >= 0.10 , hashable >= 1.2 , unordered-containers >= 0.2 - , liquid-fixpoint >= 0.7.0.7 + , liquid-fixpoint >= 0.7.0.5 , located-base - , aeson >= 1.2 && < 1.3 + , aeson >= 1.2 && < 1.4 , bytestring >= 0.10 , fingertree >= 0.1 , Cabal >= 1.18 From d281dbc19c8a07b5cef7a7824b43a36dc33d6503 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 9 Jun 2018 17:34:02 +0300 Subject: [PATCH 2/2] all up to Liquid.Model --- cabal.project | 3 + liquid-fixpoint | 2 +- liquidhaskell.cabal | 10 +- .../Haskell/Liquid/Constraint/Generate.hs | 18 +- .../Haskell/Liquid/Constraint/Types.hs | 7 +- src/Language/Haskell/Liquid/Desugar/Check.hs | 393 ++- .../Haskell/Liquid/Desugar/Coverage.hs | 192 +- .../Haskell/Liquid/Desugar/Desugar.hs | 32 +- .../Haskell/Liquid/Desugar/DsArrows.hs | 85 +- .../Haskell/Liquid/Desugar/DsBinds.hs | 298 ++- .../Haskell/Liquid/Desugar/DsCCall.hs | 6 +- src/Language/Haskell/Liquid/Desugar/DsExpr.hs | 2209 +++++++++-------- .../Haskell/Liquid/Desugar/DsExpr.hs-boot | 14 +- .../Haskell/Liquid/Desugar/DsForeign.hs | 12 +- .../Haskell/Liquid/Desugar/DsGRHSs.hs | 24 +- .../Haskell/Liquid/Desugar/DsListComp.hs | 59 +- src/Language/Haskell/Liquid/Desugar/DsMeta.hs | 456 ++-- .../Haskell/Liquid/Desugar/DsMonad.hs | 44 +- .../Haskell/Liquid/Desugar/DsUsage.hs | 2 + .../Haskell/Liquid/Desugar/DsUtils.hs | 2009 +++++++-------- src/Language/Haskell/Liquid/Desugar/Match.hs | 179 +- .../Haskell/Liquid/Desugar/Match.hs-boot | 9 +- .../Haskell/Liquid/Desugar/MatchCon.hs | 16 +- .../Haskell/Liquid/Desugar/MatchLit.hs | 104 +- src/Language/Haskell/Liquid/Desugar/PmExpr.hs | 14 +- .../Haskell/Liquid/Desugar/StaticPtrTable.hs | 2 + src/Language/Haskell/Liquid/GHC/Interface.hs | 23 +- src/Language/Haskell/Liquid/GHC/Misc.hs | 2 +- src/Language/Haskell/Liquid/Measure.hs | 8 +- src/Language/Haskell/Liquid/Misc.hs | 4 +- .../Haskell/Liquid/Termination/Structural.hs | 14 +- src/Language/Haskell/Liquid/Types.hs | 79 +- src/Language/Haskell/Liquid/Types/Errors.hs | 24 +- .../Haskell/Liquid/Types/PrettyPrint.hs | 22 +- src/Language/Haskell/Liquid/Types/RefType.hs | 34 +- src/Test/Target/Util.hs | 2 +- updating-ghc.txt | 19 + 37 files changed, 3375 insertions(+), 3055 deletions(-) create mode 100644 updating-ghc.txt diff --git a/cabal.project b/cabal.project index 80d2fc3f05..6627e87da5 100644 --- a/cabal.project +++ b/cabal.project @@ -3,9 +3,12 @@ packages: . ./liquid-fixpoint + ./text-format package liquid-fixpoint flags: devel package liquidhaskell flags: devel + +with-compiler: ghc-8.4.3 diff --git a/liquid-fixpoint b/liquid-fixpoint index 342ebc329b..657c69c6ee 160000 --- a/liquid-fixpoint +++ b/liquid-fixpoint @@ -1 +1 @@ -Subproject commit 342ebc329b6e6dced80a8bc2079983b4ab02dc8f +Subproject commit 657c69c6ee43e55ffd5d26be7fdfb86eaeb53c89 diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal index 005f192081..06d20c64b4 100644 --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -68,7 +68,7 @@ Flag deterministic-profiling Executable liquid default-language: Haskell98 - Build-Depends: base >=4.8.1.0 && <5 + Build-Depends: base >=4.9.1.0 && <5 , ghc , ghc-boot , cmdargs @@ -108,9 +108,9 @@ Executable liquid Library Default-Language: Haskell98 - Build-Depends: base >=4.8.1.0 && <5 - , ghc == 8.2.2 - , ghc-boot == 8.2.2 + Build-Depends: base >=4.11.1.0 && <5 + , ghc == 8.4.3 + , ghc-boot == 8.4.3 , template-haskell >= 2.9 , time >= 1.4 , array >= 0.5 @@ -286,7 +286,7 @@ Library if flag(include) hs-source-dirs: devel if flag(devel) - ghc-options: -Werror +-- ghc-options: -Werror if flag(deterministic-profiling) cpp-options: -DDETERMINISTIC_PROFILING Default-Extensions: PatternGuards diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs index 4c0e5520d6..2f766010d3 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -43,7 +43,7 @@ import Name hiding (varName) import FastString (fastStringToByteString) import Unify import UniqSet (mkUniqSet) -import Text.PrettyPrint.HughesPJ hiding (first) +import Text.PrettyPrint.HughesPJ.Compat import Control.Monad.State import Data.Maybe (fromMaybe, catMaybes, isJust) import qualified Data.HashMap.Strict as M @@ -75,7 +75,7 @@ import Language.Haskell.Liquid.Types.Literals import Language.Haskell.Liquid.Constraint.Types import Language.Haskell.Liquid.Constraint.Constraint import Language.Haskell.Liquid.Transforms.Rec -import Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult) +import Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult) import Language.Haskell.Liquid.Bare.Misc (makeDataConChecker) -------------------------------------------------------------------------------- @@ -170,7 +170,7 @@ checkIndex (x, vs, t, index) where loc = getSrcSpan x ts = ty_args $ toRTypeRep $ unOCons $ unTemplate t - msg1 = ErrTermin loc [xd] ("No decreasing" <+> F.pprint index <> "-th argument on" <+> xd <+> "with" <+> (F.pprint vs)) + msg1 = ErrTermin loc [xd] ("No decreasing" <+> F.pprint index <-> "-th argument on" <+> xd <+> "with" <+> (F.pprint vs)) msg2 = ErrTermin loc [xd] "No decreasing parameter" xd = F.pprint x @@ -494,7 +494,7 @@ consBind isRec γ (x, e, Internal spect) -- 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 $ F.tracepp "consBind 2" $ Internal spect + return $ F.tracepp "consBind 2" $ Internal spect where explanation = "Cannot give singleton type to the function definition." @@ -543,7 +543,7 @@ extender γ (x, Assumed t) extender γ _ = return γ -data Template a +data Template a = Asserted a | Assumed a | Internal a @@ -552,11 +552,11 @@ data Template a deriving instance (Show a) => (Show (Template a)) -instance PPrint a => PPrint (Template a) where +instance PPrint a => PPrint (Template a) where pprintTidy k (Asserted t) = "Asserted" <+> pprintTidy k t pprintTidy k (Assumed t) = "Assumed" <+> pprintTidy k t pprintTidy k (Internal t) = "Internal" <+> pprintTidy k t - pprintTidy _ Unknown = "Unknown" + pprintTidy _ Unknown = "Unknown" unTemplate :: Template t -> t unTemplate (Asserted t) = t @@ -1171,9 +1171,9 @@ projectTypes (Just is) ts = mapM (projT is) (zip [0..] ts) 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 + where notLiteralReft = maybe mempty F.notExprReft . snd . literalConst (emb γ) - notDataConReft d | exactDC (getConfig γ) + 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" diff --git a/src/Language/Haskell/Liquid/Constraint/Types.hs b/src/Language/Haskell/Liquid/Constraint/Types.hs index 9294640ef9..03cb60cfb7 100644 --- a/src/Language/Haskell/Liquid/Constraint/Types.hs +++ b/src/Language/Haskell/Liquid/Constraint/Types.hs @@ -60,7 +60,7 @@ import SrcLoc import Unify (tcUnifyTy) import qualified TyCon as TC import qualified DataCon as DC -import Text.PrettyPrint.HughesPJ hiding (first) +import Text.PrettyPrint.HughesPJ.Compat import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import qualified Data.List as L @@ -117,7 +117,10 @@ data LConstraint = LC [[(F.Symbol, SpecType)]] instance Monoid LConstraint where mempty = LC [] - mappend (LC cs1) (LC cs2) = LC (cs1 ++ cs2) + mappend = (<>) + +instance Semigroup LConstraint where + LC cs1 <> LC cs2 = LC (cs1 ++ cs2) instance PPrint CGEnv where pprintTidy k = pprintTidy k . renv diff --git a/src/Language/Haskell/Liquid/Desugar/Check.hs b/src/Language/Haskell/Liquid/Desugar/Check.hs index ca3d061c7a..2b0d2b03a2 100644 --- a/src/Language/Haskell/Liquid/Desugar/Check.hs +++ b/src/Language/Haskell/Liquid/Desugar/Check.hs @@ -12,11 +12,18 @@ module Language.Haskell.Liquid.Desugar.Check ( checkSingle, checkMatches, isAnyPmCheckEnabled, -- See Note [Type and Term Equality Propagation] - genCaseTmCs1, genCaseTmCs2 + genCaseTmCs1, genCaseTmCs2, + + -- Pattern-match-specific type operations + pmIsClosedType, pmTopNormaliseType_maybe ) where import Language.Haskell.Liquid.Desugar.TmOracle +import Prelude hiding ((<>)) + +import Unify( tcMatchTy ) +import BasicTypes import DynFlags import HsSyn import TcHsSyn @@ -24,6 +31,7 @@ import Id import ConLike import Name import FamInstEnv +import TysPrim (tYPETyCon) import TysWiredIn import TyCon import SrcLoc @@ -39,9 +47,11 @@ import TcType (toTcType, isStringTy, isIntTy, isWordTy) import Bag import ErrUtils import Var (EvVar) +import TyCoRep import Type import UniqSupply import Language.Haskell.Liquid.Desugar.DsGRHSs (isTrueLHsExpr) +import Maybes ( expectJust ) import Data.List (find) import Data.Maybe (isJust, fromMaybe) @@ -49,6 +59,7 @@ import Control.Monad (forM, when, forM_) import Coercion import TcEvidence import IOEnv +import qualified Data.Semigroup as Semi import ListT (ListT(..), fold, select) @@ -89,36 +100,37 @@ liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk -- Pick the first match complete covered match or otherwise the "best" match. -- The best match is the one with the least uncovered clauses, ties broken --- by the number of inaccessible clauses followed by number of redudant --- clauses +-- by the number of inaccessible clauses followed by number of redundant +-- clauses. +-- +-- This is specified in the +-- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the +-- users' guide. If you update the implementation of this function, make sure +-- to update that section of the users' guide as well. getResult :: PmM PmResult -> DsM PmResult -getResult ls = do - res <- fold ls goM (pure Nothing) - case res of - Nothing -> panic "getResult is empty" - Just a -> return a +getResult ls + = do { res <- fold ls goM (pure Nothing) + ; case res of + Nothing -> panic "getResult is empty" + Just a -> return a } where goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult) - goM mpm dpm = do - pmr <- dpm - return $ go pmr mpm + goM mpm dpm = do { pmr <- dpm + ; return $ Just $ go pmr mpm } + -- Careful not to force unecessary results - go :: Maybe PmResult -> PmResult -> Maybe PmResult - go Nothing rs = Just rs - go old@(Just (PmResult prov rs (UncoveredPatterns us) is)) new + go :: Maybe PmResult -> PmResult -> PmResult + go Nothing rs = rs + go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new | null us && null rs && null is = old | otherwise = let PmResult prov' rs' (UncoveredPatterns us') is' = new - lr = length rs - lr' = length rs' - li = length is - li' = length is' - in case compare (length us) (length us') - `mappend` (compare li li') - `mappend` (compare lr lr') + in case compareLength us us' + `mappend` (compareLength is is') + `mappend` (compareLength rs rs') `mappend` (compare prov prov') of - GT -> Just new - EQ -> Just new + GT -> new + EQ -> new LT -> old go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new = panic "getResult: No inhabitation candidates" @@ -135,7 +147,7 @@ data PmPat :: PatTy -> * where , pm_con_dicts :: [EvVar] , pm_con_args :: [PmPat t] } -> PmPat t -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs - PmVar :: { pm_var_id :: Id } -> PmPat t + PmVar :: { pm_var_id :: Id } -> PmPat t PmLit :: { pm_lit_lit :: PmLit } -> PmPat t -- See Note [Literals in PmPat] PmNLit :: { pm_lit_id :: Id , pm_lit_not :: [PmLit] } -> PmPat 'VA @@ -181,11 +193,14 @@ instance Outputable Covered where -- Like the or monoid for booleans -- Covered = True, Uncovered = False +instance Semi.Semigroup Covered where + Covered <> _ = Covered + _ <> Covered = Covered + NotCovered <> NotCovered = NotCovered + instance Monoid Covered where mempty = NotCovered - Covered `mappend` _ = Covered - _ `mappend` Covered = Covered - NotCovered `mappend` NotCovered = NotCovered + mappend = (Semi.<>) data Diverged = Diverged | NotDiverged deriving Show @@ -194,11 +209,14 @@ instance Outputable Diverged where ppr Diverged = text "Diverged" ppr NotDiverged = text "NotDiverged" +instance Semi.Semigroup Diverged where + Diverged <> _ = Diverged + _ <> Diverged = Diverged + NotDiverged <> NotDiverged = NotDiverged + instance Monoid Diverged where mempty = NotDiverged - Diverged `mappend` _ = Diverged - _ `mappend` Diverged = Diverged - NotDiverged `mappend` NotDiverged = NotDiverged + mappend = (Semi.<>) -- | When we learned that a given match group is complete data Provenance = @@ -210,17 +228,20 @@ data Provenance = instance Outputable Provenance where ppr = text . show +instance Semi.Semigroup Provenance where + FromComplete <> _ = FromComplete + _ <> FromComplete = FromComplete + _ <> _ = FromBuiltin + instance Monoid Provenance where mempty = FromBuiltin - FromComplete `mappend` _ = FromComplete - _ `mappend` FromComplete = FromComplete - _ `mappend` _ = FromBuiltin + mappend = (Semi.<>) data PartialResult = PartialResult { - presultProvenence :: Provenance + presultProvenance :: Provenance -- keep track of provenance because we don't want -- to warn about redundant matches if the result - -- is contaiminated with a COMPLETE pragma + -- is contaminated with a COMPLETE pragma , presultCovered :: Covered , presultUncovered :: Uncovered , presultDivergent :: Diverged } @@ -230,14 +251,19 @@ instance Outputable PartialResult where = text "PartialResult" <+> ppr prov <+> ppr c <+> ppr d <+> ppr vsa + +instance Semi.Semigroup PartialResult where + (PartialResult prov1 cs1 vsa1 ds1) + <> (PartialResult prov2 cs2 vsa2 ds2) + = PartialResult (prov1 Semi.<> prov2) + (cs1 Semi.<> cs2) + (vsa1 Semi.<> vsa2) + (ds1 Semi.<> ds2) + + instance Monoid PartialResult where mempty = PartialResult mempty mempty [] mempty - (PartialResult prov1 cs1 vsa1 ds1) - `mappend` (PartialResult prov2 cs2 vsa2 ds2) - = PartialResult (prov1 `mappend` prov2) - (cs1 `mappend` cs2) - (vsa1 `mappend` vsa2) - (ds1 `mappend` ds2) + mappend = (Semi.<>) -- newtype ChoiceOf a = ChoiceOf [a] @@ -254,10 +280,10 @@ instance Monoid PartialResult where -- data PmResult = PmResult { - pmresultProvenance :: Provenance - , pmresultRedundant :: [Located [LPat Id]] - , pmresultUncovered :: UncoveredCandidates - , pmresultInaccessible :: [Located [LPat Id]] } + pmresultProvenance :: Provenance + , pmresultRedundant :: [Located [LPat GhcTc]] + , pmresultUncovered :: UncoveredCandidates + , pmresultInaccessible :: [Located [LPat GhcTc]] } -- | Either a list of patterns that are not covered, or their type, in case we -- have no patterns at hand. Not having patterns at hand can arise when @@ -290,7 +316,7 @@ uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) [] -} -- | Check a single pattern binding (let) -checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM () +checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM () checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p]) mb_pm_res <- tryM (getResult (checkSingle' locn var p)) @@ -299,7 +325,7 @@ checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do Right res -> dsPmWarn dflags ctxt res -- | Check a single pattern binding (let) -checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult +checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult checkSingle' locn var p = do liftD resetPmIterDs -- set the iter-no to zero fam_insts <- liftD dsGetFamInstEnvs @@ -317,7 +343,7 @@ checkSingle' locn var p = do -- | Check a matchgroup (case, functions, etc.) checkMatches :: DynFlags -> DsMatchContext - -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM () + -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM () checkMatches dflags ctxt vars matches = do tracePmD "checkMatches" (hang (vcat [ppr ctxt , ppr vars @@ -335,7 +361,7 @@ checkMatches dflags ctxt vars matches = do -- | Check a matchgroup (case, functions, etc.). To be called on a non-empty -- list of matches. For empty case expressions, use checkEmptyCase' instead. -checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult +checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult checkMatches' vars matches | null matches = panic "checkMatches': EmptyCase" | otherwise = do @@ -349,11 +375,11 @@ checkMatches' vars matches , pmresultUncovered = UncoveredPatterns us , pmresultInaccessible = map hsLMatchToLPats ds } where - go :: [LMatch Id (LHsExpr Id)] -> Uncovered + go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered -> PmM (Provenance - , [LMatch Id (LHsExpr Id)] + , [LMatch GhcTc (LHsExpr GhcTc)] , Uncovered - , [LMatch Id (LHsExpr Id)]) + , [LMatch GhcTc (LHsExpr GhcTc)]) go [] missing = return (mempty, [], missing, []) go (m:ms) missing = do tracePm "checMatches': go" (ppr m $$ ppr missing) @@ -373,7 +399,7 @@ checkMatches' vars matches (NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is) hsLMatchToLPats :: LMatch id body -> Located [LPat id] - hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats + hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats -- | Check an empty case expression. Since there are no clauses to process, we -- only compute the uncovered set. See Note [Checking EmptyCase Expressions] @@ -407,10 +433,151 @@ checkEmptyCase' var = do else PmResult FromBuiltin [] uncovered [] Nothing -> return emptyPmResult +-- | Returns 'True' if the argument 'Type' is a fully saturated application of +-- a closed type constructor. +-- +-- Closed type constructors are those with a fixed right hand side, as +-- opposed to e.g. associated types. These are of particular interest for +-- pattern-match coverage checking, because GHC can exhaustively consider all +-- possible forms that values of a closed type can take on. +-- +-- Note that this function is intended to be used to check types of value-level +-- patterns, so as a consequence, the 'Type' supplied as an argument to this +-- function should be of kind @Type@. +pmIsClosedType :: Type -> Bool +pmIsClosedType ty + = case splitTyConApp_maybe ty of + Just (tc, _ty_args) + | is_algebraic_like tc && not (isFamilyTyCon tc) + -> True + _other -> False + where + -- This returns True for TyCons which /act like/ algebraic types. + -- (See "Type#type_classification" for what an algebraic type is.) + -- + -- This is qualified with \"like\" because of a particular special + -- case: TYPE (the underlyind kind behind Type, among others). TYPE + -- is conceptually a datatype (and thus algebraic), but in practice it is + -- a primitive builtin type, so we must check for it specially. + -- + -- NB: it makes sense to think of TYPE as a closed type in a value-level, + -- pattern-matching context. However, at the kind level, TYPE is certainly + -- not closed! Since this function is specifically tailored towards pattern + -- matching, however, it's OK to label TYPE as closed. + is_algebraic_like :: TyCon -> Bool + is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon + +pmTopNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Type, [DataCon], Type) +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- +-- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a +-- coercion, it returns useful information for issuing pattern matching +-- warnings. See Note [Type normalisation for EmptyCase] for details. +pmTopNormaliseType_maybe env typ + = do ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ + return (eq_src_ty ty (typ : ty_f [ty]), tm_f [], ty) + where + -- Find the first type in the sequence of rewrites that is a data type, + -- newtype, or a data family application (not the representation tycon!). + -- This is the one that is equal (in source Haskell) to the initial type. + -- If none is found in the list, then all of them are type family + -- applications, so we simply return the last one, which is the *simplest*. + eq_src_ty :: Type -> [Type] -> Type + eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys) + + is_closed_or_data_family :: Type -> Bool + is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty + + -- For efficiency, represent both lists as difference lists. + -- comb performs the concatenation, for both lists. + comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2) + + stepper = newTypeStepper `composeSteppers` tyFamStepper + + -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into + -- a loop. If it would fall into a loop, it produces 'NS_Abort'. + newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon]) + newTypeStepper rec_nts tc tys + | Just (ty', _co) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> let tyf = ((TyConApp tc tys):) + tmf = ((tyConSingleDataCon tc):) + in NS_Step rec_nts' ty' (tyf, tmf) + Nothing -> NS_Abort + | otherwise + = NS_Done + + tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon]) + tyFamStepper rec_nts tc tys -- Try to step a type/data family + = let (_args_co, ntys) = normaliseTcArgs env Representational tc tys in + -- NB: It's OK to use normaliseTcArgs here instead of + -- normalise_tc_args (which takes the LiftingContext described + -- in Note [Normalising types]) because the reduceTyFamApp below + -- works only at top level. We'll never recur in this function + -- after reducing the kind of a bound tyvar. + + case reduceTyFamApp_maybe env Representational tc ntys of + Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id) + _ -> NS_Done + +{- Note [Type normalisation for EmptyCase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +EmptyCase is an exception for pattern matching, since it is strict. This means +that it boils down to checking whether the type of the scrutinee is inhabited. +Function pmTopNormaliseType_maybe gets rid of the outermost type function/data +family redex and newtypes, in search of an algebraic type constructor, which is +easier to check for inhabitation. + +It returns 3 results instead of one, because there are 2 subtle points: +1. Newtypes are isomorphic to the underlying type in core but not in the source + language, +2. The representational data family tycon is used internally but should not be + shown to the user + +Hence, if pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty), then + (a) src_ty is the rewritten type which we can show to the user. That is, the + type we get if we rewrite type families but not data families or + newtypes. + (b) dcs is the list of data constructors "skipped", every time we normalise a + newtype to it's core representation, we keep track of the source data + constructor. + (c) core_ty is the rewritten type. That is, + pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty) + implies + topNormaliseType_maybe env ty = Just (co, core_ty) + for some coercion co. + +To see how all cases come into play, consider the following example: + + data family T a :: * + data instance T Int = T1 | T2 Bool + -- Which gives rise to FC: + -- data T a + -- data R:TInt = T1 | T2 Bool + -- axiom ax_ti : T Int ~R R:TInt + + newtype G1 = MkG1 (T Int) + newtype G2 = MkG2 G1 + + type instance F Int = F Char + type instance F Char = G2 + +In this case pmTopNormaliseType_maybe env (F Int) results in + + Just (G2, [MkG2,MkG1], R:TInt) + +Which means that in source Haskell: + - G2 is equivalent to F Int (in contrast, G1 isn't). + - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int). +-} + -- | Generate all inhabitation candidates for a given type. The result is -- either (Left ty), if the type cannot be reduced to a closed algebraic type -- (or if it's one trivially inhabited, like Int), or (Right candidates), if it --- can. In this case, the candidates are the singnature of the tycon, each one +-- can. In this case, the candidates are the signature of the tycon, each one -- accompanied by the term- and type- constraints it gives rise to. -- See also Note [Checking EmptyCase Expressions] inhabitationCandidates :: FamInstEnvs -> Type @@ -440,7 +607,8 @@ inhabitationCandidates fam_insts ty (_:_) -> do var <- liftD $ mkPmId (toTcType core_ty) let va = build_tm (PmVar var) dcs return $ Right [(va, mkIdEq var, emptyBag)] - | isClosedAlgType core_ty -> liftD $ do + + | pmIsClosedType core_ty -> liftD $ do var <- mkPmId (toTcType core_ty) -- it would be wrong to unify x alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc) return $ Right [(build_tm va dcs, eq, cs) | (va, eq, cs) <- alts] @@ -545,14 +713,14 @@ mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon {-# INLINE mkListPatVec #-} -- | Create a (non-overloaded) literal pattern -mkLitPattern :: HsLit -> Pattern +mkLitPattern :: HsLit GhcTc -> Pattern mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit } {-# INLINE mkLitPattern #-} -- ----------------------------------------------------------------------- -- * Transform (Pat Id) into of (PmPat Id) -translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec +translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec translatePat fam_insts pat = case pat of WildPat ty -> mkPmVars [ty] VarPat id -> return [PmVar (unLoc id)] @@ -578,7 +746,7 @@ translatePat fam_insts pat = case pat of | otherwise -> do ps <- translatePat fam_insts p (xp,xe) <- mkPmId2Forms ty - let g = mkGuard ps (HsWrap wrapper (unLoc xe)) + let g = mkGuard ps (mkHsWrap wrapper (unLoc xe)) return [xp,g] -- (n + k) ===> x (True <- x >= k) (n <- x-k) @@ -662,30 +830,36 @@ translatePat fam_insts pat = case pat of -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs) translateNPat :: FamInstEnvs - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec + -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type + -> DsM PatVec translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg = translatePat fam_insts (LitPat (HsString src s)) - | not type_change, isIntTy ty, HsIntegral src i <- val - = translatePat fam_insts (mk_num_lit HsInt src i) - | not type_change, isWordTy ty, HsIntegral src i <- val - = translatePat fam_insts (mk_num_lit HsWordPrim src i) + | not type_change, isIntTy ty, HsIntegral i <- val + = translatePat fam_insts + (LitPat $ case mb_neg of + Nothing -> HsInt def i + Just _ -> HsInt def (negateIntegralLit i)) + | not type_change, isWordTy ty, HsIntegral i <- val + = translatePat fam_insts + (LitPat $ case mb_neg of + Nothing -> HsWordPrim (il_text i) (il_value i) + Just _ -> let ni = negateIntegralLit i in + HsWordPrim (il_text ni) (il_value ni)) where type_change = not (outer_ty `eqType` ty) - mk_num_lit c src i = LitPat $ case mb_neg of - Nothing -> c src i - Just _ -> c src (-i) + translateNPat _ ol mb_neg _ = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }] -- | Translate a list of patterns (Note: each pattern is translated -- to a pattern vector but we do not concatenate the results). -translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec] +translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec] translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats -- | Translate a constructor pattern translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar] - -> ConLike -> HsConPatDetails Id -> DsM PatVec + -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps) = concat <$> translatePatVec fam_insts (map unLoc ps) translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2) @@ -739,13 +913,14 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _)) | otherwise = subsetOf (x:xs) ys -- Translate a single match -translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec]) -translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do +translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc) + -> DsM (PatVec,[PatVec]) +translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do pats' <- concat <$> translatePatVec fam_insts pats guards' <- mapM (translateGuards fam_insts) guards return (pats', guards') where - extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id] + extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] extractGuards (L _ (GRHS gs _)) = map unLoc gs pats = map unLoc lpats @@ -755,7 +930,7 @@ translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do -- * Transform source guards (GuardStmt Id) to PmPats (Pattern) -- | Translate a list of guard statements to a pattern vector -translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec +translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec translateGuards fam_insts guards = do all_guards <- concat <$> mapM (translateGuard fam_insts) guards return (replace_unhandled all_guards) @@ -795,7 +970,7 @@ cantFailPattern (PmGrd pv _e) cantFailPattern _ = False -- | Translate a guard statement to Pattern -translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec +translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec translateGuard fam_insts guard = case guard of BodyStmt e _ _ _ -> translateBoolGuard e LetStmt binds -> translateLet (unLoc binds) @@ -807,17 +982,17 @@ translateGuard fam_insts guard = case guard of ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt" -- | Translate let-bindings -translateLet :: HsLocalBinds Id -> DsM PatVec +translateLet :: HsLocalBinds GhcTc -> DsM PatVec translateLet _binds = return [] -- | Translate a pattern guard -translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec +translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec translateBind fam_insts (L _ p) e = do ps <- translatePat fam_insts p return [mkGuard ps (unLoc e)] -- | Translate a boolean guard -translateBoolGuard :: LHsExpr Id -> DsM PatVec +translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec translateBoolGuard e | isJust (isTrueLHsExpr e) = return [] -- The formal thing to do would be to generate (True <- True) @@ -964,14 +1139,14 @@ mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar) -- ComplexEq: x ~ K y1..yn -- [EvVar]: Q mkOneConFull x con = do - let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys - res_ty = idType x - (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _) + let res_ty = idType x + (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty) = conLikeFullSig con - tc_args = case splitTyConApp_maybe res_ty of - Just (_, tys) -> tys - Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty) - subst1 = zipTvSubst univ_tvs tc_args + tc_args = tyConAppArgs res_ty + subst1 = case con of + RealDataCon {} -> zipTvSubst univ_tvs tc_args + PatSynCon {} -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty) + -- See Note [Pattern synonym result type] in PatSyn (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM @@ -991,7 +1166,7 @@ mkOneConFull x con = do -- * More smart constructors and fresh variable generation -- | Create a guard pattern -mkGuard :: PatVec -> HsExpr Id -> Pattern +mkGuard :: PatVec -> HsExpr GhcTc -> Pattern mkGuard pv e | all cantFailPattern pv = PmGrd pv expr | PmExprOther {} <- expr = fake_pat @@ -1029,14 +1204,14 @@ mkPmVars tys = mapM mkPmVar tys -- | Generate a fresh `Id` of a given type mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique -> - let occname = mkVarOccFS (fsLit (show unique)) + let occname = mkVarOccFS $ fsLit "$pm" name = mkInternalName unique occname noSrcSpan in return (mkLocalId name ty) -- | Generate a fresh term variable of a given and return it in two forms: -- * A variable pattern -- * A variable expression -mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id) +mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc) mkPmId2Forms ty = do x <- mkPmId ty return (PmVar x, noLoc (HsVar (noLoc x))) @@ -1086,24 +1261,32 @@ singleConstructor _ = False -- These come from two places. -- 1. From data constructors defined with the result type constructor. -- 2. From `COMPLETE` pragmas which have the same type as the result --- type constructor. +-- type constructor. Note that we only use `COMPLETE` pragmas +-- *all* of whose pattern types match. See #14135 allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])] allCompleteMatches cl tys = do let fam = case cl of RealDataCon dc -> [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))] PatSynCon _ -> [] - - pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of - Just (tc, _) -> dsGetCompleteMatches tc - Nothing -> return [] - let fams cm = fmap (FromComplete,) $ + ty = conLikeResTy cl tys + pragmas <- case splitTyConApp_maybe ty of + Just (tc, _) -> dsGetCompleteMatches tc + Nothing -> return [] + let fams cm = (FromComplete,) <$> mapM dsLookupConLike (completeMatchConLikes cm) - from_pragma <- mapM fams pragmas - + from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$> + mapM fams pragmas let final_groups = fam ++ from_pragma - tracePmD "allCompleteMatches" (ppr final_groups) return final_groups + where + -- Check that all the pattern types in a `COMPLETE` + -- pragma subsume the type we're matching. See #14135. + isValidCompleteMatch :: Type -> [ConLike] -> Bool + isValidCompleteMatch ty = + isJust . mapM (flip tcMatchTy ty . resTy . conLikeFullSig) + where + resTy (_, _, _, _, _, _, res_ty) = res_ty -- ----------------------------------------------------------------------- -- * Types and constraints @@ -1463,7 +1646,7 @@ force_if True pres = forces pres force_if False pres = pres set_provenance :: Provenance -> PartialResult -> PartialResult -set_provenance prov pr = pr { presultProvenence = prov } +set_provenance prov pr = pr { presultProvenance = prov } -- ---------------------------------------------------------------------------- -- * Propagation of term constraints inwards when checking nested matches @@ -1503,9 +1686,9 @@ these constraints. -- When we go deeper to check e.g. e1 we record two equalities: -- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn) -- and (x ~ p1). -genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee - -> [Pat Id] -- LHS (should have length 1) - -> [Id] -- MatchVars (should have length 1) +genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee + -> [Pat GhcTc] -- LHS (should have length 1) + -> [Id] -- MatchVars (should have length 1) -> DsM (Bag SimpleEq) genCaseTmCs2 Nothing _ _ = return emptyBag genCaseTmCs2 (Just scr) [p] [var] = do @@ -1519,7 +1702,7 @@ genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase" -- case x of { matches } -- When checking matches we record that (x ~ y) where y is the initial -- uncovered. All matches will have to satisfy this equality. -genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq +genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq genCaseTmCs1 Nothing _ = emptyBag genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr) genCaseTmCs1 _ _ = panic "genCaseTmCs1: HsCase" @@ -1733,15 +1916,15 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs (L _ fun) _ _ -> (pprMatchContext kind, - \ pp -> ppr fun <+> pp) - _ -> (pprMatchContext kind, \ pp -> pp) + FunRhs { mc_fun = L _ fun } + -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + _ -> (pprMatchContext kind, \ pp -> pp) -ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc +ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc ppr_pats kind pats = sep [sep (map ppr pats), matchSeparator kind, text "..."] -ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc +ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn)) ppr_constraint :: (SDoc,[PmLit]) -> SDoc diff --git a/src/Language/Haskell/Liquid/Desugar/Coverage.hs b/src/Language/Haskell/Liquid/Desugar/Coverage.hs index d4894c8b2e..77050c0854 100644 --- a/src/Language/Haskell/Liquid/Desugar/Coverage.hs +++ b/src/Language/Haskell/Liquid/Desugar/Coverage.hs @@ -7,16 +7,15 @@ module Language.Haskell.Liquid.Desugar.Coverage (addTicksToBinds, hpcInitCode) where +import Prelude hiding ((<>)) + #ifdef GHCI import qualified GHCi import GHCi.RemoteTypes import Data.Array import ByteCodeTypes -#if MIN_VERSION_base(4,9,0) -import GHC.Stack.CCS #else -import GHC.Stack as GHC.Stack.CCS -#endif +-- import GHC.Stack as GHC.Stack.CCS #endif import Type import HsSyn @@ -75,8 +74,8 @@ addTicksToBinds -- isExportedId doesn't work yet (the desugarer -- hasn't set it), so we have to work from this set. -> [TyCon] -- Type constructor in this module - -> LHsBinds Id - -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks) + -> LHsBinds GhcTc + -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) addTicksToBinds hsc_env mod mod_loc exports tyCons binds | let dflags = hsc_dflags hsc_env @@ -131,7 +130,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds | otherwise = return (binds, emptyHpcInfo False, Nothing) -guessSourceFile :: LHsBinds Id -> FilePath -> FilePath +guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead. @@ -203,7 +202,7 @@ writeMixEntries dflags mod count entries filename modTime <- getModificationUTCTime filename let entries' = [ (hpcPos, box) | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] - when (length entries' /= count) $ do + when (entries' `lengthIsNot` count) $ do panic "the number of .mix entries are inconsistent" let hashNo = mixHash filename modTime tabStop entries' mixCreate hpc_mod_dir mod_name @@ -268,10 +267,10 @@ shouldTickPatBind density top_lev -- ----------------------------------------------------------------------------- -- Adding ticks to bindings -addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) +addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) addTickLHsBinds = mapBagM addTickLHsBind -addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) +addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do @@ -290,35 +289,12 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , idName pid `elemNameSet` (exports env) ] } + -- See Note [inline sccs] add_inlines env = env{ inlines = inlines env `extendVarSetList` [ mid | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , isAnyInlinePragma (idInlinePragma pid) ] } - -addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind = val_bind - , abs_sig_export = poly_id })) - | L _ FunBind { fun_id = L _ mono_id } <- val_bind - = do withEnv (add_export mono_id) $ do - withEnv (add_inlines mono_id) $ do - val_bind' <- addTickLHsBind val_bind - return $ L pos $ bind { abs_sig_bind = val_bind' } - - | otherwise - = pprPanic "addTickLHsBind" (ppr bind) - where - -- see AbsBinds comments - add_export mono_id env - | idName poly_id `elemNameSet` exports env - = env { exports = exports env `extendNameSet` idName mono_id } - | otherwise - = env - - add_inlines mono_id env - | isAnyInlinePragma (idInlinePragma poly_id) - = env { inlines = inlines env `extendVarSet` mono_id } - | otherwise - = env + , isInlinePragma (idInlinePragma pid) ] } addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let name = getOccString id @@ -326,7 +302,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do density <- getDensity inline_ids <- liftM inlines getEnv - let inline = isAnyInlinePragma (idInlinePragma id) + -- See Note [inline sccs] + let inline = isInlinePragma (idInlinePragma id) || id `elemVarSet` inline_ids -- See Note [inline sccs] @@ -410,24 +387,22 @@ bindTick density name pos fvs = do -- Note [inline sccs] -- --- It should be reasonable to add ticks to INLINE functions; however --- currently this tickles a bug later on because the SCCfinal pass --- does not look inside unfoldings to find CostCentres. It would be --- difficult to fix that, because SCCfinal currently works on STG and --- not Core (and since it also generates CostCentres for CAFs, --- changing this would be difficult too). --- --- Another reason not to add ticks to INLINE functions is that this +-- The reason not to add ticks to INLINE functions is that this is -- sometimes handy for avoiding adding a tick to a particular function -- (see #6131) -- -- So for now we do not add any ticks to INLINE functions at all. +-- +-- We used to use isAnyInlinePragma to figure out whether to avoid adding +-- ticks for this purpose. However, #12962 indicates that this contradicts +-- the documentation on profiling (which only mentions INLINE pragmas). +-- So now we're more careful about what we avoid adding ticks to. -- ----------------------------------------------------------------------------- -- Decorate an LHsExpr with ticks -- selectively add ticks to interesting expressions -addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of @@ -443,7 +418,7 @@ addTickLHsExpr e@(L pos e0) = do -- We always consider these to be breakpoints, unless the expression is a 'let' -- (because the body will definitely have a tick somewhere). ToDo: perhaps -- we should treat 'case' and 'if' the same way? -addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprRHS e@(L pos e0) = do d <- getDensity case d of @@ -460,7 +435,7 @@ addTickLHsExprRHS e@(L pos e0) = do -- let binds in [], ( [] ) -- we never tick these if we're doing HPC, but otherwise -- we treat it like an ordinary expression. -addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprEvalInner e = do d <- getDensity case d of @@ -472,7 +447,7 @@ addTickLHsExprEvalInner e = do -- want to tick the body, even if it is not a redex. See test -- break012. This gives the user the opportunity to inspect the -- values of the let-bound variables. -addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprLetBody e@(L pos e0) = do d <- getDensity case d of @@ -486,32 +461,32 @@ addTickLHsExprLetBody e@(L pos e0) = do -- version of addTick that does not actually add a tick, -- because the scope of this tick is completely subsumed by -- another. -addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprNever (L pos e0) = do e1 <- addTickHsExpr e0 return $ L pos e1 -- general heuristic: expressions which do not denote values are good -- break points -isGoodBreakExpr :: HsExpr Id -> Bool +isGoodBreakExpr :: HsExpr GhcTc -> Bool isGoodBreakExpr (HsApp {}) = True isGoodBreakExpr (HsAppTypeOut {}) = True isGoodBreakExpr (OpApp {}) = True isGoodBreakExpr _other = False -isCallSite :: HsExpr Id -> Bool +isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True isCallSite HsAppTypeOut{} = True isCallSite OpApp{} = True isCallSite _ = False -addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprOptAlt oneOfMany (L pos e0) = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) (addTickLHsExpr (L pos e0)) -addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) +addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addBinTickLHsExpr boxLabel (L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel pos $ addTickHsExpr e0) @@ -523,7 +498,7 @@ addBinTickLHsExpr boxLabel (L pos e0) -- (Whether to put a tick around the whole expression was already decided, -- in the addTickLHsExpr family of functions.) -addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) +addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsConLikeOut con) @@ -676,24 +651,27 @@ addTickHsExpr (ExprWithTySigOut e ty) = -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) -addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id) +addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e ; return (L l (Present e')) } addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) -addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) + -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches return $ mg { mg_alts = L l matches' } -addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) -addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = +addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) + -> TM (Match GhcTc (LHsExpr GhcTc)) +addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs - return $ Match mf pats opSig gRHSs' + return $ match { m_grhss = gRHSs' } -addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) +addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) + -> TM (GRHSs GhcTc (LHsExpr GhcTc)) addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds @@ -702,13 +680,14 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do where binders = collectLocalBinders local_binds -addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id)) +addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) + -> TM (GRHS GhcTc (LHsExpr GhcTc)) addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickGRHSBody isOneOfMany isLambda expr) return $ GRHS stmts' expr' -addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id) +addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do d <- getDensity case d of @@ -720,20 +699,22 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do _otherwise -> addTickLHsExprRHS expr -addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id] +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] + -> TM [ExprLStmt GhcTc] addTickLStmts isGuard stmts = do (stmts, _) <- addTickLStmts' isGuard stmts (return ()) return stmts -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a - -> TM ([ExprLStmt Id], a) +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a + -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res = bindLocals (collectLStmtsBinders lstmts) $ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } -addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id)) +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) + -> TM (Stmt GhcTc (LHsExpr GhcTc)) addTickStmt _isGuard (LastStmt e noret ret) = do liftM3 LastStmt (addTickLHsExpr e) @@ -786,33 +767,36 @@ addTickStmt isGuard stmt@(RecStmt {}) ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) +addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id) - -> TM (SyntaxExpr Id, ApplicativeArg Id Id) + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where - addTickArg (ApplicativeArgOne pat expr) = - ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr + addTickArg (ApplicativeArgOne pat expr isBody) = + ApplicativeArgOne + <$> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody addTickArg (ApplicativeArgMany stmts ret pat) = ApplicativeArgMany <$> addTickLStmts isGuard stmts <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat -addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id - -> TM (ParStmtBlock Id Id) +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc + -> TM (ParStmtBlock GhcTc GhcTc) addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = liftM3 ParStmtBlock (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr) -addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id) +addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds binds) = liftM HsValBinds (addTickHsValBinds binds) @@ -821,7 +805,7 @@ addTickHsLocalBinds (HsIPBinds binds) = (addTickHsIPBinds binds) addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds -addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b) +addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b) addTickHsValBinds (ValBindsOut binds sigs) = liftM2 ValBindsOut (mapM (\ (rec,binds') -> @@ -832,28 +816,28 @@ addTickHsValBinds (ValBindsOut binds sigs) = (return sigs) addTickHsValBinds _ = panic "addTickHsValBinds" -addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id) +addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) addTickHsIPBinds (IPBinds ipbinds dictbinds) = liftM2 IPBinds (mapM (liftL (addTickIPBind)) ipbinds) (return dictbinds) -addTickIPBind :: IPBind Id -> TM (IPBind Id) +addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind nm e) = liftM2 IPBind (return nm) (addTickLHsExpr e) -- There is no location here, so we might need to use a context location?? -addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id) +addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do L _ x' <- addTickLHsExpr (L pos x) return $ syn { syn_expr = x' } -- we do not walk into patterns. -addTickLPat :: LPat Id -> TM (LPat Id) +addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat -addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id) +addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = liftM4 HsCmdTop (addTickLHsCmd cmd) @@ -861,12 +845,12 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = (return ty) (return syntaxtable) -addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) +addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (L pos c0) = do c1 <- addTickHsCmd c0 return $ L pos c1 -addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) +addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) addTickHsCmd (HsCmdLam matchgroup) = liftM HsCmdLam (addTickCmdMatchGroup matchgroup) addTickHsCmd (HsCmdApp c e) = @@ -918,18 +902,19 @@ addTickHsCmd (HsCmdWrap w cmd) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) -addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id)) +addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) + -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do matches' <- mapM (liftL addTickCmdMatch) matches return $ mg { mg_alts = L l matches' } -addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) -addTickCmdMatch (Match mf pats opSig gRHSs) = +addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) +addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs - return $ Match mf pats opSig gRHSs' + return $ match { m_grhss = gRHSs' } -addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) +addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds @@ -938,7 +923,7 @@ addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do where binders = collectLocalBinders local_binds -addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id)) +addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is -- C.f. addTickGRHS for the BinBox stuff addTickCmdGRHS (GRHS stmts cmd) @@ -946,12 +931,14 @@ addTickCmdGRHS (GRHS stmts cmd) stmts (addTickLHsCmd cmd) ; return $ GRHS stmts' expr' } -addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)] +addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] + -> TM [LStmt GhcTc (LHsCmd GhcTc)] addTickLCmdStmts stmts = do (stmts, _) <- addTickLCmdStmts' stmts (return ()) return stmts -addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a) +addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a + -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) addTickLCmdStmts' lstmts res = bindLocals binders $ do lstmts' <- mapM (liftL addTickCmdStmt) lstmts @@ -960,7 +947,7 @@ addTickLCmdStmts' lstmts res where binders = collectLStmtsBinders lstmts -addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id)) +addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) addTickCmdStmt (BindStmt pat c bind fail ty) = do liftM5 BindStmt (addTickLPat pat) @@ -995,18 +982,19 @@ addTickCmdStmt ApplicativeStmt{} = -- Others should never happen in a command context. addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) -addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) +addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc) addTickHsRecordBinds (HsRecFields fields dd) = do { fields' <- mapM addTickHsRecField fields ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id)) +addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) + -> TM (LHsRecField' id (LHsExpr GhcTc)) addTickHsRecField (L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr ; return (L l (HsRecField id expr' pun)) } -addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) +addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) = liftM From (addTickLHsExpr e1) @@ -1194,8 +1182,8 @@ isBlackListed pos = TM $ \ env st -> -- the tick application inherits the source position of its -- expression argument to support nested box allocations -allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id) - -> TM (LHsExpr Id) +allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) allocTickBox boxLabel countEntries topOnly pos m = ifGoodTickSrcSpan pos (do (fvs, e) <- getFreeVars m @@ -1272,8 +1260,8 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do _otherwise -> panic "mkTickish: bad source span!" -allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id) - -> TM (LHsExpr Id) +allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) allocBinTickBox boxLabel pos m = do env <- getEnv case tickishType env of @@ -1283,8 +1271,8 @@ allocBinTickBox boxLabel pos m = do (return e) _other -> allocTickBox (ExpBox False) False False pos m -mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id - -> TM (LHsExpr Id) +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc + -> TM (LHsExpr GhcTc) mkBinTickBoxHpc boxLabel pos e = TM $ \ env st -> let meT = (pos,declPath env, [],boxLabel True) @@ -1317,10 +1305,10 @@ mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" hpcSrcSpan :: SrcSpan hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") -matchesOneOfMany :: [LMatch Id body] -> Bool +matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss + matchCount (L _ (Match { m_grhss = GRHSs grhss _binds })) = length grhss type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) diff --git a/src/Language/Haskell/Liquid/Desugar/Desugar.hs b/src/Language/Haskell/Liquid/Desugar/Desugar.hs index a8082c78cf..244114c99a 100644 --- a/src/Language/Haskell/Liquid/Desugar/Desugar.hs +++ b/src/Language/Haskell/Liquid/Desugar/Desugar.hs @@ -7,6 +7,7 @@ The Desugarer: turning HsSyn into Core. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Liquid.Desugar.Desugar ( -- * Desugaring operations @@ -144,7 +145,8 @@ deSugar hsc_env keep_alive <- readIORef keep_var ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules final_prs = addExportFlagsAndRules target export_set keep_alive - rules_for_locals (fromOL all_prs) + mod rules_for_locals + (fromOL all_prs) final_pgm = combineEvBinds ds_ev_binds final_prs -- Notice that we put the whole lot in a big Rec, even the foreign binds @@ -153,7 +155,7 @@ deSugar hsc_env -- You might think it doesn't matter, but the simplifier brings all top-level -- things into the in-scope set before simplifying; so we get no unfolding for F#! -#ifdef DEBUG +#if defined(DEBUG) -- Debug only as pre-simple-optimisation program may be really big ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps #endif @@ -247,7 +249,7 @@ So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr) +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do { let dflags = hsc_dflags hsc_env @@ -274,9 +276,9 @@ deSugarExpr hsc_env tc_expr = do { -} addExportFlagsAndRules - :: HscTarget -> NameSet -> NameSet -> [CoreRule] + :: HscTarget -> NameSet -> NameSet -> Module -> [CoreRule] -> [(Id, t)] -> [(Id, t)] -addExportFlagsAndRules target exports keep_alive rules prs +addExportFlagsAndRules target exports keep_alive mod rules prs = mapFst add_one prs where add_one bndr = add_rules name (add_export name bndr) @@ -309,10 +311,20 @@ addExportFlagsAndRules target exports keep_alive rules prs -- simplification), and retain them all in the TypeEnv so they are -- available from the command line. -- + -- Most of the time, this can be accomplished by use of + -- targetRetainsAllBindings, which returns True if the target is + -- HscInteractive. However, there are cases when one can use GHCi with + -- a target other than HscInteractive (e.g., with the -fobject-code + -- flag enabled, as in #12091). In such scenarios, + -- targetRetainsAllBindings can return False, so we must fall back on + -- isInteractiveModule to be doubly sure we export entities defined in + -- a GHCi session. + -- -- isExternalName separates the user-defined top-level names from those -- introduced by the type checker. is_exported :: Name -> Bool - is_exported | targetRetainsAllBindings target = isExternalName + is_exported | targetRetainsAllBindings target + || isInteractiveModule mod = isExternalName | otherwise = (`elemNameSet` exports) {- @@ -359,7 +371,7 @@ Reason ************************************************************************ -} -dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) +dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars] @@ -420,7 +432,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids <+> text "might inline first") , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id) - , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id @@ -431,7 +443,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids <+> text "for"<+> quotes (ppr lhs_id) <+> text "might fire first") , text "Probable fix: add phase [n] or [~n] to the competing rule" - , ifPprDebug (ppr bad_rule) ]) + , whenPprDebug (ppr bad_rule) ]) | otherwise = return () @@ -538,7 +550,7 @@ subsequent transformations could fire. ************************************************************************ -} -dsVect :: LVectDecl Id -> DsM CoreVect +dsVect :: LVectDecl GhcTc -> DsM CoreVect dsVect (L loc (HsVect _ (L _ v) rhs)) = putSrcSpanDs loc $ do { rhs' <- dsLExpr rhs diff --git a/src/Language/Haskell/Liquid/Desugar/DsArrows.hs b/src/Language/Haskell/Liquid/Desugar/DsArrows.hs index 9c86823e7a..536a888fce 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsArrows.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsArrows.hs @@ -7,6 +7,7 @@ Desugaring arrow commands -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Liquid.Desugar.DsArrows ( dsProcExpr ) where @@ -35,7 +36,6 @@ import MkCore import Language.Haskell.Liquid.Desugar.DsBinds (dsHsWrapper) import Name -import Var import Id import ConLike import TysWiredIn @@ -55,7 +55,7 @@ data DsCmdEnv = DsCmdEnv { arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr } -mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) +mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) -- See Note [CmdSyntaxTable] in HsExpr mkCmdEnv tc_meths = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths @@ -293,7 +293,7 @@ matchVarStack (param_id:param_ids) stack_id body = do pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) return (pair_id, coreCasePair pair_id param_id tail_id tail_code) -mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc mkHsEnvStackExpr env_ids stack_id = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] @@ -306,8 +306,8 @@ mkHsEnvStackExpr env_ids stack_id -- where (xs) is the tuple of variables bound by p dsProcExpr - :: LPat Id - -> LHsCmdTop Id + :: LPat GhcTc + -> LHsCmdTop GhcTc -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do (meth_binds, meth_ids) <- mkCmdEnv ids @@ -335,7 +335,7 @@ to an expression e such that D |- e :: a (xs, stk) t -} -dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id] +dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id] -> DsM (CoreExpr, DIdSet) dsLCmd ids local_vars stk_ty res_ty cmd env_ids = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids @@ -344,8 +344,8 @@ dsCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command -> Type -- type of the stack (right-nested tuple) -> Type -- return type of the command - -> HsCmd Id -- command to desugar - -> [Id] -- list of vars in the input to this command + -> HsCmd GhcTc -- command to desugar + -> [Id] -- list of vars in the input to this command -- This is typically fed back, -- so don't pull on it too early -> DsM (CoreExpr, -- desugared expression @@ -445,8 +445,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _ - (GRHSs [L _ (GRHS [] body)] _ ))] })) + (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats = pats + , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) let @@ -573,8 +573,8 @@ dsCmd ids local_vars stack_ty res_ty let left_id = HsConLikeOut (RealDataCon left_con) right_id = HsConLikeOut (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e + left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. @@ -674,8 +674,8 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) dsTrimCmdArg :: IdSet -- set of local vars available to this command - -> [Id] -- list of vars in the input to this command - -> LHsCmdTop Id -- command argument to desugar + -> [Id] -- list of vars in the input to this command + -> LHsCmdTop GhcTc -- command argument to desugar -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do @@ -698,7 +698,7 @@ dsfixCmd -> IdSet -- set of local vars available to this command -> Type -- type of the stack (right-nested tuple) -> Type -- return type of the command - -> LHsCmd Id -- command to desugar + -> LHsCmd GhcTc -- command to desugar -> DsM (CoreExpr, -- desugared expression DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back @@ -731,7 +731,7 @@ Translation of command judgements of the form dsCmdDo :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> Type -- return type of the statement - -> [CmdLStmt Id] -- statements to desugar + -> [CmdLStmt GhcTc] -- statements to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early @@ -780,7 +780,7 @@ as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. -} -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id] -> DsM (CoreExpr, DIdSet) dsCmdLStmt ids local_vars out_ids cmd env_ids = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids @@ -789,7 +789,7 @@ dsCmdStmt :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- list of vars in the output of this statement - -> CmdStmt Id -- statement to desugar + -> CmdStmt GhcTc -- statement to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early @@ -971,11 +971,11 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) dsRecCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement - -> [CmdLStmt Id] -- list of statements inside the RecCmd + -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd -> [Id] -- list of vars defined here and used later - -> [HsExpr Id] -- expressions corresponding to later_ids + -> [HsExpr GhcTc] -- expressions corresponding to later_ids -> [Id] -- list of vars fed back through the loop - -> [HsExpr Id] -- expressions corresponding to rec_ids + -> [HsExpr GhcTc] -- expressions corresponding to rec_ids -> DsM (CoreExpr, -- desugared statement DIdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list @@ -1049,7 +1049,7 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [CmdLStmt Id] -- statements to desugar + -> [CmdLStmt GhcTc] -- statements to desugar -> DsM (CoreExpr, -- desugared expression DIdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list @@ -1063,7 +1063,7 @@ dsCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [CmdLStmt Id] -- statements to desugar + -> [CmdLStmt GhcTc] -- statements to desugar -> [Id] -- list of vars in the input to these statements -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free @@ -1090,7 +1090,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" matchSimplys :: [CoreExpr] -- Scrutinees -> HsMatchContext Name -- Match kind - -> [LPat Id] -- Patterns they should match + -> [LPat GhcTc] -- Patterns they should match -> CoreExpr -- Return this if they all match -> CoreExpr -- Return this if they don't -> DsM CoreExpr @@ -1102,8 +1102,9 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" -- List of leaf expressions, with set of variables bound in each -leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] -leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) +leavesMatch :: LMatch GhcTc (Located (body GhcTc)) + -> [(Located (body GhcTc), IdSet)] +leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) })) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1118,21 +1119,21 @@ leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) replaceLeavesMatch :: Type -- new result type - -> [Located (body' Id)] -- replacement leaf expressions of that type - -> LMatch Id (Located (body Id)) -- the matches of a case command - -> ([Located (body' Id)], -- remaining leaf expressions - LMatch Id (Located (body' Id))) -- updated match -replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds))) + -> [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LMatch GhcTc (Located (body' GhcTc))) -- updated match +replaceLeavesMatch _res_ty leaves (L loc match@(Match { m_grhss = GRHSs grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', L loc (Match mf pat mt (GRHSs grhss' binds))) + (leaves', L loc (match { m_grhss = GRHSs grhss' binds })) replaceLeavesGRHS - :: [Located (body' Id)] -- replacement leaf expressions of that type - -> LGRHS Id (Located (body Id)) -- rhss of a case command - -> ([Located (body' Id)], -- remaining leaf expressions - LGRHS Id (Located (body' Id))) -- updated GRHS + :: [Located (body' GhcTc)] -- replacement leaf expressions of that type + -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command + -> ([Located (body' GhcTc)], -- remaining leaf expressions + LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) = (leaves, L loc (GRHS stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" @@ -1170,14 +1171,14 @@ See comments in HsUtils for why the other version does not include these bindings. -} -collectPatBinders :: LPat Id -> [Id] +collectPatBinders :: LPat GhcTc -> [Id] collectPatBinders pat = collectl pat [] -collectPatsBinders :: [LPat Id] -> [Id] +collectPatsBinders :: [LPat GhcTc] -> [Id] collectPatsBinders pats = foldr collectl [] pats --------------------- -collectl :: LPat Id -> [Id] -> [Id] +collectl :: LPat GhcTc -> [Id] -> [Id] -- See Note [Dictionary binders in ConPatOut] collectl (L _ pat) bndrs = go pat @@ -1217,12 +1218,12 @@ add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs | otherwise = bs -- A worry: what about coercion variable binders?? -collectLStmtsBinders :: [LStmt Id body] -> [Id] +collectLStmtsBinders :: [LStmt GhcTc body] -> [Id] collectLStmtsBinders = concatMap collectLStmtBinders -collectLStmtBinders :: LStmt Id body -> [Id] +collectLStmtBinders :: LStmt GhcTc body -> [Id] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: Stmt Id body -> [Id] +collectStmtBinders :: Stmt GhcTc body -> [Id] collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids collectStmtBinders stmt = HsUtils.collectStmtBinders stmt diff --git a/src/Language/Haskell/Liquid/Desugar/DsBinds.hs b/src/Language/Haskell/Liquid/Desugar/DsBinds.hs index 4a80cae33d..2704d1688a 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsBinds.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsBinds.hs @@ -11,13 +11,16 @@ lower levels it is preserved with @let@/@letrec@s). -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Liquid.Desugar.DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule ) where -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr( dsLExpr ) -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match( matchWrapper ) +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr( dsLExpr ) +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match( matchWrapper ) + +import Prelude hiding ((<>)) import Language.Haskell.Liquid.Desugar.DsMonad import Language.Haskell.Liquid.Desugar.DsGRHSs @@ -49,6 +52,7 @@ import Name import VarSet import Rules import VarEnv +import Var( EvVar ) import Outputable import Module import SrcLoc @@ -71,12 +75,12 @@ import Control.Monad -- | Desugar top level binds, strict binds are treated like normal -- binds since there is no good time to force before first usage. -dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) dsTopLHsBinds binds -- see Note [Strict binds checks] | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict pattern bindings") bang_binds + ; mapBagM_ (top_level_err "strict bindings") bang_binds ; return nilOL } | otherwise @@ -85,7 +89,7 @@ dsTopLHsBinds binds where unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds - bang_binds = filterBag (isBangedPatBind . unLoc) binds + bang_binds = filterBag (isBangedHsBind . unLoc) binds top_level_err desc (L loc bind) = putSrcSpanDs loc $ @@ -95,30 +99,29 @@ dsTopLHsBinds binds -- | Desugar all other kind of bindings, Ids of strict binds are returned to -- later be forced in the binding group body, see Note [Desugar Strict binds] -dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBinds binds = do { ds_bs <- mapBagM dsLHsBind binds ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) id ([], []) ds_bs) } ------------------------ -dsLHsBind :: LHsBind Id +dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBind (L loc bind) = do dflags <- getDynFlags putSrcSpanDs loc $ dsHsBind dflags bind -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags - -> HsBind Id + -> HsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) -- ^ The Ids of strict binds, to be forced in the body of the -- binding group see Note [Desugar Strict binds] and all -- bindings and their desugared right hand sides. -dsHsBind dflags - (VarBind { var_id = var - , var_rhs = expr - , var_inline = inline_regardless }) +dsHsBind dflags (VarBind { var_id = var + , var_rhs = expr + , var_inline = inline_regardless }) = do { core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here @@ -130,9 +133,8 @@ dsHsBind dflags else [] ; return (force_var, [core_bind]) } -dsHsBind dflags - b@(FunBind { fun_id = L _ fun, fun_matches = matches - , fun_co_fn = co_fn, fun_tick = tick }) +dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches + , fun_co_fn = co_fn, fun_tick = tick }) = do { (args, body) <- matchWrapper (mkPrefixFunRhs (noLoc $ idName fun)) Nothing matches @@ -145,16 +147,18 @@ dsHsBind dflags | xopt LangExt.Strict dflags , matchGroupArity matches == 0 -- no need to force lambdas = [id] - | isBangedBind b + | isBangedHsBind b = [id] | otherwise = [] - ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $ - return (force_var, [core_binds]) } - -dsHsBind dflags - (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty - , pat_ticks = (rhs_tick, var_ticks) }) + ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) + -- , ppr (mg_alts matches) + -- , ppr args, ppr core_binds]) $ + return (force_var, [core_binds]) } + +dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_rhs_ty = ty + , pat_ticks = (rhs_tick, var_ticks) }) = do { body_expr <- dsGuarded grhss ty ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat @@ -166,47 +170,73 @@ dsHsBind dflags else [] ; return (force_var', sel_binds) } - -- A common case: one exported variable, only non-strict binds - -- Non-recursive bindings come through this way - -- So do self-recursive bindings - -- Bindings with complete signatures are AbsBindsSigs, below -dsHsBind dflags - (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = [export] - , abs_ev_binds = ev_binds, abs_binds = binds }) - | ABE { abe_wrap = wrap, abe_poly = global - , abe_mono = local, abe_prags = prags } <- export - , not (xopt LangExt.Strict dflags) -- Handle strict binds - , not (anyBag (isBangedBind . unLoc) binds) -- in the next case - = -- See Note [AbsBinds wrappers] in HsBinds - addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (_, bind_prs) <- dsLHsBinds binds - ; let core_bind = Rec bind_prs - ; ds_binds <- dsTcEvBinds_s ev_binds - ; core_wrap <- dsHsWrapper wrap -- Usually the identity +dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds, abs_sig = has_sig }) + = do { ds_binds <- addDictsDs (toTcTypeBag (listToBag dicts)) $ + dsLHsBinds binds + -- addDictsDs: push type constraints deeper + -- for inner pattern match check + + ; ds_ev_binds <- dsTcEvBinds_s ev_binds + + -- dsAbsBinds does the hard work + ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } + +dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" + + +----------------------- +dsAbsBinds :: DynFlags + -> [TyVar] -> [EvVar] -> [ABExport GhcTc] + -> [CoreBind] -- Desugared evidence bindings + -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings + -> Bool -- Single binding with signature + -> DsM ([Id], [(Id,CoreExpr)]) + +dsAbsBinds dflags tyvars dicts exports + ds_ev_binds (force_vars, bind_prs) has_sig + + -- A very important common case: one exported variable + -- Non-recursive bindings come through this way + -- So do self-recursive bindings + | [export] <- exports + , ABE { abe_poly = global_id, abe_mono = local_id + , abe_wrap = wrap, abe_prags = prags } <- export + , Just force_vars' <- case force_vars of + [] -> Just [] + [v] | v == local_id -> Just [global_id] + _ -> Nothing + -- If there is a variable to force, it's just the + -- single variable we are binding here + = do { core_wrap <- dsHsWrapper wrap -- Usually the identity ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_binds $ - mkLet core_bind $ - Var local + mkCoreLets ds_ev_binds $ + body + + body | has_sig + , [(_, lrhs)] <- bind_prs + = lrhs + | otherwise + = mkLetRec bind_prs (Var local_id) + ; (spec_binds, rules) <- dsSpecs rhs prags - ; let global' = addIdSpecialisations global rules - main_bind = makeCorePair dflags global' (isDefaultMethod prags) - (dictArity dicts) rhs + ; let global_id' = addIdSpecialisations global_id rules + main_bind = makeCorePair dflags global_id' + (isDefaultMethod prags) + (dictArity dicts) rhs - ; return ([], main_bind : fromOL spec_binds) } + ; return (force_vars', main_bind : fromOL spec_binds) } - -- Another common case: no tyvars, no dicts - -- In this case we can have a much simpler desugaring -dsHsBind dflags - (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds, abs_binds = binds }) - = do { (force_vars, bind_prs) <- dsLHsBinds binds - ; let mk_bind (ABE { abe_wrap = wrap + -- Another common case: no tyvars, no dicts + -- In this case we can have a much simpler desugaring + | null tyvars, null dicts + + = do { let mk_bind (ABE { abe_wrap = wrap , abe_poly = global , abe_mono = local , abe_prags = prags }) @@ -216,42 +246,35 @@ dsHsBind dflags 0 (core_wrap (Var local))) } ; main_binds <- mapM mk_bind exports - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) } - -dsHsBind dflags - (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports, abs_ev_binds = ev_binds - , abs_binds = binds }) - -- See Note [Desugaring AbsBinds] - = addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (local_force_vars, bind_prs) <- dsLHsBinds binds - ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs + ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } + + -- The general case + -- See Note [Desugaring AbsBinds] + | otherwise + = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs | (lcl_id, rhs) <- bind_prs ] -- Monomorphic recursion possible, hence Rec - new_force_vars = get_new_force_vars local_force_vars - locals = map abe_mono exports - all_locals = locals ++ new_force_vars - tup_expr = mkBigCoreVarTup all_locals - tup_ty = exprType tup_expr - ; ds_binds <- dsTcEvBinds_s ev_binds - ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_binds $ - mkLet core_bind $ - tup_expr - - ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) + new_force_vars = get_new_force_vars force_vars + locals = map abe_mono exports + all_locals = locals ++ new_force_vars + tup_expr = mkBigCoreVarTup all_locals + tup_ty = exprType tup_expr + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + mkLet core_bind $ + tup_expr + + ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) -- Find corresponding global or make up a new one: sometimes -- we need to make new export to desugar strict binds, see -- Note [Desugar Strict binds] - ; (exported_force_vars, extra_exports) <- get_exports local_force_vars + ; (exported_force_vars, extra_exports) <- get_exports force_vars - ; let mk_bind (ABE { abe_wrap = wrap - , abe_poly = global - , abe_mono = local, abe_prags = spec_prags }) - -- See Note [AbsBinds wrappers] in HsBinds + ; let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local, abe_prags = spec_prags }) + -- See Note [AbsBinds wrappers] in HsBinds = do { tup_id <- newSysLocalDs tup_ty ; core_wrap <- dsHsWrapper wrap ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ @@ -266,13 +289,13 @@ dsHsBind dflags -- Id is just the selector. Hmm. ; return ((global', rhs) : fromOL spec_binds) } - ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) + ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) - ; return (exported_force_vars - ,(poly_tup_id, poly_tup_rhs) : + ; return ( exported_force_vars + , (poly_tup_id, poly_tup_rhs) : concat export_binds_s) } where - inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with -- the inline pragma from the source -- The type checker put the inline pragma -- on the *global* Id, so we need to transfer it @@ -299,7 +322,7 @@ dsHsBind dflags [] lcls -- find exports or make up new exports for force variables - get_exports :: [Id] -> DsM ([Id], [ABExport Id]) + get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc]) get_exports lcls = foldM (\(glbls, exports) lcl -> case lookupVarEnv global_env lcl of @@ -312,57 +335,10 @@ dsHsBind dflags mk_export local = do global <- newSysLocalDs (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE {abe_poly = global - ,abe_mono = local - ,abe_wrap = WpHole - ,abe_prags = SpecPrags []}) - --- AbsBindsSig is a combination of AbsBinds and FunBind -dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_sig_export = global - , abs_sig_prags = prags - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = bind }) - | L bind_loc FunBind { fun_matches = matches - , fun_co_fn = co_fn - , fun_tick = tick } <- bind - = putSrcSpanDs bind_loc $ - addDictsDs (toTcTypeBag (listToBag dicts)) $ - -- addDictsDs: push type constraints deeper for pattern match check - do { (args, body) <- matchWrapper - (mkPrefixFunRhs (noLoc $ idName global)) - Nothing matches - ; core_wrap <- dsHsWrapper co_fn - ; let body' = mkOptTickBox tick body - fun_rhs = core_wrap (mkLams args body') - force_vars - | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas - = [global] - | isBangedBind (unLoc bind) - = [global] - | otherwise - = [] - - ; ds_binds <- dsTcEvBinds ev_bind - ; let rhs = mkLams tyvars $ - mkLams dicts $ - mkCoreLets ds_binds $ - fun_rhs - - ; (spec_binds, rules) <- dsSpecs rhs prags - ; let global' = addIdSpecialisations global rules - main_bind = makeCorePair dflags global' (isDefaultMethod prags) - (dictArity dicts) rhs - - ; return (force_vars, main_bind : fromOL spec_binds) } - - | otherwise - = pprPanic "dsHsBind: AbsBindsSig" (ppr bind) - -dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" - - + return (ABE { abe_poly = global + , abe_mono = local + , abe_wrap = WpHole + , abe_prags = SpecPrags [] }) -- | This is where we apply INLINE and INLINABLE pragmas. All we need to -- do is to attach the unfolding information to the Id. @@ -372,17 +348,19 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" -- the unfolding in the interface file is made in `TidyPgm.addExternal` -- using this information. ------------------------ -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr + -> (Id, CoreExpr) makeCorePair dflags gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined + | is_default_method -- Default methods are *always* inlined + -- See Note [INLINE and default methods] in TcInstDcls = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) | otherwise = case inlinePragmaSpec inline_prag of - EmptyInlineSpec -> (gbl_id, rhs) - NoInline -> (gbl_id, rhs) - Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline -> inline_pair + NoUserInline -> (gbl_id, rhs) + NoInline -> (gbl_id, rhs) + Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline -> inline_pair where inline_prag = idInlinePragma gbl_id @@ -419,7 +397,7 @@ Note [Rules and inlining] ~~~~~~~~~~~~~~~~~~~~~~~~~ Common special case: no type or dictionary abstraction This is a bit less trivial than you might suppose -The naive way woudl be to desguar to something like +The naive way would be to desugar to something like f_lcl = ...f_lcl... -- The "binds" from AbsBinds M.f = f_lcl -- Generated from "exports" But we don't want that, because if M.f isn't exported, @@ -535,6 +513,7 @@ thought! Note [Desugar Strict binds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma Desugaring strict variable bindings looks as follows (core below ==>) @@ -620,7 +599,7 @@ We define an "unlifted bind" to be any bind that binds an unlifted id. Note that is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind. -Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind. +Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind. Define a "strict bind" to be either an unlifted bind or a banged bind. The restrictions are: @@ -669,7 +648,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) = putSrcSpanDs loc $ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)) - ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that + ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that -- See Note [Activation pragmas for SPECIALISE] | otherwise @@ -1029,7 +1008,7 @@ drop_dicts drops dictionary bindings on the LHS where possible. RULE forall s (d :: MonadAbstractIOST (ReaderT s)). useAbstractMonad (ReaderT s) d = $suseAbstractMonad s - Trac #8848 is a good example of where there are some intersting + Trac #8848 is a good example of where there are some interesting dictionary bindings to discard. The drop_dicts algorithm is based on these observations: @@ -1251,10 +1230,12 @@ ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) -- Note that we use the kind of the type, not the TyCon from which it -- is constructed since the latter may be kind polymorphic whereas the -- former we know is not (we checked in the solver). - ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr } ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) @@ -1265,8 +1246,11 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -- TypeRep a -> TypeRep b -> TypeRep (a b) ; let (k1, k2) = splitFunTy (typeKind t1) - ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] } + ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr + ; return expr + } ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) | Just (t1,t2) <- splitFunTy_maybe ty diff --git a/src/Language/Haskell/Liquid/Desugar/DsCCall.hs b/src/Language/Haskell/Liquid/Desugar/DsCCall.hs index 85afe61c34..aeee526d42 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsCCall.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsCCall.hs @@ -130,7 +130,7 @@ unboxArg :: CoreExpr -- The supplied argument, not levity-pol -- always returns a non-levity-polymorphic expression unboxArg arg - -- Primtive types: nothing to unbox + -- Primitive types: nothing to unbox | isPrimitiveType arg_ty = return (arg, \body -> body) @@ -196,7 +196,7 @@ boxResult :: Type -- Takes the result of the user-level ccall: -- either (IO t), --- or maybe just t for an side-effect-free call +-- or maybe just t for a side-effect-free call -- Returns a wrapper for the primitive ccall itself, along with the -- type of the result of the primitive ccall. This result type -- will be of the form @@ -335,7 +335,7 @@ resultWrapper result_ty -- Data types with a single constructor, which has a single arg -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys) <- maybe_tc_app - , Just data_con <- isDataProductTyCon_maybe tycon -- One construtor, no existentials + , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument = do { dflags <- getDynFlags ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty diff --git a/src/Language/Haskell/Liquid/Desugar/DsExpr.hs b/src/Language/Haskell/Liquid/Desugar/DsExpr.hs index b92318d624..9b5aa4a65e 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsExpr.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsExpr.hs @@ -1,1057 +1,1152 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Desugaring expressions. --} - -{-# LANGUAGE CPP, MultiWayIf #-} - -module Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds - , dsValBinds, dsLit, dsSyntaxExpr ) where - -import Language.Haskell.Liquid.Desugar.Match -import Language.Haskell.Liquid.Desugar.MatchLit -import Language.Haskell.Liquid.Desugar.DsBinds -import Language.Haskell.Liquid.Desugar.DsGRHSs -import Language.Haskell.Liquid.Desugar.DsListComp -import Language.Haskell.Liquid.Desugar.DsUtils -import Language.Haskell.Liquid.Desugar.DsArrows -import Language.Haskell.Liquid.Desugar.DsMonad -import Name -import NameEnv -import FamInstEnv( topNormaliseType ) -import Language.Haskell.Liquid.Desugar.DsMeta -import HsSyn - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types -import TcType -import TcEvidence -import TcRnMonad -import TcHsSyn -import Type -import CoreSyn -import CoreUtils -import MkCore - -import DynFlags -import CostCentre -import Id -import MkId -import Module -import ConLike -import DataCon -import TysWiredIn -import PrelNames -import BasicTypes -import Maybes -import VarEnv -import SrcLoc -import Util -import Bag -import Outputable -import PatSyn - -import Control.Monad - -{- -************************************************************************ -* * - dsLocalBinds, dsValBinds -* * -************************************************************************ --} - -dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr -dsLocalBinds (L _ EmptyLocalBinds) body = return body -dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body - -------------------------- --- caller sets location -dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr -dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds -dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" - -------------------------- -dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ip_binds ev_binds) body - = do { ds_binds <- dsTcEvBinds ev_binds - ; let inner = mkCoreLets ds_binds body - -- The dict bindings may not be in - -- dependency order; hence Rec - ; foldrM ds_ip_bind inner ip_binds } - where - ds_ip_bind (L _ (IPBind ~(Right n) e)) body - = do e' <- dsLExpr e - return (Let (NonRec n e') body) - -------------------------- --- caller sets location -ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr --- Special case for bindings which bind unlifted variables --- We need to do a case right away, rather than building --- a tuple and doing selections. --- Silently ignore INLINE and SPECIALISE pragmas... -ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds - -- Non-recursive, non-overloaded bindings only come in ones - -- ToDo: in some bizarre case it's conceivable that there - -- could be dict binds in the 'binds'. (See the notes - -- below. Then pattern-match would fail. Urk.) - , isUnliftedHsBind bind - = putSrcSpanDs loc $ - -- see Note [Strict binds checks] in DsBinds - if is_polymorphic bind - then errDsCoreExpr (poly_bind_err bind) - -- data Ptr a = Ptr Addr# - -- f x = let p@(Ptr y) = ... in ... - -- Here the binding for 'p' is polymorphic, but does - -- not mix with an unlifted binding for 'y'. You should - -- use a bang pattern. Trac #6078. - - else do { when (looksLazyPatBind bind) $ - warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) - -- Complain about a binding that looks lazy - -- e.g. let I# y = x in ... - -- Remember, in checkStrictBinds we are going to do strict - -- matching, so (for software engineering reasons) we insist - -- that the strictness is manifest on each binding - -- However, lone (unboxed) variables are ok - - - ; dsUnliftedBind bind body } - where - is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) - = not (null tvs && null evs) - is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }) - = not (null tvs && null evs) - is_polymorphic _ = False - - unlifted_must_be_bang bind - = hang (text "Pattern bindings containing unlifted types should use" $$ - text "an outermost bang pattern:") - 2 (ppr bind) - - poly_bind_err bind - = hang (text "You can't mix polymorphic and unlifted bindings:") - 2 (ppr bind) $$ - text "Probable fix: add a type signature" - -ds_val_bind (_, binds) _body - | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds - = errDsCoreExpr $ - hang (text "Recursive bindings for unlifted types aren't allowed:") - 2 (vcat (map ppr (bagToList binds))) - --- Ordinary case for bindings; none should be unlifted -ds_val_bind (_, binds) body - = do { (force_vars,prs) <- dsLHsBinds binds - ; let body' = foldr seqVar body force_vars - ; case prs of - [] -> return body - _ -> return (Let (Rec prs) body') } - -- Use a Rec regardless of is_rec. - -- Why? Because it allows the binds to be all - -- mixed up, which is what happens in one rare case - -- Namely, for an AbsBind with no tyvars and no dicts, - -- but which does have dictionary bindings. - -- See notes with TcSimplify.inferLoop [NO TYVARS] - -- It turned out that wrapping a Rec here was the easiest solution - -- - -- NB The previous case dealt with unlifted bindings, so we - -- only have to deal with lifted ones now; so Rec is ok - ------------------- -dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr -dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = lbinds }) body - = do { let body1 = foldr bind_export body exports - bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b - ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body) - body1 lbinds - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (mkCoreLets ds_binds body2) } - -dsUnliftedBind (AbsBindsSig { abs_tvs = [] - , abs_ev_vars = [] - , abs_sig_export = poly - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = L _ bind }) body - = do { ds_binds <- dsTcEvBinds ev_bind - ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body - ; return (mkCoreLets ds_binds body') } - -dsUnliftedBind (FunBind { fun_id = L l fun - , fun_matches = matches - , fun_tick = tick }) body - -- Can't be a bang pattern (that looks like a PatBind) - -- so must be simply unboxed - = do { (_, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) - Nothing matches - ; let rhs' = mkOptTickBox tick rhs - ; return (bindNonRec fun rhs' body) } - -dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body - = -- let C x# y# = rhs in body - -- ==> case rhs of C x# y# -> body - do { rhs <- dsGuarded grhss ty - ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], - eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar upat - ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (bindNonRec var rhs result) } - -dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) - -{- -************************************************************************ -* * -\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} -* * -************************************************************************ --} - -dsLExpr :: LHsExpr Id -> DsM CoreExpr - -dsLExpr (L loc e) - = do ce <- putSrcSpanDs loc $ dsExpr e - m <- getModule - return $ Tick (srcSpanTick m loc) ce - -srcSpanTick :: Module -> SrcSpan -> Tickish a -srcSpanTick m loc - = ProfNote (AllCafsCC m loc) False True --- | Variant of 'dsLExpr' that ensures that the result is not levity --- polymorphic. This should be used when the resulting expression will --- be an argument to some other function. --- See Note [Levity polymorphism checking] in DsMonad --- See Note [Levity polymorphism invariants] in CoreSyn -dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr -dsLExprNoLP (L loc e) - = putSrcSpanDs loc $ - do { e' <- dsExpr e - ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) - ; return e' } - -dsExpr :: HsExpr Id -> DsM CoreExpr -dsExpr (HsPar e) = dsLExpr e -dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar (L _ var)) = return (varToCoreExpr var) - -- See Note [Desugaring vars] -dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them -dsExpr (HsConLikeOut con) = return (dsConLike con) -dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" -dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel" -dsExpr (HsLit lit) = dsLit lit -dsExpr (HsOverLit lit) = dsOverLit lit - -dsExpr (HsWrap co_fn e) - = do { e' <- dsExpr e - ; wrap' <- dsHsWrapper co_fn - ; dflags <- getDynFlags - ; let wrapped_e = wrap' e' - ; warnAboutIdentities dflags e' (exprType wrapped_e) - ; return wrapped_e } - -dsExpr (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral src i }))) - neg_expr) - = do { expr' <- putSrcSpanDs loc $ do - { dflags <- getDynFlags - ; warnAboutOverflowedLiterals dflags - (lit { ol_val = HsIntegral src (-i) }) - ; dsOverLit' dflags lit } - ; dsSyntaxExpr neg_expr [expr'] } - -dsExpr (NegApp expr neg_expr) - = do { expr' <- dsLExpr expr - ; dsSyntaxExpr neg_expr [expr'] } - -dsExpr (HsLam a_Match) - = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match - -dsExpr (HsLamCase matches) - = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches - ; return $ Lam discrim_var matching_code } - -dsExpr e@(HsApp fun arg) - = do { fun' <- dsLExpr fun - ; dsWhenNoErrs (dsLExprNoLP arg) - (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } - -dsExpr (HsAppTypeOut e _) - -- ignore type arguments here; they're in the wrappers instead at this point - = dsLExpr e - - -{- -Note [Desugaring vars] -~~~~~~~~~~~~~~~~~~~~~~ -In one situation we can get a *coercion* variable in a HsVar, namely -the support method for an equality superclass: - class (a~b) => C a b where ... - instance (blah) => C (T a) (T b) where .. -Then we get - $dfCT :: forall ab. blah => C (T a) (T b) - $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) - - $c$p1C :: forall ab. blah => (T a ~ T b) - $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g - -That 'g' in the 'in' part is an evidence variable, and when -converting to core it must become a CO. - -Operator sections. At first it looks as if we can convert -\begin{verbatim} - (expr op) -\end{verbatim} -to -\begin{verbatim} - \x -> op expr x -\end{verbatim} - -But no! expr might be a redex, and we can lose laziness badly this -way. Consider -\begin{verbatim} - map (expr op) xs -\end{verbatim} -for example. So we convert instead to -\begin{verbatim} - let y = expr in \x -> op y x -\end{verbatim} -If \tr{expr} is actually just a variable, say, then the simplifier -will sort it out. --} - -dsExpr e@(OpApp e1 op _ e2) - = -- for the type of y, we need the type of op's 2nd argument - do { op' <- dsLExpr op - ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) - (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } - -dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) - = do { op' <- dsLExpr op - ; dsWhenNoErrs (dsLExprNoLP expr) - (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } - --- dsLExpr (SectionR op expr) -- \ x -> op x expr -dsExpr e@(SectionR op expr) = do - core_op <- dsLExpr op - -- for the type of x, we need the type of op's 2nd argument - let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) - -- See comment with SectionL - y_core <- dsLExpr expr - dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) - (\[x_id, y_id] -> bindNonRec y_id y_core $ - Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) - core_op [Var x_id, Var y_id])) - -dsExpr (ExplicitTuple tup_args boxity) - = do { let go (lam_vars, args) (L _ (Missing ty)) - -- For every missing expression, we need - -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDsNoLP ty - ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present expr)) - -- Expressions that are present don't generate - -- lambdas, just arguments. - = do { core_expr <- dsLExpr expr - ; return (lam_vars, core_expr : args) } - - ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) - -- The reverse is because foldM goes left-to-right - - ; return $ mkCoreLams lam_vars $ - mkCoreTupBoxity boxity args } - -dsExpr (ExplicitSum alt arity expr types) - = do { core_expr <- dsLExpr expr - ; return $ mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep) types ++ - map Type types ++ - [core_expr]) } - -dsExpr (HsSCC _ cc expr@(L loc _)) = do - dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags - then do - mod_name <- getModule - count <- goptM Opt_ProfCountEntries -#ifdef DETERMINISTIC_PROFILING - let nm = sl_fs cc - flavour <- ExprCC <$> getCCIndexM nm - Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True) -#else - uniq <- newUnique - Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True) -#endif - <$> dsLExpr expr - else dsLExpr expr - -dsExpr (HsCoreAnn _ _ expr) - = dsLExpr expr - -dsExpr (HsCase discrim matches) - = do { core_discrim <- dsLExpr discrim - ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches - ; return (bindNonRec discrim_var core_discrim matching_code) } - --- Pepe: The binds are in scope in the body but NOT in the binding group --- This is to avoid silliness in breakpoints -dsExpr (HsLet binds body) = do - body' <- dsLExpr body - dsLocalBinds binds body' - --- We need the `ListComp' form to use `deListComp' (rather than the "do" form) --- because the interpretation of `stmts' depends on what sort of thing it is. --- -dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty -dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) -dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts -dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts -dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts -dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts - -dsExpr (HsIf mb_fun guard_expr then_expr else_expr) - = do { pred <- dsLExpr guard_expr - ; b1 <- dsLExpr then_expr - ; b2 <- dsLExpr else_expr - ; case mb_fun of - Just fun -> dsSyntaxExpr fun [pred, b1, b2] - Nothing -> return $ mkIfThenElse pred b1 b2 } - -dsExpr (HsMultiIf res_ty alts) - | null alts - = mkErrorExpr - - | otherwise - = do { match_result <- liftM (foldr1 combineMatchResults) - (mapM (dsGRHS IfAlt res_ty) alts) - ; error_expr <- mkErrorExpr - ; extractMatchResult match_result error_expr } - where - mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty - (text "multi-way if") - -{- -\noindent -\underline{\bf Various data construction things} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -dsExpr (ExplicitList elt_ty wit xs) - = dsExplicitList elt_ty wit xs - --- We desugar [:x1, ..., xn:] as --- singletonP x1 +:+ ... +:+ singletonP xn --- -dsExpr (ExplicitPArr ty []) = do - emptyP <- dsDPHBuiltin emptyPVar - return (Var emptyP `App` Type ty) -dsExpr (ExplicitPArr ty xs) = do - singletonP <- dsDPHBuiltin singletonPVar - appP <- dsDPHBuiltin appPVar - xs' <- mapM dsLExprNoLP xs - let unary fn x = mkApps (Var fn) [Type ty, x] - binary fn x y = mkApps (Var fn) [Type ty, x, y] - - return . foldr1 (binary appP) $ map (unary singletonP) xs' - -dsExpr (ArithSeq expr witness seq) - = case witness of - Nothing -> dsArithSeq expr seq - Just fl -> do { newArithSeq <- dsArithSeq expr seq - ; dsSyntaxExpr fl [newArithSeq] } - -dsExpr (PArrSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to] - -dsExpr (PArrSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to] - -dsExpr (PArrSeq _ _) - = panic "DsExpr.dsExpr: Infinite parallel array!" - -- the parser shouldn't have generated it and the renamer and typechecker - -- shouldn't have let it through - -{- -Static Pointers -~~~~~~~~~~~~~~~ - -See Note [Grand plan for static forms] in StaticPtrTable for an overview. - - g = ... static f ... -==> - g = ... makeStatic loc f ... --} - -dsExpr (HsStatic _ expr@(L loc _)) = do - expr_ds <- dsLExprNoLP expr - let ty = exprType expr_ds - makeStaticId <- dsLookupGlobalId makeStaticName - - dflags <- getDynFlags - let (line, col) = case loc of - RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r - , srcLocCol $ realSrcSpanStart r - ) - _ -> (0, 0) - srcLoc = mkCoreConApps (tupleDataCon Boxed 2) - [ Type intTy , Type intTy - , mkIntExprInt dflags line, mkIntExprInt dflags col - ] - - putSrcSpanDs loc $ return $ - mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] - -{- -\noindent -\underline{\bf Record construction and update} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record construction we do this (assuming T has three arguments) -\begin{verbatim} - T { op2 = e } -==> - let err = /\a -> recConErr a - T (recConErr t1 "M.hs/230/op1") - e - (recConErr t1 "M.hs/230/op3") -\end{verbatim} -@recConErr@ then converts its argument string into a proper message -before printing it as -\begin{verbatim} - M.hs, line 230: missing field op1 was evaluated -\end{verbatim} - -We also handle @C{}@ as valid construction syntax for an unlabelled -constructor @C@, setting all of @C@'s fields to bottom. --} - -dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds - , rcon_con_like = con_like }) - = do { con_expr' <- dsExpr con_expr - ; let - (arg_tys, _) = tcSplitFunTys (exprType con_expr') - -- A newtype in the corner should be opaque; - -- hence TcType.tcSplitFunTys - - mk_arg (arg_ty, fl) - = case findField (rec_flds rbinds) (flSelector fl) of - (rhs:_) -> dsLExprNoLP rhs - [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) - unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty - - labels = conLikeFieldLabels con_like - - ; con_args <- if null labels - then mapM unlabelled_bottom arg_tys - else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) - - ; return (mkCoreApps con_expr' con_args) } - -{- -Record update is a little harder. Suppose we have the decl: -\begin{verbatim} - data T = T1 {op1, op2, op3 :: Int} - | T2 {op4, op2 :: Int} - | T3 -\end{verbatim} -Then we translate as follows: -\begin{verbatim} - r { op2 = e } -===> - let op2 = e in - case r of - T1 op1 _ op3 -> T1 op1 op2 op3 - T2 op4 _ -> T2 op4 op2 - other -> recUpdError "M.hs/230" -\end{verbatim} -It's important that we use the constructor Ids for @T1@, @T2@ etc on the -RHSs, and do not generate a Core constructor application directly, because the constructor -might do some argument-evaluation first; and may have to throw away some -dictionaries. - -Note [Update for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b where - T1 :: { f1 :: a } -> T a Int - -Then the wrapper function for T1 has type - $WT1 :: a -> T a Int -But if x::T a b, then - x { f1 = v } :: T a b (not T a Int!) -So we need to cast (T a Int) to (T a b). Sigh. - --} - -dsExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = fields - , rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap } ) - | null fields - = dsLExpr record_expr - | otherwise - = do { record_expr' <- dsLExpr record_expr - ; field_binds' <- mapM ds_field fields - ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding - upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] - - -- It's important to generate the match with matchWrapper, - -- and the right hand sides with applications of the wrapper Id - -- so that everything works when we are doing fancy unboxing on the - -- constructor arguments. - ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd - ; ([discrim_var], matching_code) - <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts - , mg_arg_tys = [in_ty] - , mg_res_ty = out_ty, mg_origin = FromSource }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings - - ; return (add_field_binds field_binds' $ - bindNonRec discrim_var record_expr' matching_code) } - where - ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr) - -- Clone the Id in the HsRecField, because its Name is that - -- of the record selector, and we must not make that a local binder - -- else we shadow other uses of the record selector - -- Hence 'lcl_id'. Cf Trac #2735 - ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) - ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } - - add_field_binds [] expr = expr - add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) - - -- Awkwardly, for families, the match goes - -- from instance type to family type - (in_ty, out_ty) = - case (head cons_to_upd) of - RealDataCon data_con -> - let tycon = dataConTyCon data_con in - (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) - PatSynCon pat_syn -> - ( patSynInstResTy pat_syn in_inst_tys - , patSynInstResTy pat_syn out_inst_tys) - mk_alt upd_fld_env con - = do { let (univ_tvs, ex_tvs, eq_spec, - prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - subst = zipTvSubst univ_tvs in_inst_tys - - -- I'm not bothering to clone the ex_tvs - ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta) - ; arg_ids <- newSysLocalsDs (substTysUnchecked subst arg_tys) - ; let field_labels = conLikeFieldLabels con - val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - field_labels arg_ids - mk_val_arg fl pat_arg_id - = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - - inst_con = noLoc $ HsWrap wrap (HsConLikeOut con) - -- Reconstruct with the WrapId so that unpacking happens - -- The order here is because of the order in `TcPatSyn`. - wrap = mkWpEvVarApps theta_vars <.> - dict_req_wrap <.> - mkWpTyApps (mkTyVarTys ex_tvs) <.> - mkWpTyApps [ ty - | (tv, ty) <- univ_tvs `zip` out_inst_tys - , not (tv `elemVarEnv` wrap_subst) ] - rhs = foldl (\a b -> nlHsApp a b) inst_con val_args - - -- Tediously wrap the application in a cast - -- Note [Update for GADTs] - wrapped_rhs = - case con of - RealDataCon data_con -> - let - wrap_co = - mkTcTyConAppCo Nominal - (dataConTyCon data_con) - [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys ] - lookup univ_tv ty = - case lookupVarEnv wrap_subst univ_tv of - Just co' -> co' - Nothing -> mkTcReflCo Nominal ty - in if null eq_spec - then rhs - else mkLHsWrap (mkWpCastN wrap_co) rhs - -- eq_spec is always null for a PatSynCon - PatSynCon _ -> rhs - - wrap_subst = - mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) - | (spec, eq_var) <- eq_spec `zip` eqs_vars - , let tv = eqSpecTyVar spec ] - - req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - - pat = noLoc $ ConPatOut { pat_con = noLoc con - , pat_tvs = ex_tvs - , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_arg_tys = in_inst_tys - , pat_wrap = req_wrap } - ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } - --- Here is where we desugar the Template Haskell brackets and escapes - --- Template Haskell stuff - -dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" -dsExpr (HsTcBracketOut x ps) = dsBracket x ps -dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) - --- Arrow notation extension -dsExpr (HsProc pat cmd) = dsProcExpr pat cmd - --- Hpc Support - -dsExpr (HsTick tickish e) = do - e' <- dsLExpr e - return (Tick tickish e') - --- There is a problem here. The then and else branches --- have no free variables, so they are open to lifting. --- We need someway of stopping this. --- This will make no difference to binary coverage --- (did you go here: YES or NO), but will effect accurate --- tick counting. - -dsExpr (HsBinTick ixT ixF e) = do - e2 <- dsLExpr e - do { mkBinaryTickBox ixT ixF e2 - } - -dsExpr (HsTickPragma _ _ _ expr) = do - dflags <- getDynFlags - if gopt Opt_Hpc dflags - then panic "dsExpr:HsTickPragma" - else dsLExpr expr - --- HsSyn constructs that just shouldn't be here: -dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" -dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" -dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp" -dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm" -dsExpr (EWildPat {}) = panic "dsExpr:EWildPat" -dsExpr (EAsPat {}) = panic "dsExpr:EAsPat" -dsExpr (EViewPat {}) = panic "dsExpr:EViewPat" -dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat" -dsExpr (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker -dsExpr (HsDo {}) = panic "dsExpr:HsDo" -dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" - ------------------------------- -dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr -dsSyntaxExpr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - arg_exprs - = do { fun <- dsExpr expr - ; core_arg_wraps <- mapM dsHsWrapper arg_wraps - ; core_res_wrap <- dsHsWrapper res_wrap - ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs - ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) - (\_ -> core_res_wrap (mkApps fun wrapped_args)) } - where - mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) - -findField :: [LHsRecField Id arg] -> Name -> [arg] -findField rbinds sel - = [hsRecFieldArg fld | L _ fld <- rbinds - , sel == idName (unLoc $ hsRecFieldId fld) ] - -{- -%-------------------------------------------------------------------- - -Note [Desugaring explicit lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Explicit lists are desugared in a cleverer way to prevent some -fruitless allocations. Essentially, whenever we see a list literal -[x_1, ..., x_n] we generate the corresponding expression in terms of -build: - -Explicit lists (literals) are desugared to allow build/foldr fusion when -beneficial. This is a bit of a trade-off, - - * build/foldr fusion can generate far larger code than the corresponding - cons-chain (e.g. see #11707) - - * even when it doesn't produce more code, build can still fail to fuse, - requiring that the simplifier do more work to bring the expression - back into cons-chain form; this costs compile time - - * when it works, fusion can be a significant win. Allocations are reduced - by up to 25% in some nofib programs. Specifically, - - Program Size Allocs Runtime CompTime - rewrite +0.0% -26.3% 0.02 -1.8% - ansi -0.3% -13.8% 0.00 +0.0% - lift +0.0% -8.7% 0.00 -2.3% - -At the moment we use a simple heuristic to determine whether build will be -fruitful: for small lists we assume the benefits of fusion will be worthwhile; -for long lists we assume that the benefits will be outweighted by the cost of -code duplication. This magic length threshold is @maxBuildLength@. Also, fusion -won't work at all if rewrite rules are disabled, so we don't use the build-based -desugaring in this case. - -We used to have a more complex heuristic which would try to break the list into -"static" and "dynamic" parts and only build-desugar the dynamic part. -Unfortunately, determining "static-ness" reliably is a bit tricky and the -heuristic at times produced surprising behavior (see #11710) so it was dropped. --} - -{- | The longest list length which we will desugar using @build@. - -This is essentially a magic number and its setting is unfortunate rather -arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], -is to avoid deforesting large static data into large(r) code. Ideally we'd -want a smaller threshold with larger consumers and vice-versa, but we have no -way of knowing what will be consuming our list in the desugaring impossible to -set generally correctly. - -The effect of reducing this number will be that 'build' fusion is applied -less often. From a runtime performance perspective, applying 'build' more -liberally on "moderately" sized lists should rarely hurt and will often it can -only expose further optimization opportunities; if no fusion is possible it will -eventually get rule-rewritten back to a list). We do, however, pay in compile -time. --} -maxBuildLength :: Int -maxBuildLength = 32 - -dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] - -> DsM CoreExpr --- See Note [Desugaring explicit lists] -dsExplicitList elt_ty Nothing xs - = do { dflags <- getDynFlags - ; xs' <- mapM dsLExprNoLP xs - ; if length xs' > maxBuildLength - -- Don't generate builds if the list is very long. - || length xs' == 0 - -- Don't generate builds when the [] constructor will do - || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off - -- Don't generate a build if there are no rules to eliminate it! - -- See Note [Desugaring RULE left hand sides] in Desugar - then return $ mkListExpr elt_ty xs' - else mkBuildExpr elt_ty (mk_build_list xs') } - where - mk_build_list xs' (cons, _) (nil, _) - = return (foldr (App . App (Var cons)) (Var nil) xs') - -dsExplicitList elt_ty (Just fln) xs - = do { list <- dsExplicitList elt_ty Nothing xs - ; dflags <- getDynFlags - ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } - -dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr -dsArithSeq expr (From from) - = App <$> dsExpr expr <*> dsLExprNoLP from -dsArithSeq expr (FromTo from to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from Nothing to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - to' <- dsLExprNoLP to - return $ mkApps expr' [from', to'] -dsArithSeq expr (FromThen from thn) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] -dsArithSeq expr (FromThenTo from thn to) - = do dflags <- getDynFlags - warnAboutEmptyEnumerations dflags from (Just thn) to - expr' <- dsExpr expr - from' <- dsLExprNoLP from - thn' <- dsLExprNoLP thn - to' <- dsLExprNoLP to - return $ mkApps expr' [from', thn', to'] - -{- -Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're -handled in DsListComp). Basically does the translation given in the -Haskell 98 report: --} - -dsDo :: [ExprLStmt Id] -> DsM CoreExpr -dsDo stmts - = goL stmts - where - goL [] = panic "dsDo" - goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - go _ (LastStmt body _ _) _ - = dsLExpr body - -- The 'return' op isn't used for 'do' expressions - - go _ (BodyStmt rhs then_expr _ _) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs (exprType rhs2) - ; rest <- goL stmts - ; dsSyntaxExpr then_expr [rhs2, rest] } - - go _ (LetStmt binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } - - go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - - go _ (ApplicativeStmt args mb_join body_ty) stmts - = do { - let - (pats, rhss) = unzip (map (do_arg . snd) args) - - do_arg (ApplicativeArgOne pat expr) = - (pat, dsLExpr expr) - do_arg (ApplicativeArgMany stmts ret pat) = - (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) - - arg_tys = map hsLPatType pats - - ; rhss' <- sequence rhss - - ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty - - ; let fun = L noSrcSpan $ HsLam $ - MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats - body'] - , mg_arg_tys = arg_tys - , mg_res_ty = body_ty - , mg_origin = Generated } - - ; fun' <- dsLExpr fun - ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] - ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') - ; case mb_join of - Nothing -> return expr - Just join_op -> dsSyntaxExpr join_op [expr] } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = return_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_bind_ty = bind_ty - , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts - = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } - where - new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats) - mfix_app bind_op - noSyntaxExpr -- Tuple cannot fail - bind_ty - - tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids - tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case - rec_tup_pats = map nlVarPat tup_ids - later_pats = rec_tup_pats - rets = map noLoc rec_rets - mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam - (MG { mg_alts = noLoc [mkSimpleMatch - LambdaExpr - [mfix_pat] body] - , mg_arg_tys = [tup_ty], mg_res_ty = body_ty - , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty - ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] - ret_stmt = noLoc $ mkLastStmt ret_app - -- This LastStmt will be desugared with dsDo, - -- which ignores the return_op in the LastStmt, - -- so we must apply the return_op explicitly - - go _ (ParStmt {}) _ = panic "dsDo ParStmt" - go _ (TransStmt {}) _ = panic "dsDo TransStmt" - -handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr - -- In a do expression, pattern-match failure just calls - -- the monadic 'fail' rather than throwing an exception -handle_failure pat match fail_op - | matchCanFail match - = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] - ; extractMatchResult match fail_expr } - | otherwise - = extractMatchResult match (error "It can't fail") - -mk_fail_msg :: DynFlags -> Located e -> String -mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ - showPpr dflags (getLoc pat) - -{- -************************************************************************ -* * - Desugaring ConLikes -* * -************************************************************************ --} - -dsConLike :: ConLike -> CoreExpr -dsConLike (RealDataCon dc) = Var (dataConWrapId dc) -dsConLike (PatSynCon ps) = case patSynBuilder ps of - Just (id, add_void) - | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) - | otherwise -> Var id - _ -> pprPanic "dsConLike" (ppr ps) - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ --} - --- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () -warnDiscardedDoBindings rhs rhs_ty - | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty - = do { warn_unused <- woptM Opt_WarnUnusedDoBind - ; warn_wrong <- woptM Opt_WarnWrongDoBind - ; when (warn_unused || warn_wrong) $ - do { fam_inst_envs <- dsGetFamInstEnvs - ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty - - -- Warn about discarding non-() things in 'monadic' binding - ; if warn_unused && not (isUnitTy norm_elt_ty) - then warnDs (Reason Opt_WarnUnusedDoBind) - (badMonadBind rhs elt_ty) - else - - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - when warn_wrong $ - do { case tcSplitAppTy_maybe norm_elt_ty of - Just (elt_m_ty, _) - | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> warnDs (Reason Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) - _ -> return () } } } - - | otherwise -- RHS does have type of form (m ty), which is weird - = return () -- but at lesat this warning is irrelevant - -badMonadBind :: LHsExpr Id -> Type -> SDoc -badMonadBind rhs elt_ty - = vcat [ hang (text "A do-notation statement discarded a result of type") - 2 (quotes (ppr elt_ty)) - , hang (text "Suppress this warning by saying") - 2 (quotes $ text "_ <-" <+> ppr rhs) - ] +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring exporessions. +-} + +{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +module Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds + , dsValBinds, dsLit, dsSyntaxExpr ) where + +import Language.Haskell.Liquid.Desugar.Match +import Language.Haskell.Liquid.Desugar.MatchLit +import Language.Haskell.Liquid.Desugar.DsBinds +import Language.Haskell.Liquid.Desugar.DsGRHSs +import Language.Haskell.Liquid.Desugar.DsListComp +import Language.Haskell.Liquid.Desugar.DsUtils +import Language.Haskell.Liquid.Desugar.DsArrows +import Language.Haskell.Liquid.Desugar.DsMonad +import Name +import NameEnv +import FamInstEnv( topNormaliseType ) +import Language.Haskell.Liquid.Desugar.DsMeta +import HsSyn + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types +import TcType +import TcEvidence +import TcRnMonad +import TcHsSyn +import Type +import CoreSyn +import CoreUtils +import MkCore + +import DynFlags +import CostCentre +import Id +import MkId +import Module +import ConLike +import DataCon +import TysWiredIn +import PrelNames +import BasicTypes +import Maybes +import VarEnv +import SrcLoc +import Util +import Bag +import Outputable +import PatSyn + +import Control.Monad + +{- +************************************************************************ +* * + dsLocalBinds, dsValBinds +* * +************************************************************************ +-} + +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsLocalBinds (L _ EmptyLocalBinds) body = return body +dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body + +------------------------- +-- caller sets location +dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds +dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" + +------------------------- +dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsIPBinds (IPBinds ip_binds ev_binds) body + = do { ds_binds <- dsTcEvBinds ev_binds + ; let inner = mkCoreLets ds_binds body + -- The dict bindings may not be in + -- dependency order; hence Rec + ; foldrM ds_ip_bind inner ip_binds } + where + ds_ip_bind (L _ (IPBind ~(Right n) e)) body + = do e' <- dsLExpr e + return (Let (NonRec n e') body) + +------------------------- +-- caller sets location +ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr +-- Special case for bindings which bind unlifted variables +-- We need to do a case right away, rather than building +-- a tuple and doing selections. +-- Silently ignore INLINE and SPECIALISE pragmas... +ds_val_bind (NonRecursive, hsbinds) body + | [L loc bind] <- bagToList hsbinds + -- Non-recursive, non-overloaded bindings only come in ones + -- ToDo: in some bizarre case it's conceivable that there + -- could be dict binds in the 'binds'. (See the notes + -- below. Then pattern-match would fail. Urk.) + , isUnliftedHsBind bind + = putSrcSpanDs loc $ + -- see Note [Strict binds checks] in DsBinds + if is_polymorphic bind + then errDsCoreExpr (poly_bind_err bind) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. Trac #6078. + + else do { when (looksLazyPatBind bind) $ + warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) + -- Complain about a binding that looks lazy + -- e.g. let I# y = x in ... + -- Remember, in checkStrictBinds we are going to do strict + -- matching, so (for software engineering reasons) we insist + -- that the strictness is manifest on each binding + -- However, lone (unboxed) variables are ok + + + ; dsUnliftedBind bind body } + where + is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) + = not (null tvs && null evs) + is_polymorphic _ = False + + unlifted_must_be_bang bind + = hang (text "Pattern bindings containing unlifted types should use" $$ + text "an outermost bang pattern:") + 2 (ppr bind) + + poly_bind_err bind + = hang (text "You can't mix polymorphic and unlifted bindings:") + 2 (ppr bind) $$ + text "Probable fix: add a type signature" + +ds_val_bind (is_rec, binds) _body + | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds + = errDsCoreExpr $ + hang (text "Recursive bindings for unlifted types aren't allowed:") + 2 (vcat (map ppr (bagToList binds))) + +-- Ordinary case for bindings; none should be unlifted +ds_val_bind (is_rec, binds) body + = do { (force_vars,prs) <- dsLHsBinds binds + ; let body' = foldr seqVar body force_vars + ; case prs of + [] -> return body + _ -> return (Let (Rec prs) body') } + -- Use a Rec regardless of is_rec. + -- Why? Because it allows the binds to be all + -- mixed up, which is what happens in one rare case + -- Namely, for an AbsBind with no tyvars and no dicts, + -- but which does have dictionary bindings. + -- See notes with TcSimplify.inferLoop [NO TYVARS] + -- It turned out that wrapping a Rec here was the easiest solution + -- + -- NB The previous case dealt with unlifted bindings, so we + -- only have to deal with lifted ones now; so Rec is ok + +------------------ +dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr +dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = lbinds }) body + = do { let body1 = foldr bind_export body exports + bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b + ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body) + body1 lbinds + ; ds_binds <- dsTcEvBinds_s ev_binds + ; return (mkCoreLets ds_binds body2) } + +dsUnliftedBind (FunBind { fun_id = L l fun + , fun_matches = matches + , fun_co_fn = co_fn + , fun_tick = tick }) body + -- Can't be a bang pattern (that looks like a PatBind) + -- so must be simply unboxed + = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) + Nothing matches + ; let rhs' = mkOptTickBox tick rhs + ; return (bindNonRec fun rhs' body) } + +dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body + = -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + do { rhs <- dsGuarded grhss ty + ; let upat = unLoc pat + eqn = EqnInfo { eqn_pats = [upat], + eqn_rhs = cantFailMatchResult body } + ; var <- selectMatchVar upat + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (bindNonRec var rhs result) } + +dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + +{- +************************************************************************ +* * +\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} +* * +************************************************************************ +-} + +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr + +dsLExpr (L loc e) + = putSrcSpanDs loc $ + do { core_expr <- dsExpr e + -- uncomment this check to test the hsExprType function in TcHsSyn + -- ; MASSERT2( exprType core_expr `eqType` hsExprType e + -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ + -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) + ; return core_expr } + +-- | Variant of 'dsLExpr' that ensures that the result is not levity +-- polymorphic. This should be used when the resulting expression will +-- be an argument to some other function. +-- See Note [Levity polymorphism checking] in DsMonad +-- See Note [Levity polymorphism invariants] in CoreSyn +dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsLExprNoLP (L loc e) + = putSrcSpanDs loc $ + do { e' <- dsExpr e + ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) + ; return e' } + +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsExpr = ds_expr False + +ds_expr :: Bool -- are we directly inside an HsWrap? + -- See Wrinkle in Note [Detecting forced eta expansion] + -> HsExpr GhcTc -> DsM CoreExpr +ds_expr _ (HsPar e) = dsLExpr e +ds_expr _ (ExprWithTySigOut e _) = dsLExpr e +ds_expr w (HsVar (L _ var)) = dsHsVar w var +ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them +ds_expr w (HsConLikeOut con) = dsConLike w con +ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar" +ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" +ds_expr _ (HsLit lit) = dsLit (convertLit lit) +ds_expr _ (HsOverLit lit) = dsOverLit lit + +ds_expr _ (HsWrap co_fn e) + = do { e' <- ds_expr True e + ; wrap' <- dsHsWrapper co_fn + ; dflags <- getDynFlags + ; let wrapped_e = wrap' e' + wrapped_ty = exprType wrapped_e + ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion] + ; warnAboutIdentities dflags e' wrapped_ty + ; return wrapped_e } + +ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i }))) + neg_expr) + = do { expr' <- putSrcSpanDs loc $ do + { dflags <- getDynFlags + ; warnAboutOverflowedLiterals dflags + (lit { ol_val = HsIntegral (negateIntegralLit i) }) + ; dsOverLit' dflags lit } + ; dsSyntaxExpr neg_expr [expr'] } + +ds_expr _ (NegApp expr neg_expr) + = do { expr' <- dsLExpr expr + ; dsSyntaxExpr neg_expr [expr'] } + +ds_expr _ (HsLam a_Match) + = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match + +ds_expr _ (HsLamCase matches) + = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches + ; return $ Lam discrim_var matching_code } + +ds_expr _ e@(HsApp fun arg) + = do { fun' <- dsLExpr fun + ; dsWhenNoErrs (dsLExprNoLP arg) + (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } + +ds_expr _ (HsAppTypeOut e _) + -- ignore type arguments here; they're in the wrappers instead at this point + = dsLExpr e + + +{- +Note [Desugaring vars] +~~~~~~~~~~~~~~~~~~~~~~ +In one situation we can get a *coercion* variable in a HsVar, namely +the support method for an equality superclass: + class (a~b) => C a b where ... + instance (blah) => C (T a) (T b) where .. +Then we get + $dfCT :: forall ab. blah => C (T a) (T b) + $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) + + $c$p1C :: forall ab. blah => (T a ~ T b) + $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g + +That 'g' in the 'in' part is an evidence variable, and when +converting to core it must become a CO. + +Operator sections. At first it looks as if we can convert +\begin{verbatim} + (expr op) +\end{verbatim} +to +\begin{verbatim} + \x -> op expr x +\end{verbatim} + +But no! expr might be a redex, and we can lose laziness badly this +way. Consider +\begin{verbatim} + map (expr op) xs +\end{verbatim} +for example. So we convert instead to +\begin{verbatim} + let y = expr in \x -> op y x +\end{verbatim} +If \tr{expr} is actually just a variable, say, then the simplifier +will sort it out. +-} + +ds_expr _ e@(OpApp e1 op _ e2) + = -- for the type of y, we need the type of op's 2nd argument + do { op' <- dsLExpr op + ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) + (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } + +ds_expr _ (SectionL expr op) -- Desugar (e !) to ((!) e) + = do { op' <- dsLExpr op + ; dsWhenNoErrs (dsLExprNoLP expr) + (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } + +-- dsLExpr (SectionR op expr) -- \ x -> op x expr +ds_expr _ e@(SectionR op expr) = do + core_op <- dsLExpr op + -- for the type of x, we need the type of op's 2nd argument + let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) + -- See comment with SectionL + y_core <- dsLExpr expr + dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) + (\[x_id, y_id] -> bindNonRec y_id y_core $ + Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) + core_op [Var x_id, Var y_id])) + +ds_expr _ (ExplicitTuple tup_args boxity) + = do { let go (lam_vars, args) (L _ (Missing ty)) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDsNoLP ty + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (L _ (Present expr)) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExprNoLP expr + ; return (lam_vars, core_expr : args) } + + ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) + -- The reverse is because foldM goes left-to-right + (\(lam_vars, args) -> mkCoreLams lam_vars $ + mkCoreTupBoxity boxity args) } + +ds_expr _ (ExplicitSum alt arity expr types) + = do { dsWhenNoErrs (dsLExprNoLP expr) + (\core_expr -> mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep) types ++ + map Type types ++ + [core_expr]) ) } + +ds_expr _ (HsSCC _ cc expr@(L loc _)) = do + dflags <- getDynFlags + if gopt Opt_SccProfilingOn dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + uniq <- newUnique + Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True) + <$> dsLExpr expr + else dsLExpr expr + +ds_expr _ (HsCoreAnn _ _ expr) + = dsLExpr expr + +ds_expr _ (HsCase discrim matches) + = do { core_discrim <- dsLExpr discrim + ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches + ; return (bindNonRec discrim_var core_discrim matching_code) } + +-- Pepe: The binds are in scope in the body but NOT in the binding group +-- This is to avoid silliness in breakpoints +ds_expr _ (HsLet binds body) = do + body' <- dsLExpr body + dsLocalBinds binds body' + +-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) +-- because the interpretation of `stmts' depends on what sort of thing it is. +-- +ds_expr _ (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty +ds_expr _ (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) +ds_expr _ (HsDo DoExpr (L _ stmts) _) = dsDo stmts +ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts +ds_expr _ (HsDo MDoExpr (L _ stmts) _) = dsDo stmts +ds_expr _ (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts + +ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; case mb_fun of + Just fun -> dsSyntaxExpr fun [pred, b1, b2] + Nothing -> return $ mkIfThenElse pred b1 b2 } + +ds_expr _ (HsMultiIf res_ty alts) + | null alts + = mkErrorExpr + + | otherwise + = do { match_result <- liftM (foldr1 combineMatchResults) + (mapM (dsGRHS IfAlt res_ty) alts) + ; error_expr <- mkErrorExpr + ; extractMatchResult match_result error_expr } + where + mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty + (text "multi-way if") + +{- +\noindent +\underline{\bf Various data construction things} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} + +ds_expr _ (ExplicitList elt_ty wit xs) + = dsExplicitList elt_ty wit xs + +-- We desugar [:x1, ..., xn:] as +-- singletonP x1 +:+ ... +:+ singletonP xn +-- +ds_expr _ (ExplicitPArr ty []) = do + emptyP <- dsDPHBuiltin emptyPVar + return (Var emptyP `App` Type ty) +ds_expr _ (ExplicitPArr ty xs) = do + singletonP <- dsDPHBuiltin singletonPVar + appP <- dsDPHBuiltin appPVar + xs' <- mapM dsLExprNoLP xs + let unary fn x = mkApps (Var fn) [Type ty, x] + binary fn x y = mkApps (Var fn) [Type ty, x, y] + + return . foldr1 (binary appP) $ map (unary singletonP) xs' + +ds_expr _ (ArithSeq expr witness seq) + = case witness of + Nothing -> dsArithSeq expr seq + Just fl -> do { newArithSeq <- dsArithSeq expr seq + ; dsSyntaxExpr fl [newArithSeq] } + +ds_expr _ (PArrSeq expr (FromTo from to)) + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to] + +ds_expr _ (PArrSeq expr (FromThenTo from thn to)) + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to] + +ds_expr _ (PArrSeq _ _) + = panic "DsExpr.dsExpr: Infinite parallel array!" + -- the parser shouldn't have generated it and the renamer and typechecker + -- shouldn't have let it through + +{- +Static Pointers +~~~~~~~~~~~~~~~ + +See Note [Grand plan for static forms] in StaticPtrTable for an overview. + + g = ... static f ... +==> + g = ... makeStatic loc f ... +-} + +ds_expr _ (HsStatic _ expr@(L loc _)) = do + expr_ds <- dsLExprNoLP expr + let ty = exprType expr_ds + makeStaticId <- dsLookupGlobalId makeStaticName + + dflags <- getDynFlags + let (line, col) = case loc of + RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r + , srcLocCol $ realSrcSpanStart r + ) + _ -> (0, 0) + srcLoc = mkCoreConApps (tupleDataCon Boxed 2) + [ Type intTy , Type intTy + , mkIntExprInt dflags line, mkIntExprInt dflags col + ] + + putSrcSpanDs loc $ return $ + mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] + +{- +\noindent +\underline{\bf Record construction and update} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record construction we do this (assuming T has three arguments) +\begin{verbatim} + T { op2 = e } +==> + let err = /\a -> recConErr a + T (recConErr t1 "M.hs/230/op1") + e + (recConErr t1 "M.hs/230/op3") +\end{verbatim} +@recConErr@ then converts its argument string into a proper message +before printing it as +\begin{verbatim} + M.hs, line 230: missing field op1 was evaluated +\end{verbatim} + +We also handle @C{}@ as valid construction syntax for an unlabelled +constructor @C@, setting all of @C@'s fields to bottom. +-} + +ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds + , rcon_con_like = con_like }) + = do { con_expr' <- dsExpr con_expr + ; let + (arg_tys, _) = tcSplitFunTys (exprType con_expr') + -- A newtype in the corner should be opaque; + -- hence TcType.tcSplitFunTys + + mk_arg (arg_ty, fl) + = case findField (rec_flds rbinds) (flSelector fl) of + (rhs:rhss) -> dsLExprNoLP rhs + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) + unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty + + labels = conLikeFieldLabels con_like + + ; con_args <- if null labels + then mapM unlabelled_bottom arg_tys + else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) + + ; return (mkCoreApps con_expr' con_args) } + +{- +Record update is a little harder. Suppose we have the decl: +\begin{verbatim} + data T = T1 {op1, op2, op3 :: Int} + | T2 {op4, op2 :: Int} + | T3 +\end{verbatim} +Then we translate as follows: +\begin{verbatim} + r { op2 = e } +===> + let op2 = e in + case r of + T1 op1 _ op3 -> T1 op1 op2 op3 + T2 op4 _ -> T2 op4 op2 + other -> recUpdError "M.hs/230" +\end{verbatim} +It's important that we use the constructor Ids for @T1@, @T2@ etc on the +RHSs, and do not generate a Core constructor application directly, because the constructor +might do some argument-evaluation first; and may have to throw away some +dictionaries. + +Note [Update for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b where + T1 :: { f1 :: a } -> T a Int + +Then the wrapper function for T1 has type + $WT1 :: a -> T a Int +But if x::T a b, then + x { f1 = v } :: T a b (not T a Int!) +So we need to cast (T a Int) to (T a b). Sigh. + +-} + +ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields + , rupd_cons = cons_to_upd + , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys + , rupd_wrap = dict_req_wrap } ) + | null fields + = dsLExpr record_expr + | otherwise + = do { record_expr' <- dsLExpr record_expr + ; field_binds' <- mapM ds_field fields + ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding + upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] + + -- It's important to generate the match with matchWrapper, + -- and the right hand sides with applications of the wrapper Id + -- so that everything works when we are doing fancy unboxing on the + -- constructor arguments. + ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd + ; ([discrim_var], matching_code) + <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts + , mg_arg_tys = [in_ty] + , mg_res_ty = out_ty, mg_origin = FromSource }) + -- FromSource is not strictly right, but we + -- want incomplete pattern-match warnings + + ; return (add_field_binds field_binds' $ + bindNonRec discrim_var record_expr' matching_code) } + where + ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) + -- Clone the Id in the HsRecField, because its Name is that + -- of the record selector, and we must not make that a local binder + -- else we shadow other uses of the record selector + -- Hence 'lcl_id'. Cf Trac #2735 + ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecUpdFieldId rec_field) + ; lcl_id <- newSysLocalDs (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } + + add_field_binds [] expr = expr + add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) + + -- Awkwardly, for families, the match goes + -- from instance type to family type + (in_ty, out_ty) = + case (head cons_to_upd) of + RealDataCon data_con -> + let tycon = dataConTyCon data_con in + (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) + PatSynCon pat_syn -> + ( patSynInstResTy pat_syn in_inst_tys + , patSynInstResTy pat_syn out_inst_tys) + mk_alt upd_fld_env con + = do { let (univ_tvs, ex_tvs, eq_spec, + prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con + subst = zipTvSubst univ_tvs in_inst_tys + + -- I'm not bothering to clone the ex_tvs + ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) + ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta) + ; arg_ids <- newSysLocalsDs (substTysUnchecked subst arg_tys) + ; let field_labels = conLikeFieldLabels con + val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + field_labels arg_ids + mk_val_arg fl pat_arg_id + = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) + + inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con) + -- Reconstruct with the WrapId so that unpacking happens + -- The order here is because of the order in `TcPatSyn`. + wrap = mkWpEvVarApps theta_vars <.> + dict_req_wrap <.> + mkWpTyApps (mkTyVarTys ex_tvs) <.> + mkWpTyApps [ ty + | (tv, ty) <- univ_tvs `zip` out_inst_tys + , not (tv `elemVarEnv` wrap_subst) ] + rhs = foldl (\a b -> nlHsApp a b) inst_con val_args + + -- Tediously wrap the application in a cast + -- Note [Update for GADTs] + wrapped_rhs = + case con of + RealDataCon data_con -> + let + wrap_co = + mkTcTyConAppCo Nominal + (dataConTyCon data_con) + [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys ] + lookup univ_tv ty = + case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkTcReflCo Nominal ty + in if null eq_spec + then rhs + else mkLHsWrap (mkWpCastN wrap_co) rhs + -- eq_spec is always null for a PatSynCon + PatSynCon _ -> rhs + + wrap_subst = + mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) + | (spec, eq_var) <- eq_spec `zip` eqs_vars + , let tv = eqSpecTyVar spec ] + + req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys + + pat = noLoc $ ConPatOut { pat_con = noLoc con + , pat_tvs = ex_tvs + , pat_dicts = eqs_vars ++ theta_vars + , pat_binds = emptyTcEvBinds + , pat_args = PrefixCon $ map nlVarPat arg_ids + , pat_arg_tys = in_inst_tys + , pat_wrap = req_wrap } + ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } + +-- Here is where we desugar the Template Haskell brackets and escapes + +-- Template Haskell stuff + +ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" +ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps +ds_expr _ (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) + +-- Arrow notation extension +ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd + +-- Hpc Support + +ds_expr _ (HsTick tickish e) = do + e' <- dsLExpr e + return (Tick tickish e') + +-- There is a problem here. The then and else branches +-- have no free variables, so they are open to lifting. +-- We need someway of stopping this. +-- This will make no difference to binary coverage +-- (did you go here: YES or NO), but will effect accurate +-- tick counting. + +ds_expr _ (HsBinTick ixT ixF e) = do + e2 <- dsLExpr e + do { mkBinaryTickBox ixT ixF e2 + } + +ds_expr _ (HsTickPragma _ _ _ expr) = do + dflags <- getDynFlags + if gopt Opt_Hpc dflags + then panic "dsExpr:HsTickPragma" + else dsLExpr expr + +-- HsSyn constructs that just shouldn't be here: +ds_expr _ (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" +ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" +ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp" +ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm" +ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat" +ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat" +ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" +ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" +ds_expr _ (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker +ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" +ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" + +------------------------------ +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsSyntaxExpr (SyntaxExpr { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + arg_exprs + = do { fun <- dsExpr expr + ; core_arg_wraps <- mapM dsHsWrapper arg_wraps + ; core_res_wrap <- dsHsWrapper res_wrap + ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs + ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]) + (\_ -> core_res_wrap (mkApps fun wrapped_args)) } + where + mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) + +findField :: [LHsRecField GhcTc arg] -> Name -> [arg] +findField rbinds sel + = [hsRecFieldArg fld | L _ fld <- rbinds + , sel == idName (unLoc $ hsRecFieldId fld) ] + +{- +%-------------------------------------------------------------------- + +Note [Desugaring explicit lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Explicit lists are desugared in a cleverer way to prevent some +fruitless allocations. Essentially, whenever we see a list literal +[x_1, ..., x_n] we generate the corresponding expression in terms of +build: + +Explicit lists (literals) are desugared to allow build/foldr fusion when +beneficial. This is a bit of a trade-off, + + * build/foldr fusion can generate far larger code than the corresponding + cons-chain (e.g. see #11707) + + * even when it doesn't produce more code, build can still fail to fuse, + requiring that the simplifier do more work to bring the expression + back into cons-chain form; this costs compile time + + * when it works, fusion can be a significant win. Allocations are reduced + by up to 25% in some nofib programs. Specifically, + + Program Size Allocs Runtime CompTime + rewrite +0.0% -26.3% 0.02 -1.8% + ansi -0.3% -13.8% 0.00 +0.0% + lift +0.0% -8.7% 0.00 -2.3% + +At the moment we use a simple heuristic to determine whether build will be +fruitful: for small lists we assume the benefits of fusion will be worthwhile; +for long lists we assume that the benefits will be outweighted by the cost of +code duplication. This magic length threshold is @maxBuildLength@. Also, fusion +won't work at all if rewrite rules are disabled, so we don't use the build-based +desugaring in this case. + +We used to have a more complex heuristic which would try to break the list into +"static" and "dynamic" parts and only build-desugar the dynamic part. +Unfortunately, determining "static-ness" reliably is a bit tricky and the +heuristic at times produced surprising behavior (see #11710) so it was dropped. +-} + +{- | The longest list length which we will desugar using @build@. + +This is essentially a magic number and its setting is unfortunate rather +arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists], +is to avoid deforesting large static data into large(r) code. Ideally we'd +want a smaller threshold with larger consumers and vice-versa, but we have no +way of knowing what will be consuming our list in the desugaring impossible to +set generally correctly. + +The effect of reducing this number will be that 'build' fusion is applied +less often. From a runtime performance perspective, applying 'build' more +liberally on "moderately" sized lists should rarely hurt and will often it can +only expose further optimization opportunities; if no fusion is possible it will +eventually get rule-rewritten back to a list). We do, however, pay in compile +time. +-} +maxBuildLength :: Int +maxBuildLength = 32 + +dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] + -> DsM CoreExpr +-- See Note [Desugaring explicit lists] +dsExplicitList elt_ty Nothing xs + = do { dflags <- getDynFlags + ; xs' <- mapM dsLExprNoLP xs + ; if xs' `lengthExceeds` maxBuildLength + -- Don't generate builds if the list is very long. + || null xs' + -- Don't generate builds when the [] constructor will do + || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in Desugar + then return $ mkListExpr elt_ty xs' + else mkBuildExpr elt_ty (mk_build_list xs') } + where + mk_build_list xs' (cons, _) (nil, _) + = return (foldr (App . App (Var cons)) (Var nil) xs') + +dsExplicitList elt_ty (Just fln) xs + = do { list <- dsExplicitList elt_ty Nothing xs + ; dflags <- getDynFlags + ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } + +dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr +dsArithSeq expr (From from) + = App <$> dsExpr expr <*> dsLExprNoLP from +dsArithSeq expr (FromTo from to) + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from Nothing to + expr' <- dsExpr expr + from' <- dsLExprNoLP from + to' <- dsLExprNoLP to + return $ mkApps expr' [from', to'] +dsArithSeq expr (FromThen from thn) + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] +dsArithSeq expr (FromThenTo from thn to) + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from (Just thn) to + expr' <- dsExpr expr + from' <- dsLExprNoLP from + thn' <- dsLExprNoLP thn + to' <- dsLExprNoLP to + return $ mkApps expr' [from', thn', to'] + +{- +Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're +handled in DsListComp). Basically does the translation given in the +Haskell 98 report: +-} + +dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr +dsDo stmts + = goL stmts + where + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + + go _ (LastStmt body _ _) stmts + = dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (BodyStmt rhs then_expr _ _) stmts + = do { rhs2 <- dsLExpr rhs + ; warnDiscardedDoBindings rhs (exprType rhs2) + ; rest <- goL stmts + ; dsSyntaxExpr then_expr [rhs2, rest] } + + go _ (LetStmt binds) stmts + = do { rest <- goL stmts + ; dsLocalBinds binds rest } + + go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts + = do { body <- goL stmts + ; rhs' <- dsLExpr rhs + ; var <- selectSimpleMatchVarL pat + ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } + + go _ (ApplicativeStmt args mb_join body_ty) stmts + = do { + let + (pats, rhss) = unzip (map (do_arg . snd) args) + + do_arg (ApplicativeArgOne pat expr _) = + (pat, dsLExpr expr) + do_arg (ApplicativeArgMany stmts ret pat) = + (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + + arg_tys = map hsLPatType pats + + ; rhss' <- sequence rhss + + ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty + + ; let fun = L noSrcSpan $ HsLam $ + MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats + body'] + , mg_arg_tys = arg_tys + , mg_res_ty = body_ty + , mg_origin = Generated } + + ; fun' <- dsLExpr fun + ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] + ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') + ; case mb_join of + Nothing -> return expr + Just join_op -> dsSyntaxExpr join_op [expr] } + + go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = return_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_bind_ty = bind_ty + , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts + = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } + where + new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats) + mfix_app bind_op + noSyntaxExpr -- Tuple cannot fail + bind_ty + + tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case + rec_tup_pats = map nlVarPat tup_ids + later_pats = rec_tup_pats + rets = map noLoc rec_rets + mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] + mfix_arg = noLoc $ HsLam + (MG { mg_alts = noLoc [mkSimpleMatch + LambdaExpr + [mfix_pat] body] + , mg_arg_tys = [tup_ty], mg_res_ty = body_ty + , mg_origin = Generated }) + mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats + body = noLoc $ HsDo + DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty + ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly + + go _ (ParStmt {}) _ = panic "dsDo ParStmt" + go _ (TransStmt {}) _ = panic "dsDo TransStmt" + +handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr + -- In a do expression, pattern-match failure just calls + -- the monadic 'fail' rather than throwing an exception +handle_failure pat match fail_op + | matchCanFail match + = do { dflags <- getDynFlags + ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] + ; extractMatchResult match fail_expr } + | otherwise + = extractMatchResult match (error "It can't fail") + +mk_fail_msg :: DynFlags -> Located e -> String +mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ + showPpr dflags (getLoc pat) + +{- +************************************************************************ +* * + Desugaring Variables +* * +************************************************************************ +-} + +dsHsVar :: Bool -- are we directly inside an HsWrap? + -- See Wrinkle in Note [Detecting forced eta expansion] + -> Id -> DsM CoreExpr +dsHsVar w var + | not w + , let bad_tys = badUseOfLevPolyPrimop var ty + , not (null bad_tys) + = do { levPolyPrimopErr var ty bad_tys + ; return unitExpr } -- return something eminently safe + + | otherwise + = return (varToCoreExpr var) -- See Note [Desugaring vars] + + where + ty = idType var + +dsConLike :: Bool -- as in dsHsVar + -> ConLike -> DsM CoreExpr +dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc) +dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of + Just (id, add_void) + | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) + | otherwise -> Var id + _ -> pprPanic "dsConLike" (ppr ps) + +{- +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +-- Warn about certain types of values discarded in monadic bindings (#3263) +warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { warn_unused <- woptM Opt_WarnUnusedDoBind + ; warn_wrong <- woptM Opt_WarnWrongDoBind + ; when (warn_unused || warn_wrong) $ + do { fam_inst_envs <- dsGetFamInstEnvs + ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty + + -- Warn about discarding non-() things in 'monadic' binding + ; if warn_unused && not (isUnitTy norm_elt_ty) + then warnDs (Reason Opt_WarnUnusedDoBind) + (badMonadBind rhs elt_ty) + else + + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + when warn_wrong $ + do { case tcSplitAppTy_maybe norm_elt_ty of + Just (elt_m_ty, _) + | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty + -> warnDs (Reason Opt_WarnWrongDoBind) + (badMonadBind rhs elt_ty) + _ -> return () } } } + + | otherwise -- RHS does have type of form (m ty), which is weird + = return () -- but at lesat this warning is irrelevant + +badMonadBind :: LHsExpr GhcTc -> Type -> SDoc +badMonadBind rhs elt_ty + = vcat [ hang (text "A do-notation statement discarded a result of type") + 2 (quotes (ppr elt_ty)) + , hang (text "Suppress this warning by saying") + 2 (quotes $ text "_ <-" <+> ppr rhs) + ] + +{- +************************************************************************ +* * + Forced eta expansion and levity polymorphism +* * +************************************************************************ + +Note [Detecting forced eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We cannot have levity polymorphic function arguments. See +Note [Levity polymorphism invariants] in CoreSyn. But we *can* have +functions that take levity polymorphism arguments, as long as these +functions are eta-reduced. (See #12708 for an example.) + +However, we absolutely cannot do this for functions that have no +binding (i.e., say True to Id.hasNoBinding), like primops and unboxed +tuple constructors. These get eta-expanded in CorePrep.maybeSaturate. + +Detecting when this is about to happen is a bit tricky, though. When +the desugarer is looking at the Id itself (let's be concrete and +suppose we have (#,#)), we don't know whether it will be levity +polymorphic. So the right spot seems to be to look after the Id has +been applied to its type arguments. To make the algorithm efficient, +it's important to be able to spot ((#,#) @a @b @c @d) without looking +past all the type arguments. We thus require that + * The body of an HsWrap is not an HsWrap. +With that representation invariant, we simply look inside every HsWrap +to see if its body is an HsVar whose Id hasNoBinding. Then, we look +at the wrapped type. If it has any levity polymorphic arguments, reject. + +Interestingly, this approach does not look to see whether the Id in +question will be eta expanded. The logic is this: + * Either the Id in question is saturated or not. + * If it is, then it surely can't have levity polymorphic arguments. + If its wrapped type contains levity polymorphic arguments, reject. + * If it's not, then it can't be eta expanded with levity polymorphic + argument. If its wrapped type contains levity polymorphic arguments, reject. +So, either way, we're good to reject. + +Wrinkle +~~~~~~~ +Not all polymorphic Ids are wrapped in +HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type +application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id +without a wrapper, then that is surely problem and we can reject. + +We thus have a parameter to `dsExpr` that tracks whether or not we are +directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when +we're not directly in an HsWrap, reject. + +-} + +-- | Takes an expression and its instantiated type. If the expression is an +-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments, +-- issue an error. See Note [Detecting forced eta expansion] +checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () +checkForcedEtaExpansion expr ty + | Just var <- case expr of + HsVar (L _ var) -> Just var + HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc) + _ -> Nothing + , let bad_tys = badUseOfLevPolyPrimop var ty + , not (null bad_tys) + = levPolyPrimopErr var ty bad_tys +checkForcedEtaExpansion _ _ = return () + +-- | Is this a hasNoBinding Id with a levity-polymorphic type? +-- Returns the arguments that are levity polymorphic if they are bad; +-- or an empty list otherwise +-- See Note [Detecting forced eta expansion] +badUseOfLevPolyPrimop :: Id -> Type -> [Type] +badUseOfLevPolyPrimop id ty + | hasNoBinding id + = filter isTypeLevPoly arg_tys + | otherwise + = [] + where + (binders, _) = splitPiTys ty + arg_tys = mapMaybe binderRelevantType_maybe binders + +levPolyPrimopErr :: Id -> Type -> [Type] -> DsM () +levPolyPrimopErr primop ty bad_tys + = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:") + 2 (ppr primop <+> dcolon <+> ppr ty) + , hang (text "Levity-polymorphic arguments:") + 2 (vcat (map (\t -> ppr t <+> dcolon <+> ppr (typeKind t)) bad_tys)) ] diff --git a/src/Language/Haskell/Liquid/Desugar/DsExpr.hs-boot b/src/Language/Haskell/Liquid/Desugar/DsExpr.hs-boot index c7a1d35aac..9bdc3518ed 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsExpr.hs-boot +++ b/src/Language/Haskell/Liquid/Desugar/DsExpr.hs-boot @@ -1,10 +1,10 @@ module Language.Haskell.Liquid.Desugar.DsExpr where -import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) -import Var ( Id ) +import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) import Language.Haskell.Liquid.Desugar.DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) +import CoreSyn ( CoreExpr ) +import HsExtension ( GhcTc) -dsExpr :: HsExpr Id -> DsM CoreExpr -dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr -dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsExpr :: HsExpr GhcTc -> DsM CoreExpr +dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr +dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr diff --git a/src/Language/Haskell/Liquid/Desugar/DsForeign.hs b/src/Language/Haskell/Liquid/Desugar/DsForeign.hs index d4c591b085..e26f2702cf 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsForeign.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsForeign.hs @@ -7,9 +7,13 @@ Desugaring foreign declarations (see also DsCCall). -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Liquid.Desugar.DsForeign ( dsForeigns ) where +import Prelude hiding ((<>)) + import TcRnMonad -- temp import CoreSyn @@ -68,14 +72,14 @@ is the same as so we reuse the desugaring code in @DsCCall@ to deal with these. -} -type Binding = (Id, CoreExpr) -- No rec/nonrec structure; - -- the occurrence analyser will sort it all out +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out -dsForeigns :: [LForeignDecl Id] +dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) -dsForeigns' :: [LForeignDecl Id] +dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns' [] = return (NoStubs, nilOL) diff --git a/src/Language/Haskell/Liquid/Desugar/DsGRHSs.hs b/src/Language/Haskell/Liquid/Desugar/DsGRHSs.hs index f2fe5e4a81..f697dd9d6d 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsGRHSs.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsGRHSs.hs @@ -16,7 +16,6 @@ import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( matchSinglePat ) import HsSyn import MkCore import CoreSyn -import Var import Language.Haskell.Liquid.Desugar.DsMonad import Language.Haskell.Liquid.Desugar.DsUtils @@ -41,27 +40,28 @@ producing an expression with a runtime error in the corner if necessary. The type argument gives the type of the @ei@. -} -dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr +dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr dsGuarded grhss rhs_ty = do - match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty + match_result <- dsGRHSs PatBindRhs grhss rhs_ty error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty extractMatchResult match_result error_expr -- In contrast, @dsGRHSs@ produces a @MatchResult@. -dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from - -> GRHSs Id (LHsExpr Id) -- Guarded RHSs +dsGRHSs :: HsMatchContext Name + -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty +dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty = do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 -- NB: nested dsLet inside matchResult ; return match_result2 } -dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult +dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) + -> DsM MatchResult dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty @@ -73,10 +73,10 @@ dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) ************************************************************************ -} -matchGuards :: [GuardStmt Id] -- Guard - -> HsStmtContext Name -- Context - -> LHsExpr Id -- RHS - -> Type -- Type of RHS of guard +matchGuards :: [GuardStmt GhcTc] -- Guard + -> HsStmtContext Name -- Context + -> LHsExpr GhcTc -- RHS + -> Type -- Type of RHS of guard -> DsM MatchResult -- See comments with HsExpr.Stmt re what a BodyStmt means @@ -122,7 +122,7 @@ matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" matchGuards (ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt" -isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) +isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- Returns Just {..} if we're sure that the expression is True -- I.e. * 'True' datacon diff --git a/src/Language/Haskell/Liquid/Desugar/DsListComp.hs b/src/Language/Haskell/Liquid/Desugar/DsListComp.hs index fd49ae0c0a..6b40c48d9b 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsListComp.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsListComp.hs @@ -7,6 +7,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions -} {-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Liquid.Desugar.DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where @@ -41,7 +42,7 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. -} -dsListComp :: [ExprLStmt Id] +dsListComp :: [ExprLStmt GhcTc] -> Type -- Type of entire list -> DsM CoreExpr dsListComp lquals res_ty = do @@ -76,7 +77,7 @@ dsListComp lquals res_ty = do -- This function lets you desugar a inner list comprehension and a list of the binders -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) -dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) +dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) dsInnerListComp (ParStmtBlock stmts bndrs _) = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs list_ty = mkListTy bndrs_tuple_type @@ -89,7 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _) -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id) +dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc) dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap , trS_by = by, trS_using = using }) = do let (from_bndrs, to_bndrs) = unzip binderMap @@ -209,7 +210,7 @@ The introduced tuples are Boxed, but only because I couldn't get it to work with the Unboxed variety. -} -deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr +deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr deListComp [] _ = panic "deListComp" @@ -258,9 +259,9 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" deListComp (ApplicativeStmt {} : _) _ = panic "deListComp ApplicativeStmt" -deBindComp :: OutPat Id +deBindComp :: OutPat GhcTc -> CoreExpr - -> [ExprStmt Id] + -> [ExprStmt GhcTc] -> CoreExpr -> DsM (Expr Id) deBindComp pat core_list1 quals core_list2 = do @@ -314,8 +315,8 @@ TE[ e | p <- l , q ] c n = let \end{verbatim} -} -dfListComp :: Id -> Id -- 'c' and 'n' - -> [ExprStmt Id] -- the rest of the qual's +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt GhcTc] -- the rest of the qual's -> DsM CoreExpr dfListComp _ _ [] = panic "dfListComp" @@ -352,9 +353,9 @@ dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfListComp _ _ (ApplicativeStmt {} : _) = panic "dfListComp ApplicativeStmt" -dfBindComp :: Id -> Id -- 'c' and 'n' - -> (LPat Id, CoreExpr) - -> [ExprStmt Id] -- the rest of the qual's +dfBindComp :: Id -> Id -- 'c' and 'n' + -> (LPat GhcTc, CoreExpr) + -> [ExprStmt GhcTc] -- the rest of the qual's -> DsM CoreExpr dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type @@ -474,7 +475,7 @@ mkUnzipBind _ elt_tys -- -- [:e | qss:] = <<[:e | qss:]>> () [:():] -- -dsPArrComp :: [ExprStmt Id] +dsPArrComp :: [ExprStmt GhcTc] -> DsM CoreExpr -- Special case for parallel comprehension @@ -510,8 +511,8 @@ dsPArrComp qs = do -- no ParStmt in `qs' -- the work horse -- -dePArrComp :: [ExprStmt Id] - -> LPat Id -- the current generator pattern +dePArrComp :: [ExprStmt GhcTc] + -> LPat GhcTc -- the current generator pattern -> CoreExpr -- the current generator expression -> DsM CoreExpr @@ -607,7 +608,7 @@ dePArrComp (ApplicativeStmt {} : _) _ _ = -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr +dePArrParComp :: [ParStmtBlock GhcTc GhcTc] -> [ExprStmt GhcTc] -> DsM CoreExpr dePArrParComp qss quals = do (pQss, ceQss) <- deParStmt qss dePArrComp quals pQss ceQss @@ -634,8 +635,8 @@ dePArrParComp qss quals = do -- generate Core corresponding to `\p -> e' -- deLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat Id -- argument pattern - -> LHsExpr Id -- body + -> LPat GhcTc -- argument pattern + -> LHsExpr GhcTc -- body -> DsM (CoreExpr, Type) deLambda ty p e = mkLambda ty p =<< dsLExpr e @@ -643,7 +644,7 @@ deLambda ty p e = -- generate Core for a lambda pattern match, where the body is already in Core -- mkLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat Id -- argument pattern + -> LPat GhcTc -- argument pattern -> CoreExpr -- desugared body -> DsM (CoreExpr, Type) mkLambda ty p ce = do @@ -667,15 +668,15 @@ parrElemType e = -- Translation for monad comprehensions -- Entry point for monad comprehension desugaring -dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr +dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMonadComp stmts = dsMcStmts stmts -dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr +dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMcStmts [] = panic "dsMcStmts" dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- -dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr +dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr dsMcStmt (LastStmt body _ ret_op) _ = do { body' <- dsLExpr body @@ -797,12 +798,12 @@ matchTuple ids body -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` -dsMcBindStmt :: LPat Id +dsMcBindStmt :: LPat GhcTc -> CoreExpr -- ^ the desugared rhs of the bind statement - -> SyntaxExpr Id - -> SyntaxExpr Id + -> SyntaxExpr GhcTc + -> SyntaxExpr GhcTc -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T - -> [ExprLStmt Id] + -> [ExprLStmt GhcTc] -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts @@ -834,9 +835,9 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts -- returns the desugaring of -- [ (a,b,c) | quals ] -dsInnerMonadComp :: [ExprLStmt Id] - -> [Id] -- Return a tuple of these variables - -> SyntaxExpr Id -- The monomorphic "return" operator +dsInnerMonadComp :: [ExprLStmt GhcTc] + -> [Id] -- Return a tuple of these variables + -> SyntaxExpr GhcTc -- The monomorphic "return" operator -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) @@ -854,7 +855,7 @@ dsInnerMonadComp stmts bndrs ret_op -- , fmap (selN2 :: (t1, t2) -> t2) ys ) mkMcUnzipM :: TransForm - -> HsExpr TcId -- fmap + -> HsExpr GhcTcId -- fmap -> Id -- Of type n (a,b,c) -> [Type] -- [a,b,c] (not levity-polymorphic) -> DsM CoreExpr -- Of type (n a, n b, n c) diff --git a/src/Language/Haskell/Liquid/Desugar/DsMeta.hs b/src/Language/Haskell/Liquid/Desugar/DsMeta.hs index ee4dbfd8f1..98a2384676 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsMeta.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsMeta.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- @@ -17,7 +18,7 @@ module Language.Haskell.Liquid.Desugar.DsMeta( dsBracket ) where -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr ) +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr ) import Language.Haskell.Liquid.Desugar.MatchLit import Language.Haskell.Liquid.Desugar.DsMonad @@ -62,7 +63,7 @@ import Control.Monad import Data.List ----------------------------------------------------------------------------- -dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr +dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr -- Returns a CoreExpr of type TH.ExpQ -- The quoted thing is parameterised over Name, even though it has -- been type checked. We don't want all those type decorations! @@ -99,12 +100,12 @@ dsBracket brack splices -- Declarations ------------------------------------------------------- -repTopP :: LPat Name -> DsM (Core TH.PatQ) +repTopP :: LPat GhcRn -> DsM (Core TH.PatQ) repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) ; pat' <- addBinds ss (repLP pat) ; wrapGenSyms ss pat' } -repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) +repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec])) repTopDs group@(HsGroup { hs_valds = valds , hs_splcds = splcds , hs_tyclds = tyclds @@ -176,12 +177,12 @@ repTopDs group@(HsGroup { hs_valds = valds no_doc (L loc _) = notHandledL loc "Haddock documentation" empty -hsSigTvBinders :: HsValBinds Name -> [Name] +hsSigTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings] hsSigTvBinders binds = concatMap get_scoped_tvs sigs where - get_scoped_tvs :: LSig Name -> [Name] + get_scoped_tvs :: LSig GhcRn -> [Name] -- Both implicit and explicit quantified variables -- We need the implicit ones for f :: forall (a::k). blah -- here 'k' scopes too @@ -260,7 +261,7 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. -- represent associated family instances -- -repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam) @@ -295,7 +296,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, } ------------------------- -repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRoleD (L loc (RoleAnnotDecl tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles @@ -304,9 +305,9 @@ repRoleD (L loc (RoleAnnotDecl tycon roles)) ; return (loc, dec) } ------------------------- -repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] +repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Maybe (Core [TH.TypeQ]) - -> HsDataDefn Name + -> HsDataDefn GhcRn -> DsM (Core TH.DecQ) repDataDefn tc bndrs opt_tys (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig @@ -315,34 +316,34 @@ repDataDefn tc bndrs opt_tys ; derivs1 <- repDerivs mb_derivs ; case (new_or_data, cons) of (NewType, [con]) -> do { con' <- repC con - ; ksig' <- repMaybeLKind ksig + ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc bndrs opt_tys ksig' con' derivs1 } (NewType, _) -> failWithDs (text "Multiple constructors for newtype:" <+> pprQuotedList (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLKind ksig + (DataType, _) -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreList conQTyConName consL ; repData cxt1 tc bndrs opt_tys ksig' cons1 derivs1 } } -repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] - -> LHsType Name +repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] + -> LHsType GhcRn -> DsM (Core TH.DecQ) repSynDecl tc bndrs ty = do { ty1 <- repLTy ty ; repTySyn tc bndrs ty1 } -repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdLName = tc, fdTyVars = tvs, fdResultSig = L _ resultSig, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name + ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs , hsq_dependent = emptyNameSet } resTyVar = case resultSig of @@ -354,7 +355,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, ClosedTypeFamily Nothing -> notHandled "abstract closed type family" (ppr decl) ClosedTypeFamily (Just eqns) -> - do { eqns1 <- mapM repTyFamEqn eqns + do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns ; eqns2 <- coreList tySynEqnQTyConName eqns1 ; result <- repFamilyResultSig resultSig ; inj <- repInjectivityAnn injectivity @@ -370,9 +371,9 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, } -- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig) +repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ) repFamilyResultSig NoSig = repNoSig -repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki +repFamilyResultSig (KindSig ki) = do { ki' <- repLTy ki ; repKindSig ki' } repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr ; repTyVarSig bndr' } @@ -380,17 +381,17 @@ repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named -- result variable. -repFamilyResultSigToMaybeKind :: FamilyResultSig Name - -> DsM (Core (Maybe TH.Kind)) +repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn + -> DsM (Core (Maybe TH.KindQ)) repFamilyResultSigToMaybeKind NoSig = - do { coreNothing kindTyConName } + do { coreNothing kindQTyConName } repFamilyResultSigToMaybeKind (KindSig ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } + do { ki' <- repLTy ki + ; coreJust kindQTyConName ki' } repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" -- | Represent injectivity annotation of a type family -repInjectivityAnn :: Maybe (LInjectivityAnn Name) +repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> DsM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = do { coreNothing injAnnTyConName } @@ -401,17 +402,17 @@ repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2] ; coreJust injAnnTyConName injAnn } -repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] +repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ] repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) -repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ] +repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ] repAssocTyFamDefaults = mapM rep_deflt where -- very like repTyFamEqn, but different in the details - rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ) - rep_deflt (L _ (TyFamEqn { tfe_tycon = tc - , tfe_pats = bndrs - , tfe_rhs = rhs })) + rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ) + rep_deflt (L _ (FamEqn { feqn_tycon = tc + , feqn_pats = bndrs + , feqn_rhs = rhs })) = addTyClTyVarBinds bndrs $ \ _ -> do { tc1 <- lookupLOcc tc ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs) @@ -434,7 +435,7 @@ repLFunDep (L _ (xs, ys)) -- Represent instance declarations -- -repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl ; return (loc, dec) } @@ -445,7 +446,7 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } -repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) +repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds , cid_sigs = prags, cid_tyfam_insts = ats , cid_datafam_insts = adts @@ -473,7 +474,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat , deriv_type = ty })) = do { dec <- addSimpleTyVarBinds tvs $ @@ -485,17 +486,17 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) +repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) = do { let tc_name = tyFamInstDeclLName decl ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; eqn1 <- repTyFamEqn eqn ; repTySynInst tc eqn1 } -repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys - , hsib_vars = var_names } - , tfe_rhs = rhs })) +repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) +repTyFamEqn (HsIB { hsib_vars = var_names + , hsib_body = FamEqn { feqn_pats = tys + , feqn_rhs = rhs }}) = do { let hs_tvs = HsQTvs { hsq_implicit = var_names , hsq_explicit = [] , hsq_dependent = emptyNameSet } -- Yuk @@ -505,10 +506,12 @@ repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys ; rhs1 <- repLTy rhs ; repTySynEqn tys2 rhs1 } } -repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) -repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name - , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names } - , dfid_defn = defn }) +repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) +repDataFamInstD (DataFamInstDecl { dfid_eqn = + (HsIB { hsib_vars = var_names + , hsib_body = FamEqn { feqn_tycon = tc_name + , feqn_pats = tys + , feqn_rhs = defn }})}) = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; let hs_tvs = HsQTvs { hsq_implicit = var_names , hsq_explicit = [] @@ -517,7 +520,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name do { tys1 <- repList typeQTyConName repLTy tys ; repDataDefn tc bndrs (Just tys1) defn } } -repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) +repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name @@ -558,7 +561,7 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] -repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)] +repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] repFixD (L loc (FixitySig names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of @@ -571,7 +574,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir))) ; return (loc,dec) } ; mapM do_one names } -repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) = do { let bndr_names = concatMap ruleBndrNames bndrs ; ss <- mkGenSyms bndr_names @@ -585,13 +588,13 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ; rule2 <- wrapGenSyms ss rule1 ; return (loc, rule2) } -ruleBndrNames :: LRuleBndr Name -> [Name] +ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] ruleBndrNames (L _ (RuleBndrSig n sig)) | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig = unLoc n : vars -repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) +repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) repRuleBndr (L _ (RuleBndr n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } @@ -600,7 +603,7 @@ repRuleBndr (L _ (RuleBndrSig n sig)) ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } -repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp @@ -621,7 +624,7 @@ repAnnProv ModuleAnnProvenance -- Constructors ------------------------------------------------------- -repC :: LConDecl Name -> DsM (Core TH.ConQ) +repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) repC (L _ (ConDeclH98 { con_name = con , con_qvars = Nothing, con_cxt = Nothing , con_details = details })) @@ -679,7 +682,7 @@ repSrcStrictness SrcLazy = rep2 sourceLazyName [] repSrcStrictness SrcStrict = rep2 sourceStrictName [] repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] -repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ)) +repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ)) repBangTy ty = do MkC u <- repSrcUnpackedness su' MkC s <- repSrcStrictness ss' @@ -695,10 +698,10 @@ repBangTy ty = do -- Deriving clauses ------------------------------------------------------- -repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ]) +repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses -repDerivClause :: LHsDerivingClause Name +repDerivClause :: LHsDerivingClause GhcRn -> DsM (Core TH.DerivClauseQ) repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct })) @@ -706,22 +709,22 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct'] where - rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ) + rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) rep_deriv_ty (L _ ty) = repTy ty ------------------------------------------------------- -- Signatures in a class decl, or a group of bindings ------------------------------------------------------- -rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ] +rep_sigs :: [LSig GhcRn] -> DsM [Core TH.DecQ] rep_sigs sigs = do locs_cores <- rep_sigs' sigs return $ de_loc $ sort_by_loc locs_cores -rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sigs' :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] -- We silently ignore ones we don't recognise rep_sigs' = concatMapM rep_sig -rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms rep_sig (L loc (ClassOpSig is_deflt nms ty)) @@ -738,7 +741,7 @@ rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc -rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) rep_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm @@ -746,7 +749,7 @@ rep_ty_sig mk_sig loc sig_ty nm ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -- represents a pattern synonym type signature; -- see Note [Pattern synonym type signatures and Template Haskell] in Convert @@ -756,7 +759,7 @@ rep_patsyn_ty_sig loc sig_ty nm ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -- We must special-case the top-level explicit for-all of a TypeSig -- See Note [Scoped type variables in bindings] @@ -766,7 +769,7 @@ rep_wc_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv + ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv explicit_tvs -- NB: Don't pass any implicit type variables to repList above -- See Note [Don't quantify implicit type variables in quotes] @@ -792,14 +795,15 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan +rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm ; ty1 <- repHsSigType ty ; phases <- repPhases $ inl_act ispec ; let inline = inl_inline ispec - ; pragma <- if isEmptyInlineSpec inline + ; pragma <- if noUserInlineSpec inline then -- SPECIALISE repPragSpec nm1 ty1 phases else -- SPECIALISE INLINE @@ -808,7 +812,8 @@ rep_specialise nm ty ispec loc ; return [(loc, pragma)] } -rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialiseInst ty loc = do { ty1 <- repHsSigType ty ; pragma <- repPragSpecInst ty1 @@ -858,8 +863,8 @@ addSimpleTyVarBinds names thing_inside ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } -addTyVarBinds :: LHsQTyVars Name -- the binders to be added - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env +addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended @@ -870,15 +875,15 @@ addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) ; let fresh_names = fresh_imp_names ++ fresh_exp_names ; term <- addBinds fresh_names $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr + do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr (exp_tvs `zip` fresh_exp_names) ; m kbs } ; wrapGenSyms fresh_names term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -addTyClTyVarBinds :: LHsQTyVars Name - -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) +addTyClTyVarBinds :: LHsQTyVars GhcRn + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -> DsM (Core (TH.Q a)) -- Used for data/newtype declarations, and family instances, @@ -894,41 +899,43 @@ addTyClTyVarBinds tvs m -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs) + do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr + (hsQTvExplicit tvs) ; m kbs } ; wrapGenSyms freshNames term } where + mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv v } -- Produce kinded binder constructors from the Haskell tyvar binders -- -repTyVarBndrWithKind :: LHsTyVarBndr Name - -> Core TH.Name -> DsM (Core TH.TyVarBndr) +repTyVarBndrWithKind :: LHsTyVarBndr GhcRn + -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) repTyVarBndrWithKind (L _ (UserTyVar _)) nm = repPlainTV nm repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm - = repLKind ki >>= repKindedTV nm + = repLTy ki >>= repKindedTV nm -- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr) +repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm ; repPlainTV nm' } repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm - ; ki' <- repLKind ki + ; ki' <- repLTy ki ; repKindedTV nm' ki' } -- represent a type context -- -repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) +repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ) repLContext (L _ ctxt) = repContext ctxt -repContext :: HsContext Name -> DsM (Core TH.CxtQ) +repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt repCtxt preds -repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) +repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body @@ -944,7 +951,7 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } -repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) +repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs -> @@ -963,19 +970,19 @@ repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body -repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) +repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1 -- yield the representation of a list of types -repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] +repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] repLTys tys = mapM repLTy tys -- represent a type -repLTy :: LHsType Name -> DsM (Core TH.TypeQ) +repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ) repLTy (L _ ty) = repTy ty -repForall :: HsType Name -> DsM (Core TH.TypeQ) +repForall :: HsType GhcRn -> DsM (Core TH.TypeQ) -- Arg of repForall is always HsForAllTy or HsQualTy repForall ty | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) @@ -985,11 +992,13 @@ repForall ty ; ty1 <- repLTy tau ; repTForall bndrs ctxt1 ty1 } -repTy :: HsType Name -> DsM (Core TH.TypeQ) +repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty repTy (HsTyVar _ (L _ n)) + | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` constraintKindTyConKey = repTConstraint | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -1038,7 +1047,7 @@ repTy (HsEqTy t1 t2) = do repTapps eq [t1', t2'] repTy (HsKindSig t k) = do t1 <- repLTy t - k1 <- repLKind k + k1 <- repLTy k repTSig t1 k1 repTy (HsSpliceTy splice _) = repSplice splice repTy (HsExplicitListTy _ _ tys) = do @@ -1062,49 +1071,14 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] } --- represent a kind --- -repLKind :: LHsKind Name -> DsM (Core TH.Kind) -repLKind ki - = do { let (kis, ki') = splitHsFunType ki - ; kis_rep <- mapM repLKind kis - ; ki'_rep <- repNonArrowLKind ki' - ; kcon <- repKArrow - ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2 - ; foldrM f ki'_rep kis_rep - } - --- | Represent a kind wrapped in a Maybe -repMaybeLKind :: Maybe (LHsKind Name) - -> DsM (Core (Maybe TH.Kind)) -repMaybeLKind Nothing = - do { coreNothing kindTyConName } -repMaybeLKind (Just ki) = - do { ki' <- repLKind ki - ; coreJust kindTyConName ki' } - -repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) -repNonArrowLKind (L _ ki) = repNonArrowKind ki - -repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) -repNonArrowKind (HsTyVar _ (L _ name)) - | isLiftedTypeKindTyConName name = repKStar - | name `hasKey` constraintKindTyConKey = repKConstraint - | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar - | otherwise = lookupOcc name >>= repKCon -repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f - ; a' <- repLKind a - ; repKApp f' a' - } -repNonArrowKind (HsListTy k) = do { k' <- repLKind k - ; kcon <- repKList - ; repKApp kcon k' - } -repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks - ; kcon <- repKTuple (length ks) - ; repKApps kcon ks' - } -repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) +-- | Represent a type wrapped in a Maybe +repMaybeLTy :: Maybe (LHsKind GhcRn) + -> DsM (Core (Maybe TH.TypeQ)) +repMaybeLTy Nothing = + do { coreNothing kindQTyConName } +repMaybeLTy (Just ki) = + do { ki' <- repLTy ki + ; coreJust kindQTyConName ki' } repRole :: Located (Maybe Role) -> DsM (Core TH.Role) repRole (L _ (Just Nominal)) = rep2 nominalRName [] @@ -1116,7 +1090,7 @@ repRole (L _ Nothing) = rep2 inferRName [] -- Splices ----------------------------------------------------------------------------- -repSplice :: HsSplice Name -> DsM (Core a) +repSplice :: HsSplice GhcRn -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know repSplice (HsTypedSplice _ n _) = rep_splice n @@ -1137,16 +1111,16 @@ rep_splice splice_name -- Expressions ----------------------------------------------------------------------------- -repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) +repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ]) repLEs es = repList expQTyConName repLE es -- FIXME: some of these panics should be converted into proper error messages -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage -repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) +repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) -repE :: HsExpr Name -> DsM (Core TH.ExpQ) +repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) repE (HsVar (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of @@ -1156,7 +1130,7 @@ repE (HsVar (L _ x)) = Just (DsSplice e) -> do { e' <- dsExpr e ; return (MkC e') } } repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) -repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e) +repE (HsOverLabel _ s) = repOverLabel s repE e@(HsRecFld f) = case f of Unambiguous _ x -> repE (HsVar (noLoc x)) @@ -1282,8 +1256,8 @@ repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, -repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = +repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) +repMatchTup (L _ (Match { m_pats = [p], m_grhss = GRHSs guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1294,8 +1268,8 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = ; wrapGenSyms (ss1++ss2) match }}} repMatchTup _ = panic "repMatchTup: case alt with more than one arg" -repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = +repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) +repClauseTup (L _ (Match { m_pats = ps, m_grhss = GRHSs guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1305,7 +1279,7 @@ repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ) +repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] = do {a <- repLE e; repNormal a } repGuards other @@ -1314,7 +1288,8 @@ repGuards other ; gd <- repGuarded (nonEmptyCoreList ys) ; wrapGenSyms (concat xs) gd } -repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) +repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) + -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } @@ -1324,19 +1299,20 @@ repLGRHS (L _ (GRHS ss rhs)) ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' ; return (gs, guarded) } -repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) +repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) = repList fieldExpQTyConName rep_fld flds where - rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp)) + rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) + -> DsM (Core (TH.Q TH.FieldExp)) rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } -repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp]) +repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) repUpdFields = repList fieldExpQTyConName rep_fld where - rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp)) + rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) @@ -1370,10 +1346,10 @@ repUpdFields = repList fieldExpQTyConName rep_fld -- The helper function repSts computes the translation of each sub expression -- and a bunch of prefix bindings denoting the dynamic renaming. -repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) -repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repSts (BindStmt p e _ _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) @@ -1400,7 +1376,8 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) = ; (ss2, zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } where - rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ]) + rep_stmt_block :: ParStmtBlock GhcRn GhcRn + -> DsM ([GenSymBind], Core [TH.StmtQ]) rep_stmt_block (ParStmtBlock stmts _ _) = do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs @@ -1417,7 +1394,7 @@ repSts other = notHandled "Exotic statement" (ppr other) -- Bindings ----------------------------------------------------------- -repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds EmptyLocalBinds = do { core_list <- coreList decQTyConName [] ; return ([], core_list) } @@ -1437,7 +1414,7 @@ repBinds (HsValBinds decs) (de_loc (sort_by_loc prs)) ; return (ss, core_list) } -rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are already in the meta-env rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) @@ -1446,14 +1423,14 @@ rep_val_binds (ValBindsOut binds sigs) rep_val_binds (ValBindsIn _ _) = panic "rep_val_binds: ValBindsIn" -rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] +rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds ; return (de_loc (sort_by_loc binds_w_locs)) } -rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds' :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] rep_binds' = mapM rep_bind . bagToList -rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) +rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are already in the meta-env -- Note GHC treats declarations of a variable (not a pattern) @@ -1462,8 +1439,8 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts - = L _ [L _ (Match _ [] _ - (GRHSs guards (L _ wheres)))] } })) + = L _ [L _ (Match { m_pats = [] + , m_grhss = GRHSs guards (L _ wheres) })] } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -1498,7 +1475,6 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; return (srcLocSpan (getSrcLoc v), ans) } rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig" rep_bind (L loc (PatSynBind (PSB { psb_id = syn , psb_fvs = _fvs , psb_args = args @@ -1520,10 +1496,10 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn -- API. Whereas inside GHC, record pattern synonym selectors and -- their pattern-only bound right hand sides have different names, -- we want to treat them the same in TH. This is the reason why we - -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below. - mkGenArgSyms (PrefixPatSyn args) = mkGenSyms (map unLoc args) - mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] - mkGenArgSyms (RecordPatSyn fields) + -- need an adjusted mkGenArgSyms in the `RecCon` case below. + mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) + mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] + mkGenArgSyms (RecCon fields) = do { let pats = map (unLoc . recordPatSynPatVar) fields sels = map (unLoc . recordPatSynSelectorId) fields ; ss <- mkGenSyms sels @@ -1535,8 +1511,8 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn wrapGenArgSyms :: HsPatSynDetails (Located Name) -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ) - wrapGenArgSyms (RecordPatSyn _) _ dec = return dec - wrapGenArgSyms _ ss dec = wrapGenSyms ss dec + wrapGenArgSyms (RecCon _) _ dec = return dec + wrapGenArgSyms _ ss dec = wrapGenSyms ss dec repPatSynD :: Core TH.Name -> Core TH.PatSynArgsQ @@ -1547,14 +1523,14 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) = rep2 patSynDName [syn, args, dir, pat] repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ) -repPatSynArgs (PrefixPatSyn args) +repPatSynArgs (PrefixCon args) = do { args' <- repList nameTyConName lookupLOcc args ; repPrefixPatSynArgs args' } -repPatSynArgs (InfixPatSyn arg1 arg2) +repPatSynArgs (InfixCon arg1 arg2) = do { arg1' <- lookupLOcc arg1 ; arg2' <- lookupLOcc arg2 ; repInfixPatSynArgs arg1' arg2' } -repPatSynArgs (RecordPatSyn fields) +repPatSynArgs (RecCon fields) = do { sels' <- repList nameTyConName lookupLOcc sels ; repRecordPatSynArgs sels' } where sels = map recordPatSynSelectorId fields @@ -1569,7 +1545,7 @@ repRecordPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ) repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] -repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ) +repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) repPatSynDir Unidirectional = rep2 unidirPatSynName [] repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses })) @@ -1604,8 +1580,9 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like -- (\ p1 .. pn -> exp) by causing an error. -repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ) -repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) +repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) +repLambda (L _ (Match { m_pats = ps + , m_grhss = GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -1623,13 +1600,13 @@ repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m) -- variable should already appear in the environment. -- Process a list of patterns -repLPs :: [LPat Name] -> DsM (Core [TH.PatQ]) +repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ]) repLPs ps = repList patQTyConName repLP ps -repLP :: LPat Name -> DsM (Core TH.PatQ) +repLP :: LPat GhcRn -> DsM (Core TH.PatQ) repLP (L _ p) = repP p -repP :: Pat Name -> DsM (Core TH.PatQ) +repP :: Pat GhcRn -> DsM (Core TH.PatQ) repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } @@ -1654,7 +1631,7 @@ repP (ConPatIn dc details) repPinfix p1' con_str p2' } } where - rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ)) + rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ)) rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } @@ -1975,7 +1952,8 @@ repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) repNormal (MkC e) = rep2 normalBName [e] ------------ Guards ---- -repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn + -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) repLNormalGE g e = do g' <- repLE g e' <- repLE e repNormalGE g' e' @@ -2026,8 +2004,8 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] @@ -2035,8 +2013,8 @@ repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs] -repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con) (MkC derivs) @@ -2045,7 +2023,7 @@ repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con) (MkC derivs) = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs] -repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] +repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Core TH.TypeQ -> DsM (Core TH.DecQ) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -2085,7 +2063,7 @@ repOverlap mb = just = coreJust overlapTyConName -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) @@ -2130,22 +2108,22 @@ repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) repTySynInst (MkC nm) (MkC eqn) = rep2 tySynInstDName [nm, eqn] -repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr] - -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ) +repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ] + -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ) repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) = rep2 dataFamilyDName [nm, tvs, kind] repOpenFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig + -> Core [TH.TyVarBndrQ] + -> Core TH.FamilyResultSigQ -> Core (Maybe TH.InjectivityAnn) -> DsM (Core TH.DecQ) repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) = rep2 openTypeFamilyDName [nm, tvs, result, inj] repClosedFamilyD :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.FamilyResultSig + -> Core [TH.TyVarBndrQ] + -> Core TH.FamilyResultSigQ -> Core (Maybe TH.InjectivityAnn) -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ) @@ -2169,15 +2147,15 @@ repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] repDataCon :: Located Name - -> HsConDeclDetails Name + -> HsConDeclDetails GhcRn -> DsM (Core TH.ConQ) repDataCon con details = do con' <- lookupLOcc con -- See Note [Binders and occurrences] repConstr details Nothing [con'] repGadtDataCons :: [Located Name] - -> HsConDeclDetails Name - -> LHsType Name + -> HsConDeclDetails GhcRn + -> LHsType GhcRn -> DsM (Core TH.ConQ) repGadtDataCons cons details res_ty = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] @@ -2188,8 +2166,8 @@ repGadtDataCons cons details res_ty -- argument is a singleton list -- * for GADTs data constructors second argument is (Just return_type) and -- third argument is a non-empty list -repConstr :: HsConDeclDetails Name - -> Maybe (LHsType Name) +repConstr :: HsConDeclDetails GhcRn + -> Maybe (LHsType GhcRn) -> [Core TH.Name] -> DsM (Core TH.ConQ) repConstr (PrefixCon ps) Nothing [con] @@ -2214,7 +2192,7 @@ repConstr (RecCon (L _ ips)) resTy cons where rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) - rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a) + rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } @@ -2231,7 +2209,7 @@ repConstr _ _ _ = ------------ Types ------------------- -repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ +repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] @@ -2246,7 +2224,7 @@ repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) repTapps f [] = return f repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } -repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) +repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] repTequality :: DsM (Core TH.TypeQ) @@ -2266,6 +2244,12 @@ repTLit (MkC lit) = rep2 litTName [lit] repTWildCard :: DsM (Core TH.TypeQ) repTWildCard = rep2 wildCardTName [] +repTStar :: DsM (Core TH.TypeQ) +repTStar = rep2 starKName [] + +repTConstraint :: DsM (Core TH.TypeQ) +repTConstraint = rep2 constraintKName [] + --------- Type constructors -------------- repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) @@ -2305,59 +2289,30 @@ repPromotedNilTyCon = rep2 promotedNilTName [] repPromotedConsTyCon :: DsM (Core TH.TypeQ) repPromotedConsTyCon = rep2 promotedConsTName [] ------------- Kinds ------------------- +------------ TyVarBndrs ------------------- -repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) +repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ) repPlainTV (MkC nm) = rep2 plainTVName [nm] -repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) +repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ) repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] -repKVar :: Core TH.Name -> DsM (Core TH.Kind) -repKVar (MkC s) = rep2 varKName [s] - -repKCon :: Core TH.Name -> DsM (Core TH.Kind) -repKCon (MkC s) = rep2 conKName [s] - -repKTuple :: Int -> DsM (Core TH.Kind) -repKTuple i = do dflags <- getDynFlags - rep2 tupleKName [mkIntExprInt dflags i] - -repKArrow :: DsM (Core TH.Kind) -repKArrow = rep2 arrowKName [] - -repKList :: DsM (Core TH.Kind) -repKList = rep2 listKName [] - -repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) -repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2] - -repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind) -repKApps f [] = return f -repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks } - -repKStar :: DsM (Core TH.Kind) -repKStar = rep2 starKName [] - -repKConstraint :: DsM (Core TH.Kind) -repKConstraint = rep2 constraintKName [] - ---------------------------------------------------------- -- Type family result signature -repNoSig :: DsM (Core TH.FamilyResultSig) +repNoSig :: DsM (Core TH.FamilyResultSigQ) repNoSig = rep2 noSigName [] -repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig) +repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ) repKindSig (MkC ki) = rep2 kindSigName [ki] -repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig) +repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ) repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] ---------------------------------------------------------- -- Literals -repLiteral :: HsLit -> DsM (Core TH.Lit) +repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit) repLiteral (HsStringPrim _ bs) = do dflags <- getDynFlags word8_ty <- lookupType word8TyConName @@ -2369,9 +2324,9 @@ repLiteral lit = do lit' <- case lit of HsIntPrim _ i -> mk_integer i HsWordPrim _ w -> mk_integer w - HsInt _ i -> mk_integer i - HsFloatPrim r -> mk_rational r - HsDoublePrim r -> mk_rational r + HsInt _ i -> mk_integer (il_value i) + HsFloatPrim _ r -> mk_rational r + HsDoublePrim _ r -> mk_rational r HsCharPrim _ c -> mk_char c _ -> return lit lit_expr <- dsLit lit' @@ -2381,38 +2336,39 @@ repLiteral lit where mb_lit_name = case lit of HsInteger _ _ _ -> Just integerLName - HsInt _ _ -> Just integerLName + HsInt _ _ -> Just integerLName HsIntPrim _ _ -> Just intPrimLName HsWordPrim _ _ -> Just wordPrimLName - HsFloatPrim _ -> Just floatPrimLName - HsDoublePrim _ -> Just doublePrimLName + HsFloatPrim _ _ -> Just floatPrimLName + HsDoublePrim _ _ -> Just doublePrimLName HsChar _ _ -> Just charLName HsCharPrim _ _ -> Just charPrimLName HsString _ _ -> Just stringLName - HsRat _ _ -> Just rationalLName + HsRat _ _ _ -> Just rationalLName _ -> Nothing -mk_integer :: Integer -> DsM HsLit +mk_integer :: Integer -> DsM (HsLit GhcRn) mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger NoSourceText i integer_ty -mk_rational :: FractionalLit -> DsM HsLit + return $ HsInteger noSourceText i integer_ty + +mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty -mk_string :: FastString -> DsM HsLit -mk_string s = return $ HsString NoSourceText s + return $ HsRat def r rat_ty +mk_string :: FastString -> DsM (HsLit GhcRn) +mk_string s = return $ HsString noSourceText s -mk_char :: Char -> DsM HsLit -mk_char c = return $ HsChar NoSourceText c +mk_char :: Char -> DsM (HsLit GhcRn) +mk_char c = return $ HsChar noSourceText c -repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) +repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) = do { lit <- mk_lit val; repLiteral lit } -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used -mk_lit :: OverLitVal -> DsM HsLit -mk_lit (HsIntegral _ i) = mk_integer i +mk_lit :: OverLitVal -> DsM (HsLit GhcRn) +mk_lit (HsIntegral i) = mk_integer (il_value i) mk_lit (HsFractional f) = mk_rational f mk_lit (HsIsString _ s) = mk_string s @@ -2436,16 +2392,22 @@ repSequenceQ ty_a (MkC list) repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ) repUnboundVar (MkC name) = rep2 unboundVarEName [name] +repOverLabel :: FastString -> DsM (Core TH.ExpQ) +repOverLabel fs = do + (MkC s) <- coreStringLit $ unpackFS fs + rep2 labelEName [s] + + ------------ Lists ------------------- -- turn a list of patterns into a single pattern matching a list repList :: Name -> (a -> DsM (Core b)) - -> [a] -> DsM (Core [b]) + -> [a] -> DsM (Core [b]) repList tc_name f args = do { args1 <- mapM f args ; coreList tc_name args1 } -coreList :: Name -- Of the TyCon of the element type +coreList :: Name -- Of the TyCon of the element type -> [Core a] -> DsM (Core [a]) coreList tc_name es = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } diff --git a/src/Language/Haskell/Liquid/Desugar/DsMonad.hs b/src/Language/Haskell/Liquid/Desugar/DsMonad.hs index ada3ff03b0..a163f95b80 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsMonad.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsMonad.hs @@ -49,7 +49,10 @@ module Language.Haskell.Liquid.Desugar.DsMonad ( CanItFail(..), orFail, -- Levity polymorphism - dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs + dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, + + -- Trace injection + pprRuntimeTrace ) where import TcRnMonad @@ -85,9 +88,7 @@ import Maybes import Var (EvVar) import qualified GHC.LanguageExtensions as LangExt import UniqFM ( lookupWithDefaultUFM ) -#ifdef DETERMINISTIC_PROFILING -import CostCentreState -#endif +import Literal ( mkMachString ) import Data.IORef import Control.Monad @@ -108,7 +109,7 @@ instance Outputable DsMatchContext where ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match data EquationInfo - = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn + = EqnInfo { eqn_pats :: [Pat GhcTc], -- The patterns for an eqn eqn_rhs :: MatchResult } -- What to do after match instance Outputable EquationInfo where @@ -315,8 +316,7 @@ it easier to read debugging output. Note [Levity polymorphism checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the Levity Polymorphism paper -, levity +According to the "Levity Polymorphism" paper (PLDI '17), levity polymorphism is forbidden in precisely two places: in the type of a bound term-level argument and in the type of an argument to a function. The paper explains it more fully, but briefly: expressions in these contexts need to be @@ -514,7 +514,7 @@ askNoErrsDs thing_inside mkPrintUnqualifiedDs :: DsM PrintUnqualified mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv -instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where +instance {-# OVERLAPPING #-} MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal -- | Attempt to load the given module and return its exported entities if @@ -757,3 +757,31 @@ dsLookupDPHRdrEnv_maybe occ _ -> pprPanic multipleNames (ppr occ) } where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':" + +-- | Inject a trace message into the compiled program. Whereas +-- pprTrace prints out information *while compiling*, pprRuntimeTrace +-- captures that information and causes it to be printed *at runtime* +-- using Debug.Trace.trace. +-- +-- pprRuntimeTrace hdr doc expr +-- +-- will produce an expression that looks like +-- +-- trace (hdr + doc) expr +-- +-- When using this to debug a module that Debug.Trace depends on, +-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that +-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace, +-- but that doesn't seem worth the effort and maintenance cost. +pprRuntimeTrace :: String -- ^ header + -> SDoc -- ^ information to output + -> CoreExpr -- ^ expression + -> DsM CoreExpr +pprRuntimeTrace str doc expr = do + traceId <- dsLookupGlobalId traceName + unpackCStringId <- dsLookupGlobalId unpackCStringName + dflags <- getDynFlags + let message :: CoreExpr + message = App (Var unpackCStringId) $ + Lit $ mkMachString $ showSDoc dflags (hang (text str) 4 doc) + return $ mkApps (Var traceId) [Type (exprType expr), message, expr] diff --git a/src/Language/Haskell/Liquid/Desugar/DsUsage.hs b/src/Language/Haskell/Liquid/Desugar/DsUsage.hs index 8158a8e122..4544c89c9b 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsUsage.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsUsage.hs @@ -7,6 +7,8 @@ module DsUsage ( #include "HsVersions.h" +import GhcPrelude + import DynFlags import HscTypes import TcRnTypes diff --git a/src/Language/Haskell/Liquid/Desugar/DsUtils.hs b/src/Language/Haskell/Liquid/Desugar/DsUtils.hs index a6e595ea49..e5df011170 100644 --- a/src/Language/Haskell/Liquid/Desugar/DsUtils.hs +++ b/src/Language/Haskell/Liquid/Desugar/DsUtils.hs @@ -1,1004 +1,1005 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Utilities for desugaring - -This module exports some utility functions of no great interest. --} - -{-# LANGUAGE CPP #-} - --- | Utility functions for constructing Core syntax, principally for desugaring -module Language.Haskell.Liquid.Desugar.DsUtils ( - EquationInfo(..), - firstPat, shiftEqns, - - MatchResult(..), CanItFail(..), CaseAlt(..), - cantFailMatchResult, alwaysFailMatchResult, - extractMatchResult, combineMatchResults, - adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, - matchCanFail, mkEvalMatchResult, - mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, - wrapBind, wrapBinds, - - mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - - seqVar, - - -- LHs tuples - mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat, - mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, - - mkSelectorBinds, - - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang - ) where - -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( matchSimply ) -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsLExpr ) - -import HsSyn -import TcHsSyn -import TcType( tcSplitTyConApp ) -import CoreSyn -import Language.Haskell.Liquid.Desugar.DsMonad - -import CoreUtils -import MkCore -import MkId -import Id -import Literal -import TyCon -import DataCon -import PatSyn -import Type -import Coercion -import TysPrim -import TysWiredIn -import BasicTypes -import ConLike -import UniqSet -import UniqSupply -import Module -import PrelNames -import Name( isInternalName ) -import Outputable -import SrcLoc -import Util -import DynFlags -import FastString -import qualified GHC.LanguageExtensions as LangExt - -import TcEvidence - -import Control.Monad ( zipWithM ) - -{- -************************************************************************ -* * -\subsection{ Selecting match variables} -* * -************************************************************************ - -We're about to match against some patterns. We want to make some -@Ids@ to use as match variables. If a pattern has an @Id@ readily at -hand, which should indeed be bound to the pattern as a whole, then use it; -otherwise, make one up. --} - -selectSimpleMatchVarL :: LPat Id -> DsM Id -selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) - --- (selectMatchVars ps tys) chooses variables of type tys --- to use for matching ps against. If the pattern is a variable, --- we try to use that, to save inventing lots of fresh variables. --- --- OLD, but interesting note: --- But even if it is a variable, its type might not match. Consider --- data T a where --- T1 :: Int -> T Int --- T2 :: a -> T a --- --- f :: T a -> a -> Int --- f (T1 i) (x::Int) = x --- f (T2 i) (y::a) = 0 --- Then we must not choose (x::Int) as the matching variable! --- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat - -selectMatchVars :: [Pat Id] -> DsM [Id] -selectMatchVars ps = mapM selectMatchVar ps - -selectMatchVar :: Pat Id -> DsM Id -selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat var) = return (localiseId (unLoc var)) - -- Note [Localise pattern binders] -selectMatchVar (AsPat var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) - -- OK, better make up one... - -{- -Note [Localise pattern binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider module M where - [Just a] = e -After renaming it looks like - module M where - [Just M.a] = e - -We don't generalise, since it's a pattern binding, monomorphic, etc, -so after desugaring we may get something like - M.a = case e of (v:_) -> - case v of Just M.a -> M.a -Notice the "M.a" in the pattern; after all, it was in the original -pattern. However, after optimisation those pattern binders can become -let-binders, and then end up floated to top level. They have a -different *unique* by then (the simplifier is good about maintaining -proper scoping), but it's BAD to have two top-level bindings with the -External Name M.a, because that turns into two linker symbols for M.a. -It's quite rare for this to actually *happen* -- the only case I know -of is tc003 compiled with the 'hpc' way -- but that only makes it -all the more annoying. - -To avoid this, we craftily call 'localiseId' in the desugarer, which -simply turns the External Name for the Id into an Internal one, but -doesn't change the unique. So the desugarer produces this: - M.a{r8} = case e of (v:_) -> - case v of Just a{r8} -> M.a{r8} -The unique is still 'r8', but the binding site in the pattern -is now an Internal Name. Now the simplifier's usual mechanisms -will propagate that Name to all the occurrence sites, as well as -un-shadowing it, so we'll get - M.a{r8} = case e of (v:_) -> - case v of Just a{s77} -> a{s77} -In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr -runs on the output of the desugarer, so all is well by the end of -the desugaring pass. - - -************************************************************************ -* * -* type synonym EquationInfo and access functions for its pieces * -* * -************************************************************************ -\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} - -The ``equation info'' used by @match@ is relatively complicated and -worthy of a type synonym and a few handy functions. --} - -firstPat :: EquationInfo -> Pat Id -firstPat eqn = head (eqn_pats eqn) - -shiftEqns :: [EquationInfo] -> [EquationInfo] --- Drop the first pattern in each equation -shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ] - --- Functions on MatchResults - -matchCanFail :: MatchResult -> Bool -matchCanFail (MatchResult CanFail _) = True -matchCanFail (MatchResult CantFail _) = False - -alwaysFailMatchResult :: MatchResult -alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) - -cantFailMatchResult :: CoreExpr -> MatchResult -cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) - -extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr -extractMatchResult (MatchResult CantFail match_fn) _ - = match_fn (error "It can't fail!") - -extractMatchResult (MatchResult CanFail match_fn) fail_expr = do - (fail_bind, if_it_fails) <- mkFailurePair fail_expr - body <- match_fn if_it_fails - return (mkCoreLet fail_bind body) - - -combineMatchResults :: MatchResult -> MatchResult -> MatchResult -combineMatchResults (MatchResult CanFail body_fn1) - (MatchResult can_it_fail2 body_fn2) - = MatchResult can_it_fail2 body_fn - where - body_fn fail = do body2 <- body_fn2 fail - (fail_bind, duplicatable_expr) <- mkFailurePair body2 - body1 <- body_fn1 duplicatable_expr - return (Let fail_bind body1) - -combineMatchResults match_result1@(MatchResult CantFail _) _ - = match_result1 - -adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult -adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) - -adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult -adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) - = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) - -wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr -wrapBinds [] e = e -wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) - -wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body -- NB: this function must deal with term - | new==old = body -- variables, type variables or coercion variables - | otherwise = Let (NonRec new (varToCoreExpr old)) body - -seqVar :: Var -> CoreExpr -> CoreExpr -seqVar var body = Case (Var var) var (exprType body) - [(DEFAULT, [], body)] - -mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult -mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) - --- (mkViewMatchResult var' viewExpr mr) makes the expression --- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult -mkViewMatchResult var' viewExpr = - adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) - -mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult -mkEvalMatchResult var ty - = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) - -mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult -mkGuardedMatchResult pred_expr (MatchResult _ body_fn) - = MatchResult CanFail (\fail -> do body <- body_fn fail - return (mkIfThenElse pred_expr body fail)) - -mkCoPrimCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of the case - -> [(Literal, MatchResult)] -- Alternatives - -> MatchResult -- Literals are all unlifted -mkCoPrimCaseMatchResult var ty match_alts - = MatchResult CanFail mk_case - where - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) - - sorted_alts = sortWith fst match_alts -- Right order for a Case - mk_alt fail (lit, MatchResult _ body_fn) - = do body <- body_fn fail - return (LitAlt lit, [], body) - -data CaseAlt a = MkCaseAlt{ alt_pat :: a, - alt_bndrs :: [Var], - alt_wrapper :: HsWrapper, - alt_result :: MatchResult } - -mkCoAlgCaseMatchResult - :: DynFlags - -> Id -- Scrutinee - -> Type -- Type of exp - -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) - -> MatchResult -mkCoAlgCaseMatchResult dflags var ty match_alts - | isNewtype -- Newtype case; use a let - = mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 - - | isPArrFakeAlts match_alts - = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts) - | otherwise - = mkDataConCase var ty match_alts - where - isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) - - -- [Interesting: because of GADTs, we can't rely on the type of - -- the scrutinised Id to be sufficiently refined to have a TyCon in it] - - alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } - = head match_alts - -- Stuff for newtype - arg_id1 = head arg_ids1 - var_ty = idType var - (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) - - --- Stuff for parallel arrays - -- - -- Concerning `isPArrFakeAlts': - -- - -- * it is *not* sufficient to just check the type of the type - -- constructor, as we have to be careful not to confuse the real - -- representation of parallel arrays with the fake constructors; - -- moreover, a list of alternatives must not mix fake and real - -- constructors (this is checked earlier on) - -- - -- FIXME: We actually go through the whole list and make sure that - -- either all or none of the constructors are fake parallel - -- array constructors. This is to spot equations that mix fake - -- constructors with the real representation defined in - -- `PrelPArr'. It would be nicer to spot this situation - -- earlier and raise a proper error message, but it can really - -- only happen in `PrelPArr' anyway. - -- - - isPArrFakeAlts :: [CaseAlt DataCon] -> Bool - isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt) - isPArrFakeAlts (alt:alts) = - case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of - (True , True ) -> True - (False, False) -> False - _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" - isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" - -mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult -mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt - -sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] -sort_alts = sortWith (dataConTag . alt_pat) - -mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr -mkPatSynCase var ty alt fail = do - matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getRuntimeRep ty, ty] - let MatchResult _ mkCont = match_result - cont <- mkCoreLams bndrs <$> mkCont fail - return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] - where - MkCaseAlt{ alt_pat = psyn, - alt_bndrs = bndrs, - alt_wrapper = wrapper, - alt_result = match_result} = alt - (matcher, needs_void_lam) = patSynMatcher psyn - - -- See Note [Matchers and builders for pattern synonyms] in PatSyns - -- on these extra Void# arguments - ensure_unstrict cont | needs_void_lam = Lam voidArgId cont - | otherwise = cont - -mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult -mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives" -mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case - where - con1 = alt_pat alt1 - tycon = dataConTyCon con1 - data_cons = tyConDataCons tycon - match_results = map alt_result alts - - sorted_alts :: [CaseAlt DataCon] - sorted_alts = sort_alts alts - - var_ty = idType var - (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes - -- (not that splitTyConApp does, these days) - - mk_case :: CoreExpr -> DsM CoreExpr - mk_case fail = do - alts <- mapM (mk_alt fail) sorted_alts - return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts) - - mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt - mk_alt fail MkCaseAlt{ alt_pat = con, - alt_bndrs = args, - alt_result = MatchResult _ body_fn } - = do { body <- body_fn fail - ; case dataConBoxer con of { - Nothing -> return (DataAlt con, args, body) ; - Just (DCB boxer) -> - do { us <- newUniqueSupply - ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) - ; return (DataAlt con, rep_ids, mkLets binds body) } } } - - mk_default :: CoreExpr -> [CoreAlt] - mk_default fail | exhaustive_case = [] - | otherwise = [(DEFAULT, [], fail)] - - fail_flag :: CanItFail - fail_flag | exhaustive_case - = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] - | otherwise - = CanFail - - mentioned_constructors = mkUniqSet $ map alt_pat alts - un_mentioned_constructors - = mkUniqSet data_cons `minusUniqSet` mentioned_constructors - exhaustive_case = isEmptyUniqSet un_mentioned_constructors - ---- Stuff for parallel arrays --- --- * the following is to desugar cases over fake constructors for --- parallel arrays, which are introduced by `tidy1' in the `PArrPat' --- case --- -mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr -mkPArrCase dflags var ty sorted_alts fail = do - lengthP <- dsDPHBuiltin lengthPVar - alt <- unboxAlt - return (mkWildCase (len lengthP) intTy ty [alt]) - where - elemTy = case splitTyConApp (idType var) of - (_, [elemTy]) -> elemTy - _ -> panic panicMsg - panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" - len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] - -- - unboxAlt = do - l <- newSysLocalDs intPrimTy - indexP <- dsDPHBuiltin indexPVar - alts <- mapM (mkAlt indexP) sorted_alts - return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) - where - dft = (DEFAULT, [], fail) - - -- - -- each alternative matches one array length (corresponding to one - -- fake array constructor), so the match is on a literal; each - -- alternative's body is extended by a local binding for each - -- constructor argument, which are bound to array elements starting - -- with the first - -- - mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do - body <- bodyFun fail - return (LitAlt lit, [], mkCoreLets binds body) - where - lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt)) - binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] - -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] - -{- -************************************************************************ -* * -\subsection{Desugarer's versions of some Core functions} -* * -************************************************************************ --} - -mkErrorAppDs :: Id -- The error function - -> Type -- Type to which it should be applied - -> SDoc -- The error message string to pass - -> DsM CoreExpr - -mkErrorAppDs err_id ty msg = do - src_loc <- getSrcSpanDs - dflags <- getDynFlags - let - full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) - core_msg = Lit (mkMachString full_msg) - -- mkMachString returns a result of type String# - return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) - -{- -'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. - -Note [Desugaring seq (1)] cf Trac #1031 -~~~~~~~~~~~~~~~~~~~~~~~~~ - f x y = x `seq` (y `seq` (# x,y #)) - -The [CoreSyn let/app invariant] means that, other things being equal, because -the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: - - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v - -But that is bad for two reasons: - (a) we now evaluate y before x, and - (b) we can't bind v to an unboxed pair - -Seq is very, very special! So we recognise it right here, and desugar to - case x of _ -> case y of _ -> (# x,y #) - -Note [Desugaring seq (2)] cf Trac #2273 -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let chp = case b of { True -> fst x; False -> 0 } - in chp `seq` ...chp... -Here the seq is designed to plug the space leak of retaining (snd x) -for too long. - -If we rely on the ordinary inlining of seq, we'll get - let chp = case b of { True -> fst x; False -> 0 } - case chp of _ { I# -> ...chp... } - -But since chp is cheap, and the case is an alluring contet, we'll -inline chp into the case scrutinee. Now there is only one use of chp, -so we'll inline a second copy. Alas, we've now ruined the purpose of -the seq, by re-introducing the space leak: - case (case b of {True -> fst x; False -> 0}) of - I# _ -> ...case b of {True -> fst x; False -> 0}... - -We can try to avoid doing this by ensuring that the binder-swap in the -case happens, so we get his at an early stage: - case chp of chp2 { I# -> ...chp2... } -But this is fragile. The real culprit is the source program. Perhaps we -should have said explicitly - let !chp2 = chp in ...chp2... - -But that's painful. So the code here does a little hack to make seq -more robust: a saturated application of 'seq' is turned *directly* into -the case expression, thus: - x `seq` e2 ==> case x of x -> e2 -- Note shadowing! - e1 `seq` e2 ==> case x of _ -> e2 - -So we desugar our example to: - let chp = case b of { True -> fst x; False -> 0 } - case chp of chp { I# -> ...chp... } -And now all is well. - -The reason it's a hack is because if you define mySeq=seq, the hack -won't work on mySeq. - -Note [Desugaring seq (3)] cf Trac #2409 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The isLocalId ensures that we don't turn - True `seq` e -into - case True of True { ... } -which stupidly tries to bind the datacon 'True'. --} - --- NB: Make sure the argument is not levity polymorphic -mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 - | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] - = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] - where - case_bndr = case arg1 of - Var v1 | isInternalName (idName v1) - -> v1 -- Note [Desugaring seq (2) and (3)] - _ -> mkWildValBinder ty1 - -mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore - --- NB: No argument can be levity polymorphic -mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args - -mkCastDs :: CoreExpr -> Coercion -> CoreExpr --- We define a desugarer-specific version of CoreUtils.mkCast, --- because in the immediate output of the desugarer, we can have --- apparently-mis-matched coercions: E.g. --- let a = b --- in (x :: a) |> (co :: b ~ Int) --- Lint know about type-bindings for let and does not complain --- So here we do not make the assertion checks that we make in --- CoreUtils.mkCast; and we do less peephole optimisation too -mkCastDs e co | isReflCo co = e - | otherwise = Cast e co - -{- -************************************************************************ -* * - Tuples and selector bindings -* * -************************************************************************ - -This is used in various places to do with lazy patterns. -For each binder $b$ in the pattern, we create a binding: -\begin{verbatim} - b = case v of pat' -> b' -\end{verbatim} -where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. - -ToDo: making these bindings should really depend on whether there's -much work to be done per binding. If the pattern is complex, it -should be de-mangled once, into a tuple (and then selected from). -Otherwise the demangling can be in-line in the bindings (as here). - -Boring! Boring! One error message per binder. The above ToDo is -even more helpful. Something very similar happens for pattern-bound -expressions. - -Note [mkSelectorBinds] -~~~~~~~~~~~~~~~~~~~~~~ -mkSelectorBinds is used to desugar a pattern binding {p = e}, -in a binding group: - let { ...; p = e; ... } in body -where p binds x,y (this list of binders can be empty). -There are two cases. - ------- Special case (A) ------- - For a pattern that is just a variable, - let !x = e in body - ==> - let x = e in x `seq` body - So we return the binding, with 'x' as the variable to seq. - ------- Special case (B) ------- - For a pattern that is essentially just a tuple: - * A product type, so cannot fail - * Only one level, so that - - generating multiple matches is fine - - seq'ing it evaluates the same as matching it - Then instead we generate - { v = e - ; x = case v of p -> x - ; y = case v of p -> y } - with 'v' as the variable to force - ------- General case (C) ------- - In the general case we generate these bindings: - let { ...; p = e; ... } in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - in t `seq` body - - Note that we return 't' as the variable to force if the pattern - is strict (i.e. with -XStrict or an outermost-bang-pattern) - - Note that (A) /includes/ the situation where - - * The pattern binds exactly one variable - let !(Just (Just x) = e in body - ==> - let { t = case e of Just (Just v) -> Unit v - ; v = case t of Unit v -> v } - in t `seq` body - The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn - Note that forcing 't' makes the pattern match happen, - but does not force 'v'. - - * The pattern binds no variables - let !(True,False) = e in body - ==> - let t = case e of (True,False) -> () - in t `seq` body - - ------- Examples ---------- - * !(_, (_, a)) = e - ==> - t = case e of (_, (_, a)) -> Unit a - a = case t of Unit a -> a - - Note that - - Forcing 't' will force the pattern to match fully; - e.g. will diverge if (snd e) is bottom - - But 'a' itself is not forced; it is wrapped in a one-tuple - (see Note [One-tuples] in TysWiredIn) - - * !(Just x) = e - ==> - t = case e of Just x -> Unit x - x = case t of Unit x -> x - - Again, forcing 't' will fail if 'e' yields Nothing. - -Note that even though this is rather general, the special cases -work out well: - -* One binder, not -XStrict: - - let Just (Just v) = e in body - ==> - let t = case e of Just (Just v) -> Unit v - v = case t of Unit v -> v - in body - ==> - let v = case (case e of Just (Just v) -> Unit v) of - Unit v -> v - in body - ==> - let v = case e of Just (Just v) -> v - in body - -* Non-recursive, -XStrict - let p = e in body - ==> - let { t = case e of p -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> x } - in t `seq` body - ==> {inline seq, float x,y bindings inwards} - let t = case e of p -> (x,y) in - case t of t' -> - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {inline t, do case of case} - case e of p -> - let t = (x,y) in - let { x = case t' of (x,y) -> x - ; y = case t' of (x,y) -> x } in - body - ==> {case-cancellation, drop dead code} - case e of p -> body - -* Special case (B) is there to avoid fruitlessly taking the tuple - apart and rebuilding it. For example, consider - { K x y = e } - where K is a product constructor. Then general case (A) does: - { t = case e of K x y -> (x,y) - ; x = case t of (x,y) -> x - ; y = case t of (x,y) -> y } - In the lazy case we can't optimise out this fruitless taking apart - and rebuilding. Instead (B) builds - { v = e - ; x = case v of K x y -> x - ; y = case v of K x y -> y } - which is better. --} - -mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly - -> LPat Id -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound - -> DsM (Id,[(Id,CoreExpr)]) - -- ^ Id the rhs is bound to, for desugaring strict - -- binds (see Note [Desugar Strict binds] in DsBinds) - -- and all the desugared binds - -mkSelectorBinds ticks pat val_expr - | L _ (VarPat (L _ v)) <- pat' -- Special case (A) - = return (v, [(v, val_expr)]) - - | is_flat_prod_lpat pat' -- Special case (B) - = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDsNoLP pat_ty - - ; let mk_bind tick bndr_var - -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } - -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' - (Var bndr_var) - (Var bndr_var) -- Neat hack - -- Neat hack: since 'pat' can't fail, the - -- "fail-expr" passed to matchSimply is not - -- used. But it /is/ used for its type, and for - -- that bndr_var is just the ticket. - ; return (bndr_var, mkOptTickBox tick rhs_expr) } - - ; binds <- zipWithM mk_bind ticks' binders - ; return ( val_var, (val_var, val_expr) : binds) } - - | otherwise -- General case (C) - = do { tuple_var <- newSysLocalDs tuple_ty - ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat - local_tuple error_expr - ; let mk_tup_bind tick binder - = (binder, mkOptTickBox tick $ - mkTupleSelector1 local_binders binder - tuple_var (Var tuple_var)) - tup_binds = zipWith mk_tup_bind ticks' binders - ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } - where - pat' = strip_bangs pat - -- Strip the bangs before looking for case (A) or (B) - -- The incoming pattern may well have a bang on it - - binders = collectPatBinders pat' - ticks' = ticks ++ repeat [] - - local_binders = map localiseId binders -- See Note [Localise pattern binders] - local_tuple = mkBigCoreVarTup1 binders - tuple_ty = exprType local_tuple - -strip_bangs :: LPat a -> LPat a --- Remove outermost bangs and parens -strip_bangs (L _ (ParPat p)) = strip_bangs p -strip_bangs (L _ (BangPat p)) = strip_bangs p -strip_bangs lp = lp - -is_flat_prod_lpat :: LPat a -> Bool -is_flat_prod_lpat p = is_flat_prod_pat (unLoc p) - -is_flat_prod_pat :: Pat a -> Bool -is_flat_prod_pat (ParPat p) = is_flat_prod_lpat p -is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) - | RealDataCon con <- pcon - , isProductTyCon (dataConTyCon con) - = all is_triv_lpat (hsConPatArgs ps) -is_flat_prod_pat _ = False - -is_triv_lpat :: LPat a -> Bool -is_triv_lpat p = is_triv_pat (unLoc p) - -is_triv_pat :: Pat a -> Bool -is_triv_pat (VarPat _) = True -is_triv_pat (WildPat _) = True -is_triv_pat (ParPat p) = is_triv_lpat p -is_triv_pat _ = False - - -{- ********************************************************************* -* * - Creating big tuples and their types for full Haskell expressions. - They work over *Ids*, and create tuples replete with their types, - which is whey they are not in HsUtils. -* * -********************************************************************* -} - -mkLHsPatTup :: [LPat Id] -> LPat Id -mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed -mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ - mkVanillaTuplePat lpats Boxed - -mkLHsVarPatTup :: [Id] -> LPat Id -mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) - -mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id --- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) - --- The Big equivalents for the source tuple expressions -mkBigLHsVarTupId :: [Id] -> LHsExpr Id -mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) - -mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id -mkBigLHsTupId = mkChunkified mkLHsTupleExpr - --- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTupId :: [Id] -> LPat Id -mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) - -mkBigLHsPatTupId :: [LPat Id] -> LPat Id -mkBigLHsPatTupId = mkChunkified mkLHsPatTup - -{- -************************************************************************ -* * - Code for pattern-matching and other failures -* * -************************************************************************ - -Generally, we handle pattern matching failure like this: let-bind a -fail-variable, and use that variable if the thing fails: -\begin{verbatim} - let fail.33 = error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 - p3 -> fail.33 - p4 -> ... -\end{verbatim} -Then -\begin{itemize} -\item -If the case can't fail, then there'll be no mention of @fail.33@, and the -simplifier will later discard it. - -\item -If it can fail in only one way, then the simplifier will inline it. - -\item -Only if it is used more than once will the let-binding remain. -\end{itemize} - -There's a problem when the result of the case expression is of -unboxed type. Then the type of @fail.33@ is unboxed too, and -there is every chance that someone will change the let into a case: -\begin{verbatim} - case error "Help" of - fail.33 -> case .... -\end{verbatim} - -which is of course utterly wrong. Rather than drop the condition that -only boxed types can be let-bound, we just turn the fail into a function -for the primitive case: -\begin{verbatim} - let fail.33 :: Void -> Int# - fail.33 = \_ -> error "Help" - in - case x of - p1 -> ... - p2 -> fail.33 void - p3 -> fail.33 void - p4 -> ... -\end{verbatim} - -Now @fail.33@ is a function, so it can be let-bound. - -We would *like* to use join points here; in fact, these "fail variables" are -paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as -CPS functions - i.e. they take "join points" as parameters. It's not impossible -to imagine extending our type system to allow passing join points around (very -carefully), but we certainly don't support it now. - -99.99% of the time, the fail variables wind up as join points in short order -anyway, and the Void# doesn't do much harm. --} - -mkFailurePair :: CoreExpr -- Result type of the whole case expression - -> DsM (CoreBind, -- Binds the newly-created fail variable - -- to \ _ -> expression - CoreExpr) -- Fail variable applied to realWorld# --- See Note [Failure thunks and CPR] -mkFailurePair expr - = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty) - ; fail_fun_arg <- newSysLocalDs voidPrimTy - ; let real_arg = setOneShotLambda fail_fun_arg - ; return (NonRec fail_fun_var (Lam real_arg expr), - App (Var fail_fun_var) (Var voidPrimId)) } - where - ty = exprType expr - -{- -Note [Failure thunks and CPR] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This note predates join points as formal entities (hence the quotation marks). -We can't use actual join points here (see above); if we did, this would also -solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR -join points] in WorkWrap.) - -When we make a failure point we ensure that it -does not look like a thunk. Example: - - let fail = \rw -> error "urk" - in case x of - [] -> fail realWorld# - (y:ys) -> case ys of - [] -> fail realWorld# - (z:zs) -> (y,z) - -Reason: we know that a failure point is always a "join point" and is -entered at most once. Adding a dummy 'realWorld' token argument makes -it clear that sharing is not an issue. And that in turn makes it more -CPR-friendly. This matters a lot: if you don't get it right, you lose -the tail call property. For example, see Trac #3403. - - -************************************************************************ -* * - Ticks -* * -********************************************************************* -} - -mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr -mkOptTickBox = flip (foldr Tick) - -mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr -mkBinaryTickBox ixT ixF e = do - uq <- newUnique - this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq boolTy - let - falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) - trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) - -- - return $ Case e bndr1 boolTy - [ (DataAlt falseDataCon, [], falseBox) - , (DataAlt trueDataCon, [], trueBox) - ] - - - --- ******************************************************************* - --- | Use -XStrict to add a ! or remove a ~ --- --- Examples: --- ~pat => pat -- when -XStrict (even if pat = ~pat') --- !pat => !pat -- always --- pat => !pat -- when -XStrict --- pat => pat -- otherwise -decideBangHood :: DynFlags - -> LPat id -- ^ Original pattern - -> LPat id -- Pattern with bang if necessary -decideBangHood dflags lpat - | not (xopt LangExt.Strict dflags) - = lpat - | otherwise -- -XStrict - = go lpat - where - go lp@(L l p) - = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> lp' - BangPat _ -> lp - _ -> L l (BangPat lp) - --- | Unconditionally make a 'Pat' strict. -addBang :: LPat id -- ^ Original pattern - -> LPat id -- ^ Banged pattern -addBang = go - where - go lp@(L l p) - = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> L l (BangPat lp') - BangPat _ -> lp - _ -> L l (BangPat lp) +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utilities for desugaring + +This module exports some utility functions of no great interest. +-} + +{-# LANGUAGE CPP #-} + +-- | Utility functions for constructing Core syntax, principally for desugaring +module Language.Haskell.Liquid.Desugar.DsUtils ( + EquationInfo(..), + firstPat, shiftEqns, + + MatchResult(..), CanItFail(..), CaseAlt(..), + cantFailMatchResult, alwaysFailMatchResult, + extractMatchResult, combineMatchResults, + adjustMatchResult, adjustMatchResultDs, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, + matchCanFail, mkEvalMatchResult, + mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, + wrapBind, wrapBinds, + + mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, + + seqVar, + + -- LHs tuples + mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat, + mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId, + + mkSelectorBinds, + + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang + ) where + +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( matchSimply ) +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsLExpr ) + +import HsSyn +import TcHsSyn +import TcType( tcSplitTyConApp ) +import CoreSyn +import Language.Haskell.Liquid.Desugar.DsMonad + +import CoreUtils +import MkCore +import MkId +import Id +import Literal +import TyCon +import DataCon +import PatSyn +import Type +import Coercion +import TysPrim +import TysWiredIn +import BasicTypes +import ConLike +import UniqSet +import UniqSupply +import Module +import PrelNames +import Name( isInternalName ) +import Outputable +import SrcLoc +import Util +import DynFlags +import FastString +import qualified GHC.LanguageExtensions as LangExt + +import TcEvidence + +import Control.Monad ( zipWithM ) + +{- +************************************************************************ +* * +\subsection{ Selecting match variables} +* * +************************************************************************ + +We're about to match against some patterns. We want to make some +@Ids@ to use as match variables. If a pattern has an @Id@ readily at +hand, which should indeed be bound to the pattern as a whole, then use it; +otherwise, make one up. +-} + +selectSimpleMatchVarL :: LPat GhcTc -> DsM Id +selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) + +-- (selectMatchVars ps tys) chooses variables of type tys +-- to use for matching ps against. If the pattern is a variable, +-- we try to use that, to save inventing lots of fresh variables. +-- +-- OLD, but interesting note: +-- But even if it is a variable, its type might not match. Consider +-- data T a where +-- T1 :: Int -> T Int +-- T2 :: a -> T a +-- +-- f :: T a -> a -> Int +-- f (T1 i) (x::Int) = x +-- f (T2 i) (y::a) = 0 +-- Then we must not choose (x::Int) as the matching variable! +-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat + +selectMatchVars :: [Pat GhcTc] -> DsM [Id] +selectMatchVars ps = mapM selectMatchVar ps + +selectMatchVar :: Pat GhcTc -> DsM Id +selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (VarPat var) = return (localiseId (unLoc var)) + -- Note [Localise pattern binders] +selectMatchVar (AsPat var _) = return (unLoc var) +selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) + -- OK, better make up one... + +{- +Note [Localise pattern binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider module M where + [Just a] = e +After renaming it looks like + module M where + [Just M.a] = e + +We don't generalise, since it's a pattern binding, monomorphic, etc, +so after desugaring we may get something like + M.a = case e of (v:_) -> + case v of Just M.a -> M.a +Notice the "M.a" in the pattern; after all, it was in the original +pattern. However, after optimisation those pattern binders can become +let-binders, and then end up floated to top level. They have a +different *unique* by then (the simplifier is good about maintaining +proper scoping), but it's BAD to have two top-level bindings with the +External Name M.a, because that turns into two linker symbols for M.a. +It's quite rare for this to actually *happen* -- the only case I know +of is tc003 compiled with the 'hpc' way -- but that only makes it +all the more annoying. + +To avoid this, we craftily call 'localiseId' in the desugarer, which +simply turns the External Name for the Id into an Internal one, but +doesn't change the unique. So the desugarer produces this: + M.a{r8} = case e of (v:_) -> + case v of Just a{r8} -> M.a{r8} +The unique is still 'r8', but the binding site in the pattern +is now an Internal Name. Now the simplifier's usual mechanisms +will propagate that Name to all the occurrence sites, as well as +un-shadowing it, so we'll get + M.a{r8} = case e of (v:_) -> + case v of Just a{s77} -> a{s77} +In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr +runs on the output of the desugarer, so all is well by the end of +the desugaring pass. + + +************************************************************************ +* * +* type synonym EquationInfo and access functions for its pieces * +* * +************************************************************************ +\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} + +The ``equation info'' used by @match@ is relatively complicated and +worthy of a type synonym and a few handy functions. +-} + +firstPat :: EquationInfo -> Pat GhcTc +firstPat eqn = head (eqn_pats eqn) + +shiftEqns :: [EquationInfo] -> [EquationInfo] +-- Drop the first pattern in each equation +shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ] + +-- Functions on MatchResults + +matchCanFail :: MatchResult -> Bool +matchCanFail (MatchResult CanFail _) = True +matchCanFail (MatchResult CantFail _) = False + +alwaysFailMatchResult :: MatchResult +alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) + +cantFailMatchResult :: CoreExpr -> MatchResult +cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) + +extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr +extractMatchResult (MatchResult CantFail match_fn) _ + = match_fn (error "It can't fail!") + +extractMatchResult (MatchResult CanFail match_fn) fail_expr = do + (fail_bind, if_it_fails) <- mkFailurePair fail_expr + body <- match_fn if_it_fails + return (mkCoreLet fail_bind body) + + +combineMatchResults :: MatchResult -> MatchResult -> MatchResult +combineMatchResults (MatchResult CanFail body_fn1) + (MatchResult can_it_fail2 body_fn2) + = MatchResult can_it_fail2 body_fn + where + body_fn fail = do body2 <- body_fn2 fail + (fail_bind, duplicatable_expr) <- mkFailurePair body2 + body1 <- body_fn1 duplicatable_expr + return (Let fail_bind body1) + +combineMatchResults match_result1@(MatchResult CantFail _) _ + = match_result1 + +adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult +adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) + = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) + +adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult +adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) + = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) + +wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr +wrapBinds [] e = e +wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) + +wrapBind :: Var -> Var -> CoreExpr -> CoreExpr +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body + +seqVar :: Var -> CoreExpr -> CoreExpr +seqVar var body = Case (Var var) var (exprType body) + [(DEFAULT, [], body)] + +mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult +mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) + +-- (mkViewMatchResult var' viewExpr mr) makes the expression +-- let var' = viewExpr in mr +mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult +mkViewMatchResult var' viewExpr = + adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) + +mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult +mkEvalMatchResult var ty + = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) + +mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult +mkGuardedMatchResult pred_expr (MatchResult _ body_fn) + = MatchResult CanFail (\fail -> do body <- body_fn fail + return (mkIfThenElse pred_expr body fail)) + +mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of the case + -> [(Literal, MatchResult)] -- Alternatives + -> MatchResult -- Literals are all unlifted +mkCoPrimCaseMatchResult var ty match_alts + = MatchResult CanFail mk_case + where + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + + sorted_alts = sortWith fst match_alts -- Right order for a Case + mk_alt fail (lit, MatchResult _ body_fn) + = do body <- body_fn fail + return (LitAlt lit, [], body) + +data CaseAlt a = MkCaseAlt{ alt_pat :: a, + alt_bndrs :: [Var], + alt_wrapper :: HsWrapper, + alt_result :: MatchResult } + +mkCoAlgCaseMatchResult + :: DynFlags + -> Id -- Scrutinee + -> Type -- Type of exp + -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult +mkCoAlgCaseMatchResult dflags var ty match_alts + | isNewtype -- Newtype case; use a let + = mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 + + | isPArrFakeAlts match_alts + = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts) + | otherwise + = mkDataConCase var ty match_alts + where + isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) + + -- [Interesting: because of GADTs, we can't rely on the type of + -- the scrutinised Id to be sufficiently refined to have a TyCon in it] + + alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } + = head match_alts + -- Stuff for newtype + arg_id1 = head arg_ids1 + var_ty = idType var + (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) + + --- Stuff for parallel arrays + -- + -- Concerning `isPArrFakeAlts': + -- + -- * it is *not* sufficient to just check the type of the type + -- constructor, as we have to be careful not to confuse the real + -- representation of parallel arrays with the fake constructors; + -- moreover, a list of alternatives must not mix fake and real + -- constructors (this is checked earlier on) + -- + -- FIXME: We actually go through the whole list and make sure that + -- either all or none of the constructors are fake parallel + -- array constructors. This is to spot equations that mix fake + -- constructors with the real representation defined in + -- `PrelPArr'. It would be nicer to spot this situation + -- earlier and raise a proper error message, but it can really + -- only happen in `PrelPArr' anyway. + -- + + isPArrFakeAlts :: [CaseAlt DataCon] -> Bool + isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt) + isPArrFakeAlts (alt:alts) = + case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of + (True , True ) -> True + (False, False) -> False + _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" + isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" + +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult +mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt + +sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] +sort_alts = sortWith (dataConTag . alt_pat) + +mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr +mkPatSynCase var ty alt fail = do + matcher <- dsLExpr $ mkLHsWrap wrapper $ + nlHsTyApp matcher [getRuntimeRep ty, ty] + let MatchResult _ mkCont = match_result + cont <- mkCoreLams bndrs <$> mkCont fail + return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] + where + MkCaseAlt{ alt_pat = psyn, + alt_bndrs = bndrs, + alt_wrapper = wrapper, + alt_result = match_result} = alt + (matcher, needs_void_lam) = patSynMatcher psyn + + -- See Note [Matchers and builders for pattern synonyms] in PatSyns + -- on these extra Void# arguments + ensure_unstrict cont | needs_void_lam = Lam voidArgId cont + | otherwise = cont + +mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult +mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives" +mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case + where + con1 = alt_pat alt1 + tycon = dataConTyCon con1 + data_cons = tyConDataCons tycon + match_results = map alt_result alts + + sorted_alts :: [CaseAlt DataCon] + sorted_alts = sort_alts alts + + var_ty = idType var + (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + + mk_case :: CoreExpr -> DsM CoreExpr + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts) + + mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt + mk_alt fail MkCaseAlt{ alt_pat = con, + alt_bndrs = args, + alt_result = MatchResult _ body_fn } + = do { body <- body_fn fail + ; case dataConBoxer con of { + Nothing -> return (DataAlt con, args, body) ; + Just (DCB boxer) -> + do { us <- newUniqueSupply + ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) + ; return (DataAlt con, rep_ids, mkLets binds body) } } } + + mk_default :: CoreExpr -> [CoreAlt] + mk_default fail | exhaustive_case = [] + | otherwise = [(DEFAULT, [], fail)] + + fail_flag :: CanItFail + fail_flag | exhaustive_case + = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] + | otherwise + = CanFail + + mentioned_constructors = mkUniqSet $ map alt_pat alts + un_mentioned_constructors + = mkUniqSet data_cons `minusUniqSet` mentioned_constructors + exhaustive_case = isEmptyUniqSet un_mentioned_constructors + +--- Stuff for parallel arrays +-- +-- * the following is to desugar cases over fake constructors for +-- parallel arrays, which are introduced by `tidy1' in the `PArrPat' +-- case +-- +mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr + -> DsM CoreExpr +mkPArrCase dflags var ty sorted_alts fail = do + lengthP <- dsDPHBuiltin lengthPVar + alt <- unboxAlt + return (mkWildCase (len lengthP) intTy ty [alt]) + where + elemTy = case splitTyConApp (idType var) of + (_, [elemTy]) -> elemTy + _ -> panic panicMsg + panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" + len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] + -- + unboxAlt = do + l <- newSysLocalDs intPrimTy + indexP <- dsDPHBuiltin indexPVar + alts <- mapM (mkAlt indexP) sorted_alts + return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) + where + dft = (DEFAULT, [], fail) + + -- + -- each alternative matches one array length (corresponding to one + -- fake array constructor), so the match is on a literal; each + -- alternative's body is extended by a local binding for each + -- constructor argument, which are bound to array elements starting + -- with the first + -- + mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do + body <- bodyFun fail + return (LitAlt lit, [], mkCoreLets binds body) + where + lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt)) + binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] + -- + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] + +{- +************************************************************************ +* * +\subsection{Desugarer's versions of some Core functions} +* * +************************************************************************ +-} + +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> SDoc -- The error message string to pass + -> DsM CoreExpr + +mkErrorAppDs err_id ty msg = do + src_loc <- getSrcSpanDs + dflags <- getDynFlags + let + full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) + core_msg = Lit (mkMachString full_msg) + -- mkMachString returns a result of type String# + return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) + +{- +'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. + +Note [Desugaring seq (1)] cf Trac #1031 +~~~~~~~~~~~~~~~~~~~~~~~~~ + f x y = x `seq` (y `seq` (# x,y #)) + +The [CoreSyn let/app invariant] means that, other things being equal, because +the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + +But that is bad for two reasons: + (a) we now evaluate y before x, and + (b) we can't bind v to an unboxed pair + +Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + +Note [Desugaring seq (2)] cf Trac #2273 +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... +Here the seq is designed to plug the space leak of retaining (snd x) +for too long. + +If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + +But since chp is cheap, and the case is an alluring contet, we'll +inline chp into the case scrutinee. Now there is only one use of chp, +so we'll inline a second copy. Alas, we've now ruined the purpose of +the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + +We can try to avoid doing this by ensuring that the binder-swap in the +case happens, so we get his at an early stage: + case chp of chp2 { I# -> ...chp2... } +But this is fragile. The real culprit is the source program. Perhaps we +should have said explicitly + let !chp2 = chp in ...chp2... + +But that's painful. So the code here does a little hack to make seq +more robust: a saturated application of 'seq' is turned *directly* into +the case expression, thus: + x `seq` e2 ==> case x of x -> e2 -- Note shadowing! + e1 `seq` e2 ==> case x of _ -> e2 + +So we desugar our example to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } +And now all is well. + +The reason it's a hack is because if you define mySeq=seq, the hack +won't work on mySeq. + +Note [Desugaring seq (3)] cf Trac #2409 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The isLocalId ensures that we don't turn + True `seq` e +into + case True of True { ... } +which stupidly tries to bind the datacon 'True'. +-} + +-- NB: Make sure the argument is not levity polymorphic +mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 + | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] + = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] + where + case_bndr = case arg1 of + Var v1 | isInternalName (idName v1) + -> v1 -- Note [Desugaring seq (2) and (3)] + _ -> mkWildValBinder ty1 + +mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore + +-- NB: No argument can be levity polymorphic +mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args + +mkCastDs :: CoreExpr -> Coercion -> CoreExpr +-- We define a desugarer-specific version of CoreUtils.mkCast, +-- because in the immediate output of the desugarer, we can have +-- apparently-mis-matched coercions: E.g. +-- let a = b +-- in (x :: a) |> (co :: b ~ Int) +-- Lint know about type-bindings for let and does not complain +-- So here we do not make the assertion checks that we make in +-- CoreUtils.mkCast; and we do less peephole optimisation too +mkCastDs e co | isReflCo co = e + | otherwise = Cast e co + +{- +************************************************************************ +* * + Tuples and selector bindings +* * +************************************************************************ + +This is used in various places to do with lazy patterns. +For each binder $b$ in the pattern, we create a binding: +\begin{verbatim} + b = case v of pat' -> b' +\end{verbatim} +where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. + +ToDo: making these bindings should really depend on whether there's +much work to be done per binding. If the pattern is complex, it +should be de-mangled once, into a tuple (and then selected from). +Otherwise the demangling can be in-line in the bindings (as here). + +Boring! Boring! One error message per binder. The above ToDo is +even more helpful. Something very similar happens for pattern-bound +expressions. + +Note [mkSelectorBinds] +~~~~~~~~~~~~~~~~~~~~~~ +mkSelectorBinds is used to desugar a pattern binding {p = e}, +in a binding group: + let { ...; p = e; ... } in body +where p binds x,y (this list of binders can be empty). +There are two cases. + +------ Special case (A) ------- + For a pattern that is just a variable, + let !x = e in body + ==> + let x = e in x `seq` body + So we return the binding, with 'x' as the variable to seq. + +------ Special case (B) ------- + For a pattern that is essentially just a tuple: + * A product type, so cannot fail + * Only one level, so that + - generating multiple matches is fine + - seq'ing it evaluates the same as matching it + Then instead we generate + { v = e + ; x = case v of p -> x + ; y = case v of p -> y } + with 'v' as the variable to force + +------ General case (C) ------- + In the general case we generate these bindings: + let { ...; p = e; ... } in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + in t `seq` body + + Note that we return 't' as the variable to force if the pattern + is strict (i.e. with -XStrict or an outermost-bang-pattern) + + Note that (A) /includes/ the situation where + + * The pattern binds exactly one variable + let !(Just (Just x) = e in body + ==> + let { t = case e of Just (Just v) -> Unit v + ; v = case t of Unit v -> v } + in t `seq` body + The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn + Note that forcing 't' makes the pattern match happen, + but does not force 'v'. + + * The pattern binds no variables + let !(True,False) = e in body + ==> + let t = case e of (True,False) -> () + in t `seq` body + + +------ Examples ---------- + * !(_, (_, a)) = e + ==> + t = case e of (_, (_, a)) -> Unit a + a = case t of Unit a -> a + + Note that + - Forcing 't' will force the pattern to match fully; + e.g. will diverge if (snd e) is bottom + - But 'a' itself is not forced; it is wrapped in a one-tuple + (see Note [One-tuples] in TysWiredIn) + + * !(Just x) = e + ==> + t = case e of Just x -> Unit x + x = case t of Unit x -> x + + Again, forcing 't' will fail if 'e' yields Nothing. + +Note that even though this is rather general, the special cases +work out well: + +* One binder, not -XStrict: + + let Just (Just v) = e in body + ==> + let t = case e of Just (Just v) -> Unit v + v = case t of Unit v -> v + in body + ==> + let v = case (case e of Just (Just v) -> Unit v) of + Unit v -> v + in body + ==> + let v = case e of Just (Just v) -> v + in body + +* Non-recursive, -XStrict + let p = e in body + ==> + let { t = case e of p -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> x } + in t `seq` body + ==> {inline seq, float x,y bindings inwards} + let t = case e of p -> (x,y) in + case t of t' -> + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {inline t, do case of case} + case e of p -> + let t = (x,y) in + let { x = case t' of (x,y) -> x + ; y = case t' of (x,y) -> x } in + body + ==> {case-cancellation, drop dead code} + case e of p -> body + +* Special case (B) is there to avoid fruitlessly taking the tuple + apart and rebuilding it. For example, consider + { K x y = e } + where K is a product constructor. Then general case (A) does: + { t = case e of K x y -> (x,y) + ; x = case t of (x,y) -> x + ; y = case t of (x,y) -> y } + In the lazy case we can't optimise out this fruitless taking apart + and rebuilding. Instead (B) builds + { v = e + ; x = case v of K x y -> x + ; y = case v of K x y -> y } + which is better. +-} + +mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> CoreExpr -- ^ Expression to which the pattern is bound + -> DsM (Id,[(Id,CoreExpr)]) + -- ^ Id the rhs is bound to, for desugaring strict + -- binds (see Note [Desugar Strict binds] in DsBinds) + -- and all the desugared binds + +mkSelectorBinds ticks pat val_expr + | L _ (VarPat (L _ v)) <- pat' -- Special case (A) + = return (v, [(v, val_expr)]) + + | is_flat_prod_lpat pat' -- Special case (B) + = do { let pat_ty = hsLPatType pat' + ; val_var <- newSysLocalDsNoLP pat_ty + + ; let mk_bind tick bndr_var + -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } + -- Remember, 'pat' binds 'bv' + = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + (Var bndr_var) + (Var bndr_var) -- Neat hack + -- Neat hack: since 'pat' can't fail, the + -- "fail-expr" passed to matchSimply is not + -- used. But it /is/ used for its type, and for + -- that bndr_var is just the ticket. + ; return (bndr_var, mkOptTickBox tick rhs_expr) } + + ; binds <- zipWithM mk_bind ticks' binders + ; return ( val_var, (val_var, val_expr) : binds) } + + | otherwise -- General case (C) + = do { tuple_var <- newSysLocalDs tuple_ty + ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat') + ; tuple_expr <- matchSimply val_expr PatBindRhs pat + local_tuple error_expr + ; let mk_tup_bind tick binder + = (binder, mkOptTickBox tick $ + mkTupleSelector1 local_binders binder + tuple_var (Var tuple_var)) + tup_binds = zipWith mk_tup_bind ticks' binders + ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } + where + pat' = strip_bangs pat + -- Strip the bangs before looking for case (A) or (B) + -- The incoming pattern may well have a bang on it + + binders = collectPatBinders pat' + ticks' = ticks ++ repeat [] + + local_binders = map localiseId binders -- See Note [Localise pattern binders] + local_tuple = mkBigCoreVarTup1 binders + tuple_ty = exprType local_tuple + +strip_bangs :: LPat a -> LPat a +-- Remove outermost bangs and parens +strip_bangs (L _ (ParPat p)) = strip_bangs p +strip_bangs (L _ (BangPat p)) = strip_bangs p +strip_bangs lp = lp + +is_flat_prod_lpat :: LPat a -> Bool +is_flat_prod_lpat p = is_flat_prod_pat (unLoc p) + +is_flat_prod_pat :: Pat a -> Bool +is_flat_prod_pat (ParPat p) = is_flat_prod_lpat p +is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps +is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) + | RealDataCon con <- pcon + , isProductTyCon (dataConTyCon con) + = all is_triv_lpat (hsConPatArgs ps) +is_flat_prod_pat _ = False + +is_triv_lpat :: LPat a -> Bool +is_triv_lpat p = is_triv_pat (unLoc p) + +is_triv_pat :: Pat a -> Bool +is_triv_pat (VarPat _) = True +is_triv_pat (WildPat _) = True +is_triv_pat (ParPat p) = is_triv_lpat p +is_triv_pat _ = False + + +{- ********************************************************************* +* * + Creating big tuples and their types for full Haskell expressions. + They work over *Ids*, and create tuples replete with their types, + which is whey they are not in HsUtils. +* * +********************************************************************* -} + +mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc +mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats = L (getLoc (head lpats)) $ + mkVanillaTuplePat lpats Boxed + +mkLHsVarPatTup :: [Id] -> LPat GhcTc +mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) + +mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) + +-- The Big equivalents for the source tuple expressions +mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc +mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) + +mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc +mkBigLHsTupId = mkChunkified mkLHsTupleExpr + +-- The Big equivalents for the source tuple patterns +mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc +mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs) + +mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc +mkBigLHsPatTupId = mkChunkified mkLHsPatTup + +{- +************************************************************************ +* * + Code for pattern-matching and other failures +* * +************************************************************************ + +Generally, we handle pattern matching failure like this: let-bind a +fail-variable, and use that variable if the thing fails: +\begin{verbatim} + let fail.33 = error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 + p3 -> fail.33 + p4 -> ... +\end{verbatim} +Then +\begin{itemize} +\item +If the case can't fail, then there'll be no mention of @fail.33@, and the +simplifier will later discard it. + +\item +If it can fail in only one way, then the simplifier will inline it. + +\item +Only if it is used more than once will the let-binding remain. +\end{itemize} + +There's a problem when the result of the case expression is of +unboxed type. Then the type of @fail.33@ is unboxed too, and +there is every chance that someone will change the let into a case: +\begin{verbatim} + case error "Help" of + fail.33 -> case .... +\end{verbatim} + +which is of course utterly wrong. Rather than drop the condition that +only boxed types can be let-bound, we just turn the fail into a function +for the primitive case: +\begin{verbatim} + let fail.33 :: Void -> Int# + fail.33 = \_ -> error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 void + p3 -> fail.33 void + p4 -> ... +\end{verbatim} + +Now @fail.33@ is a function, so it can be let-bound. + +We would *like* to use join points here; in fact, these "fail variables" are +paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as +CPS functions - i.e. they take "join points" as parameters. It's not impossible +to imagine extending our type system to allow passing join points around (very +carefully), but we certainly don't support it now. + +99.99% of the time, the fail variables wind up as join points in short order +anyway, and the Void# doesn't do much harm. +-} + +mkFailurePair :: CoreExpr -- Result type of the whole case expression + -> DsM (CoreBind, -- Binds the newly-created fail variable + -- to \ _ -> expression + CoreExpr) -- Fail variable applied to realWorld# +-- See Note [Failure thunks and CPR] +mkFailurePair expr + = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty) + ; fail_fun_arg <- newSysLocalDs voidPrimTy + ; let real_arg = setOneShotLambda fail_fun_arg + ; return (NonRec fail_fun_var (Lam real_arg expr), + App (Var fail_fun_var) (Var voidPrimId)) } + where + ty = exprType expr + +{- +Note [Failure thunks and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This note predates join points as formal entities (hence the quotation marks). +We can't use actual join points here (see above); if we did, this would also +solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR +join points] in WorkWrap.) + +When we make a failure point we ensure that it +does not look like a thunk. Example: + + let fail = \rw -> error "urk" + in case x of + [] -> fail realWorld# + (y:ys) -> case ys of + [] -> fail realWorld# + (z:zs) -> (y,z) + +Reason: we know that a failure point is always a "join point" and is +entered at most once. Adding a dummy 'realWorld' token argument makes +it clear that sharing is not an issue. And that in turn makes it more +CPR-friendly. This matters a lot: if you don't get it right, you lose +the tail call property. For example, see Trac #3403. + + +************************************************************************ +* * + Ticks +* * +********************************************************************* -} + +mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr +mkOptTickBox = flip (foldr Tick) + +mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr +mkBinaryTickBox ixT ixF e = do + uq <- newUnique + this_mod <- getModule + let bndr1 = mkSysLocal (fsLit "t1") uq boolTy + let + falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) + trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) + -- + return $ Case e bndr1 boolTy + [ (DataAlt falseDataCon, [], falseBox) + , (DataAlt trueDataCon, [], trueBox) + ] + + + +-- ******************************************************************* + +-- | Use -XStrict to add a ! or remove a ~ +-- +-- Examples: +-- ~pat => pat -- when -XStrict (even if pat = ~pat') +-- !pat => !pat -- always +-- pat => !pat -- when -XStrict +-- pat => pat -- otherwise +decideBangHood :: DynFlags + -> LPat id -- ^ Original pattern + -> LPat id -- Pattern with bang if necessary +decideBangHood dflags lpat + | not (xopt LangExt.Strict dflags) + = lpat + | otherwise -- -XStrict + = go lpat + where + go lp@(L l p) + = case p of + ParPat p -> L l (ParPat (go p)) + LazyPat lp' -> lp' + BangPat _ -> lp + _ -> L l (BangPat lp) + +-- | Unconditionally make a 'Pat' strict. +addBang :: LPat id -- ^ Original pattern + -> LPat id -- ^ Banged pattern +addBang = go + where + go lp@(L l p) + = case p of + ParPat p -> L l (ParPat (go p)) + LazyPat lp' -> L l (BangPat lp') + BangPat _ -> lp + _ -> L l (BangPat lp) diff --git a/src/Language/Haskell/Liquid/Desugar/Match.hs b/src/Language/Haskell/Liquid/Desugar/Match.hs index 41d55ce140..fdf118d53c 100644 --- a/src/Language/Haskell/Liquid/Desugar/Match.hs +++ b/src/Language/Haskell/Liquid/Desugar/Match.hs @@ -7,6 +7,7 @@ The @match@ function -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Liquid.Desugar.Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where @@ -37,19 +38,19 @@ import Coercion ( eqCoercion ) import TcType ( toTcTypeBag ) import TyCon( isNewTyCon ) import TysWiredIn -import ListSetOps import SrcLoc import Maybes import Util import Name import Outputable -import BasicTypes ( isGenerated, fl_value ) +import BasicTypes ( isGenerated, il_value, fl_value ) import FastString import Unique import UniqDFM import Control.Monad( when, unless ) import qualified Data.Map as Map +import Data.List (groupBy) {- ************************************************************************ @@ -58,7 +59,8 @@ import qualified Data.Map as Map * * ************************************************************************ -The function @match@ is basically the same as in the Wadler chapter, +The function @match@ is basically the same as in the Wadler chapter +from "The Implementation of Functional Programming Languages", except it is monadised, to carry around the name supply, info about annotations, etc. @@ -120,44 +122,29 @@ patterns that is examined. The steps carried out are roughly: \item Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add bindings to the second component of the equation-info): -\begin{itemize} -\item -Remove the `as' patterns from column~1. -\item -Make all constructor patterns in column~1 into @ConPats@, notably -@ListPats@ and @TuplePats@. -\item -Handle any irrefutable (or ``twiddle'') @LazyPats@. -\end{itemize} \item Now {\em unmix} the equations into {\em blocks} [w\/ local function -@unmix_eqns@], in which the equations in a block all have variable -patterns in column~1, or they all have constructor patterns in ... +@match_groups@], in which the equations in a block all have the same + match group. (see ``the mixture rule'' in SLPJ). \item -Call @matchEqnBlock@ on each block of equations; it will do the -appropriate thing for each kind of column-1 pattern, usually ending up -in a recursive call to @match@. +Call the right match variant on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern. \end{enumerate} We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). And gluing the ``success expressions'' together isn't quite so pretty. -This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ -(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and -(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em +This @match@ uses @tidyEqnInfo@ +to get `as'- and `twiddle'-patterns out of the way (tidying), before +applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em un}mixes the equations], producing a list of equation-info -blocks, each block having as its first column of patterns either all -constructors, or all variables (or similar beasts), etc. - -@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the -Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ -corresponds roughly to @matchVarCon@. +blocks, each block having as its first column patterns compatible with each other. Note [Match Ids] ~~~~~~~~~~~~~~~~ -Most of the matching fuctions take an Id or [Id] as argument. This Id +Most of the matching functions take an Id or [Id] as argument. This Id is the scrutinee(s) of the match. The desugared expression may sometimes use that Id in a local binding or as a case binder. So it should not have an External name; Lint rejects non-top-level binders @@ -299,12 +286,12 @@ matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) matchOverloadedList _ _ _ = panic "matchOverloadedList" -- decompose the first pattern and leave the rest alone -decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo +decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id +getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc getCoPat (CoPat _ pat _) = pat getCoPat _ = panic "getCoPat" getBangPat (BangPat pat ) = unLoc pat @@ -340,39 +327,40 @@ See also Note [Case elimination: lifted case] in Simplify. ************************************************************************ Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ -which will be scrutinised. This means: -\begin{itemize} -\item -Replace variable patterns @x@ (@x /= v@) with the pattern @_@, -together with the binding @x = v@. -\item -Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. -\item -Removing lazy (irrefutable) patterns (you don't want to know...). -\item -Converting explicit tuple-, list-, and parallel-array-pats into ordinary -@ConPats@. -\item -Convert the literal pat "" to []. -\end{itemize} +which will be scrutinised. -The result of this tidying is that the column of patterns will include -{\em only}: -\begin{description} -\item[@WildPats@:] -The @VarPat@ information isn't needed any more after this. +This makes desugaring the pattern match simpler by transforming some of +the patterns to simpler forms. (Tuples to Constructor Patterns) -\item[@ConPats@:] -@ListPats@, @TuplePats@, etc., are all converted into @ConPats@. +Among other things in the resulting Pattern: +* Variables and irrefutable(lazy) patterns are replaced by Wildcards +* As patterns are replaced by the patterns they wrap. + +The bindings created by the above patterns are put into the returned wrapper +instead. + +This means a definition of the form: + f x = rhs +when called with v get's desugared to the equivalent of: + let x = v + in + f _ = rhs + +The same principle holds for as patterns (@) and +irrefutable/lazy patterns (~). +In the case of irrefutable patterns the irrefutable pattern is pushed into +the binding. + +Pattern Constructors which only represent syntactic sugar are converted into +their desugared representation. +This usually means converting them to Constructor patterns but for some +depends on enabled extensions. (Eg OverloadedLists) + +GHC also tries to convert overloaded Literals into regular ones. + +The result of this tidying is that the column of patterns will include +only these which can be assigned a PatternGroup (see patGroup). -\item[@LitPats@ and @NPats@:] -@LitPats@/@NPats@ of ``known friendly types'' (Int, Char, -Float, Double, at least) are converted to unboxed form; e.g., -\tr{(NPat (HsInt i) _ _)} is converted to: -\begin{verbatim} -(ConPat I# _ _ [LitPat (HsIntPrim i)]) -\end{verbatim} -\end{description} -} tidyEqnInfo :: Id -> EquationInfo @@ -383,12 +371,7 @@ tidyEqnInfo :: Id -> EquationInfo -- one pattern and fiddling the list of bindings. -- -- POST CONDITION: head pattern in the EqnInfo is - -- WildPat - -- ConPat - -- NPat - -- LitPat - -- NPlusKPat - -- but no other + -- one of these for which patGroup is defined. tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) = panic "tidyEqnInfo" @@ -397,21 +380,16 @@ tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do { (wrap, pat') <- tidy1 v pat ; return (wrap, eqn { eqn_pats = do pat' : pats }) } -tidy1 :: Id -- The Id being scrutinised - -> Pat Id -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings to do before the match - Pat Id) -- Equivalent pattern +tidy1 :: Id -- The Id being scrutinised + -> Pat GhcTc -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings to do before the match + Pat GhcTc) -- Equivalent pattern ------------------------------------------------------- -- (pat', mr') = tidy1 v pat mr -- tidies the *outer level only* of pat, giving pat' -- It eliminates many pattern forms (as-patterns, variable patterns, --- list patterns, etc) yielding one of: --- WildPat --- ConPatOut --- LitPat --- NPat --- NPlusKPat +-- list patterns, etc) and returns any created bindings in the wrapper. tidy1 v (ParPat pat) = tidy1 v (unLoc pat) tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) @@ -496,7 +474,7 @@ tidy1 _ non_interesting_pat = return (idDsWrapper, non_interesting_pat) -------------------- -tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id) +tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p @@ -547,7 +525,7 @@ tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) push_bang_into_newtype_arg :: SrcSpan -> Type -- The type of the argument we are pushing -- onto - -> HsConPatDetails Id -> HsConPatDetails Id + -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc -- See Note [Bang patterns and newtypes] -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:_)) @@ -655,7 +633,7 @@ is collected here, in @matchWrapper@. This function takes as arguments: \begin{itemize} \item -Typchecked @Matches@ (of a function definition, or a case or lambda +Typechecked @Matches@ (of a function definition, or a case or lambda expression)---the main input; \item An error message to be inserted into any (runtime) pattern-matching @@ -688,10 +666,10 @@ Call @match@ with all of this information! \end{enumerate} -} -matchWrapper :: HsMatchContext Name -- For shadowing warning messages - -> Maybe (LHsExpr Id) -- The scrutinee, if we check a case expr - -> MatchGroup Id (LHsExpr Id) -- Matches being desugared - -> DsM ([Id], CoreExpr) -- Results +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> Maybe (LHsExpr GhcTc) -- The scrutinee, if we check a case expr + -> MatchGroup GhcTc (LHsExpr GhcTc) -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results {- There is one small problem with the Lambda Patterns, when somebody @@ -741,19 +719,14 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where - mk_eqn_info vars (L _ (Match ctx pats _ grhss)) + mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do { dflags <- getDynFlags - ; let add_bang - | FunRhs {mc_strictness=SrcStrict} <- ctx - = pprTrace "addBang" empty addBang - | otherwise - = decideBangHood dflags - upats = map (unLoc . add_bang) pats + ; let upats = map (unLoc . decideBangHood dflags) pats dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars ; tm_cs <- genCaseTmCs2 mb_scr upats vars ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation] addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation] - dsGRHSs ctxt upats grhss rhs_ty + dsGRHSs ctxt grhss rhs_ty ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } handleWarnings = if isGenerated origin @@ -786,7 +759,7 @@ pattern. It returns an expression. matchSimply :: CoreExpr -- Scrutinee -> HsMatchContext Name -- Match kind - -> LPat Id -- Pattern it should match + -> LPat GhcTc -- Pattern it should match -> CoreExpr -- Return this if it matches -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr @@ -799,7 +772,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id +matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult -- matchSinglePat ensures that the scrutinee is a variable -- and then calls match_single_pat_var @@ -818,7 +791,7 @@ matchSinglePat scrut hs_ctx pat ty match_result ; return (adjustMatchResult (bindNonRec var scrut) match_result') } match_single_pat_var :: Id -- See Note [Match Ids] - -> HsMatchContext Name -> LPat Id + -> HsMatchContext Name -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult match_single_pat_var var ctx pat ty match_result = do { dflags <- getDynFlags @@ -853,7 +826,7 @@ data PatGroup | PgBang -- Bang patterns | PgCo Type -- Coercion patterns; the type is the type -- of the pattern *inside* - | PgView (LHsExpr Id) -- view pattern (e -> p): + | PgView (LHsExpr GhcTc) -- view pattern (e -> p): -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) | PgOverloadedList @@ -884,7 +857,7 @@ groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- (b) none of the gi are empty -- The ordering of equations is unchanged groupEquations dflags eqns - = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] + = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 @@ -982,14 +955,14 @@ sameGroup _ _ = False -- NB we can't assume that the two view expressions have the same type. Consider -- f (e1 -> True) = ... -- f (e2 -> "hi") = ... -viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool +viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool viewLExprEq (e1,_) (e2,_) = lexp e1 e2 where - lexp :: LHsExpr Id -> LHsExpr Id -> Bool + lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool lexp e e' = exp (unLoc e) (unLoc e') --------- - exp :: HsExpr Id -> HsExpr Id -> Bool + exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens exp (HsPar (L _ e)) e' = exp e e' @@ -1034,7 +1007,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp _ _ = False --------- - syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool + syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool syn_exp (SyntaxExpr { syn_expr = expr1 , syn_arg_wraps = arg_wraps1 , syn_res_wrap = res_wrap1 }) @@ -1081,7 +1054,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list _ (_:_) [] = False eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys -patGroup :: DynFlags -> Pat Id -> PatGroup +patGroup :: DynFlags -> Pat GhcTc -> PatGroup patGroup _ (ConPatOut { pat_con = L _ con , pat_arg_tys = tys }) | RealDataCon dcon <- con = PgCon dcon @@ -1090,14 +1063,14 @@ patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = case (oval, isJust mb_neg) of - (HsIntegral _ i, False) -> PgN (fromInteger i) - (HsIntegral _ i, True ) -> PgN (-fromInteger i) + (HsIntegral i, False) -> PgN (fromInteger (il_value i)) + (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) (HsFractional r, False) -> PgN (fl_value r) (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> PgOverS s patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) = case oval of - HsIntegral _ i -> PgNpK i + HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) diff --git a/src/Language/Haskell/Liquid/Desugar/Match.hs-boot b/src/Language/Haskell/Liquid/Desugar/Match.hs-boot index 9893df9bbb..091ff6e36a 100644 --- a/src/Language/Haskell/Liquid/Desugar/Match.hs-boot +++ b/src/Language/Haskell/Liquid/Desugar/Match.hs-boot @@ -5,6 +5,7 @@ import Language.Haskell.Liquid.Desugar.DsMonad ( DsM, EquationInfo, MatchResult import CoreSyn ( CoreExpr ) import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import Name ( Name ) +import HsExtension ( GhcTc ) match :: [Id] -> Type @@ -13,14 +14,14 @@ match :: [Id] matchWrapper :: HsMatchContext Name - -> Maybe (LHsExpr Id) - -> MatchGroup Id (LHsExpr Id) + -> Maybe (LHsExpr GhcTc) + -> MatchGroup GhcTc (LHsExpr GhcTc) -> DsM ([Id], CoreExpr) matchSimply :: CoreExpr -> HsMatchContext Name - -> LPat Id + -> LPat GhcTc -> CoreExpr -> CoreExpr -> DsM CoreExpr @@ -28,7 +29,7 @@ matchSimply matchSinglePat :: CoreExpr -> HsMatchContext Name - -> LPat Id + -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult diff --git a/src/Language/Haskell/Liquid/Desugar/MatchCon.hs b/src/Language/Haskell/Liquid/Desugar/MatchCon.hs index 885c9c9aea..58521113f0 100644 --- a/src/Language/Haskell/Liquid/Desugar/MatchCon.hs +++ b/src/Language/Haskell/Liquid/Desugar/MatchCon.hs @@ -7,6 +7,7 @@ Pattern-matching constructors -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Liquid.Desugar.MatchCon ( matchConFamily, matchPatSyn ) where @@ -20,7 +21,6 @@ import Language.Haskell.Liquid.Desugar.DsMonad import Language.Haskell.Liquid.Desugar.DsUtils import MkCore ( mkCoreLets ) import Util -import ListSetOps ( runs ) import Id import NameEnv import FieldLabel ( flSelector ) @@ -28,6 +28,7 @@ import SrcLoc import DynFlags import Outputable import Control.Monad(liftM) +import Data.List (groupBy) {- We are confronted with the first column of patterns in a set of @@ -110,7 +111,7 @@ matchPatSyn (var:vars) ty eqns _ -> panic "matchPatSyn: not PatSynCon" matchPatSyn _ _ _ = panic "matchPatSyn []" -type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) +type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) matchOneConLike :: [Id] -> Type @@ -149,8 +150,8 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor -- Divide into sub-groups; see Note [Record patterns] ; let groups :: [[(ConArgPats, EquationInfo)]] - groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn) - | eqn <- eqn1:eqns ] + groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn) + | eqn <- eqn1:eqns ] ; match_results <- mapM (match_group arg_vars) groups @@ -192,7 +193,8 @@ compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) compatible_pats _ _ = True -- Prefix or infix con -same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool +same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) + -> Bool same_fields flds1 flds2 = all2 (\(L _ f1) (L _ f2) -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) @@ -209,7 +211,7 @@ conArgPats :: [Type] -- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway -> ConArgPats - -> [Pat Id] + -> [Pat GhcTc] conArgPats _arg_tys (PrefixCon ps) = map unLoc ps conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) @@ -239,7 +241,7 @@ Now consider: In the first we must test y first; in the second we must test x first. So we must divide even the equations for a single constructor T into sub-goups, based on whether they match the same field in the -same order. That's what the (runs compatible_pats) grouping. +same order. That's what the (groupBy compatible_pats) grouping. All non-record patterns are "compatible" in this sense, because the positional patterns (T a b) and (a `T` b) all match the arguments diff --git a/src/Language/Haskell/Liquid/Desugar/MatchLit.hs b/src/Language/Haskell/Liquid/Desugar/MatchLit.hs index d25fc5f082..f77e579d93 100644 --- a/src/Language/Haskell/Liquid/Desugar/MatchLit.hs +++ b/src/Language/Haskell/Liquid/Desugar/MatchLit.hs @@ -18,6 +18,8 @@ module Language.Haskell.Liquid.Desugar.MatchLit ( dsLit, dsOverLit, dsOverLit', import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( match ) import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsSyntaxExpr ) +import Prelude hiding ((<>)) + import Language.Haskell.Liquid.Desugar.DsMonad import Language.Haskell.Liquid.Desugar.DsUtils @@ -47,6 +49,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.Int import Data.Word +import Data.Proxy {- ************************************************************************ @@ -71,38 +74,37 @@ For numeric literals, we try to detect there use at a standard type See also below where we look for @DictApps@ for \tr{plusInt}, etc. -} -dsLit :: HsLit -> DsM CoreExpr +dsLit :: HsLit GhcRn -> DsM CoreExpr dsLit (HsStringPrim _ s) = return (Lit (MachStr s)) dsLit (HsCharPrim _ c) = return (Lit (MachChar c)) dsLit (HsIntPrim _ i) = return (Lit (MachInt i)) dsLit (HsWordPrim _ w) = return (Lit (MachWord w)) dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i)) dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w)) -dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) -dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) - +dsLit (HsFloatPrim _ f) = return (Lit (MachFloat (fl_value f))) +dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar _ c) = return (mkCharExpr c) dsLit (HsString _ str) = mkStringExprFS str dsLit (HsInteger _ i _) = mkIntegerExpr i dsLit (HsInt _ i) = do dflags <- getDynFlags - return (mkIntExpr dflags i) + return (mkIntExpr dflags (il_value i)) -dsLit (HsRat r ty) = do - num <- mkIntegerExpr (numerator (fl_value r)) - denom <- mkIntegerExpr (denominator (fl_value r)) - return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) +dsLit (HsRat _ (FL _ _ val) ty) = do + num <- mkIntegerExpr (numerator val) + denom <- mkIntegerExpr (denominator val) + return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) = case tcSplitTyConApp ty of (tycon, [i_ty]) -> (head (tyConDataCons tycon), i_ty) x -> pprPanic "dsLit" (ppr x) -dsOverLit :: HsOverLit Id -> DsM CoreExpr +dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr dsOverLit lit = do { dflags <- getDynFlags ; warnAboutOverflowedLiterals dflags lit ; dsOverLit' dflags lit } -dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr +dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr -- Post-typechecker, the HsExpr field of an OverLit contains -- (an expression for) the literal value itself dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable @@ -150,25 +152,25 @@ conversionNames -- We can't easily add fromIntegerName, fromRationalName, -- because they are generated by literals -warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM () +warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM () warnAboutOverflowedLiterals dflags lit | wopt Opt_WarnOverflowedLiterals dflags , Just (i, tc) <- getIntegralLit lit - = if tc == intTyConName then check i tc (undefined :: Int) - else if tc == int8TyConName then check i tc (undefined :: Int8) - else if tc == int16TyConName then check i tc (undefined :: Int16) - else if tc == int32TyConName then check i tc (undefined :: Int32) - else if tc == int64TyConName then check i tc (undefined :: Int64) - else if tc == wordTyConName then check i tc (undefined :: Word) - else if tc == word8TyConName then check i tc (undefined :: Word8) - else if tc == word16TyConName then check i tc (undefined :: Word16) - else if tc == word32TyConName then check i tc (undefined :: Word32) - else if tc == word64TyConName then check i tc (undefined :: Word64) + = if tc == intTyConName then check i tc (Proxy :: Proxy Int) + else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) + else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) + else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) + else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) + else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) + else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) + else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) + else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) + else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) else return () | otherwise = return () where - check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM () + check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () check i tc _proxy = when (i < minB || i > maxB) $ do warnDs (Reason Opt_WarnOverflowedLiterals) @@ -197,7 +199,8 @@ We get an erroneous suggestion for but perhaps that does not matter too much. -} -warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM () +warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) + -> LHsExpr GhcTc -> DsM () -- Warns about [2,3 .. 1] which returns the empty list -- Only works for integral types, not floating point warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr @@ -205,7 +208,7 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr , Just (from,tc) <- getLHsIntegralLit fromExpr , Just mThn <- traverse getLHsIntegralLit mThnExpr , Just (to,_) <- getLHsIntegralLit toExpr - , let check :: forall a. (Enum a, Num a) => a -> DsM () + , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () check _proxy = when (null enumeration) $ warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") @@ -215,22 +218,22 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr Nothing -> [fromInteger from .. fromInteger to] Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] - = if tc == intTyConName then check (undefined :: Int) - else if tc == int8TyConName then check (undefined :: Int8) - else if tc == int16TyConName then check (undefined :: Int16) - else if tc == int32TyConName then check (undefined :: Int32) - else if tc == int64TyConName then check (undefined :: Int64) - else if tc == wordTyConName then check (undefined :: Word) - else if tc == word8TyConName then check (undefined :: Word8) - else if tc == word16TyConName then check (undefined :: Word16) - else if tc == word32TyConName then check (undefined :: Word32) - else if tc == word64TyConName then check (undefined :: Word64) - else if tc == integerTyConName then check (undefined :: Integer) + = if tc == intTyConName then check (Proxy :: Proxy Int) + else if tc == int8TyConName then check (Proxy :: Proxy Int8) + else if tc == int16TyConName then check (Proxy :: Proxy Int16) + else if tc == int32TyConName then check (Proxy :: Proxy Int32) + else if tc == int64TyConName then check (Proxy :: Proxy Int64) + else if tc == wordTyConName then check (Proxy :: Proxy Word) + else if tc == word8TyConName then check (Proxy :: Proxy Word8) + else if tc == word16TyConName then check (Proxy :: Proxy Word16) + else if tc == word32TyConName then check (Proxy :: Proxy Word32) + else if tc == word64TyConName then check (Proxy :: Proxy Word64) + else if tc == integerTyConName then check (Proxy :: Proxy Integer) else return () | otherwise = return () -getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name) +getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- See if the expression is an Integral literal -- Remember to look through automatically-added tick-boxes! (Trac #8384) getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e @@ -239,10 +242,10 @@ getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit getLHsIntegralLit _ = Nothing -getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name) -getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty }) +getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) | Just tc <- tyConAppTyCon_maybe ty - = Just (i, tyConName tc) + = Just (il_value i, tyConName tc) getIntegralLit _ = Nothing {- @@ -253,7 +256,7 @@ getIntegralLit _ = Nothing ************************************************************************ -} -tidyLitPat :: HsLit -> Pat Id +tidyLitPat :: HsLit GhcTc -> Pat GhcTc -- Result has only the following HsLits: -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim -- HsDoublePrim, HsStringPrim, HsString @@ -270,13 +273,14 @@ tidyLitPat (HsString src s) tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat +tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat -- We need this argument because tidyNPat is called -- both by Match and by Check, but they tidy LitPats -- slightly differently; and we must desugar -- literals consistently (see Trac #5117) - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type - -> Pat Id + -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc + -> Type + -> Pat GhcTc tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty -- False: Take short cuts only if the literal is not using rebindable syntax -- @@ -305,13 +309,13 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty -- type family Id). In these cases, we can't do the short-cut. type_change = not (outer_ty `eqType` ty) - mk_con_pat :: DataCon -> HsLit -> Pat Id + mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of - (Nothing, HsIntegral _ i) -> Just i - (Just _, HsIntegral _ i) -> Just (-i) + (Nothing, HsIntegral i) -> Just (il_value i) + (Just _, HsIntegral i) -> Just (-(il_value i)) _ -> Nothing mb_str_lit :: Maybe FastString @@ -371,7 +375,7 @@ matchLiterals (var:vars) ty sub_groups matchLiterals [] _ _ = panic "matchLiterals []" --------------------------- -hsLitKey :: DynFlags -> HsLit -> Literal +hsLitKey :: DynFlags -> HsLit GhcTc -> Literal -- Get the Core literal corresponding to a HsLit. -- It only works for primitive types and strings; -- others have been removed by tidy @@ -386,8 +390,8 @@ hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w hsLitKey _ (HsCharPrim _ c) = mkMachChar c -hsLitKey _ (HsFloatPrim f) = mkMachFloat (fl_value f) -hsLitKey _ (HsDoublePrim d) = mkMachDouble (fl_value d) +hsLitKey _ (HsFloatPrim _ f) = mkMachFloat (fl_value f) +hsLitKey _ (HsDoublePrim _ d) = mkMachDouble (fl_value d) hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s) hsLitKey _ l = pprPanic "hsLitKey" (ppr l) diff --git a/src/Language/Haskell/Liquid/Desugar/PmExpr.hs b/src/Language/Haskell/Liquid/Desugar/PmExpr.hs index a09bd8afc6..749f3d867f 100644 --- a/src/Language/Haskell/Liquid/Desugar/PmExpr.hs +++ b/src/Language/Haskell/Liquid/Desugar/PmExpr.hs @@ -14,6 +14,8 @@ module Language.Haskell.Liquid.Desugar.PmExpr ( ) where +import GhcPrelude + import HsSyn import Id import Name @@ -55,15 +57,15 @@ data PmExpr = PmExprVar Name | PmExprCon ConLike [PmExpr] | PmExprLit PmLit | PmExprEq PmExpr PmExpr -- Syntactic equality - | PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr] + | PmExprOther (HsExpr GhcTc) -- Note [PmExprOther in PmExpr] mkPmExprData :: DataCon -> [PmExpr] -> PmExpr mkPmExprData dc args = PmExprCon (RealDataCon dc) args -- | Literals (simple and overloaded ones) for pattern match checking. -data PmLit = PmSLit HsLit -- simple - | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded +data PmLit = PmSLit (HsLit GhcTc) -- simple + | PmOLit Bool {- is it negated? -} (HsOverLit GhcTc) -- overloaded -- | Equality between literals for pattern match checking. eqPmLit :: PmLit -> PmLit -> Bool @@ -228,10 +230,10 @@ substComplexEq x e (ex, ey) -- ----------------------------------------------------------------------- -- ** Lift source expressions (HsExpr Id) to PmExpr -lhsExprToPmExpr :: LHsExpr Id -> PmExpr +lhsExprToPmExpr :: LHsExpr GhcTc -> PmExpr lhsExprToPmExpr (L _ e) = hsExprToPmExpr e -hsExprToPmExpr :: HsExpr Id -> PmExpr +hsExprToPmExpr :: HsExpr GhcTc -> PmExpr hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) @@ -281,7 +283,7 @@ hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle -synExprToPmExpr :: SyntaxExpr Id -> PmExpr +synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr synExprToPmExpr = hsExprToPmExpr . syn_expr -- ignore the wrappers {- diff --git a/src/Language/Haskell/Liquid/Desugar/StaticPtrTable.hs b/src/Language/Haskell/Liquid/Desugar/StaticPtrTable.hs index 329150807c..b580cdad42 100644 --- a/src/Language/Haskell/Liquid/Desugar/StaticPtrTable.hs +++ b/src/Language/Haskell/Liquid/Desugar/StaticPtrTable.hs @@ -42,6 +42,8 @@ -- module Language.Haskell.Liquid.Desugar.StaticPtrTable (sptInitCode) where +import Prelude hiding ((<>)) + import CoreSyn import Module import Outputable diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs index 6e5d92bb2e..6f40cab2ba 100644 --- a/src/Language/Haskell/Liquid/GHC/Interface.hs +++ b/src/Language/Haskell/Liquid/GHC/Interface.hs @@ -42,7 +42,7 @@ import IdInfo import InstEnv import Module import Panic (throwGhcExceptionIO) -import Serialized +-- import Serialized import TcRnTypes import Var import NameSet @@ -184,7 +184,7 @@ configureGhcTargets tgtFiles = do flattenSCCs $ topSortModuleGraph False moduleGraph Nothing let homeNames = moduleName . ms_mod <$> homeModules _ <- setTargetModules homeNames - return homeModules + return $ mkModuleGraph homeModules setTargetModules :: [ModuleName] -> Ghc () setTargetModules modNames = setTargets $ mkTarget <$> modNames @@ -212,15 +212,16 @@ type DepGraphNode = Node Module () reachableModules :: DepGraph -> Module -> [Module] reachableModules depGraph mod = - snd3 <$> tail (reachableG depGraph ((), mod, [])) + undefined -- TODO GHC-8.4 snd3 <$> tail (reachableG depGraph ((), mod, [])) buildDepGraph :: ModuleGraph -> Ghc DepGraph buildDepGraph homeModules = - graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode homeModules + graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode (mgModSummaries homeModules) mkDepGraphNode :: ModSummary -> Ghc DepGraphNode -mkDepGraphNode modSummary = ((), ms_mod modSummary, ) <$> - (filterM isHomeModule =<< modSummaryImports modSummary) +mkDepGraphNode modSummary = undefined -- TODO GHC-8.4 +-- ((), ms_mod modSummary, ) <$> +-- (filterM isHomeModule =<< modSummaryImports modSummary) isHomeModule :: Module -> Ghc Bool isHomeModule mod = do @@ -305,8 +306,8 @@ processModules :: Config -> Either Error LogicMap -> [FilePath] -> DepGraph -> Ghc [GhcInfo] processModules cfg logicMap tgtFiles depGraph homeModules = do -- DO NOT DELETE: liftIO $ putStrLn $ "Process Modules: TargetFiles = " ++ show tgtFiles - catMaybes . snd <$> mapAccumM go emptyModuleEnv homeModules - where + catMaybes . snd <$> mapAccumM go emptyModuleEnv (mgModSummaries homeModules) + where go = processModule cfg logicMap (S.fromList tgtFiles) depGraph processModule :: Config -> Either Error LogicMap -> S.HashSet FilePath -> DepGraph @@ -488,10 +489,12 @@ extractSpecQuotes typechecked = mapMaybe extractSpecQuote anns mod = ms_mod $ pm_mod_summary $ tm_parsed_module typechecked extractSpecQuote :: AnnPayload -> Maybe BPspec -extractSpecQuote payload = +extractSpecQuote payload = undefined -- TODO GHC-8.4 +{- case fromSerialized deserializeWithData payload of Nothing -> Nothing Just qt -> Just $ refreshSymbols $ liquidQuoteSpec qt +-} refreshSymbols :: Data a => a -> a refreshSymbols = everywhere (mkT refreshSymbol) @@ -586,7 +589,7 @@ moduleFiles ext paths names = catMaybes <$> mapM (moduleFile ext paths) names moduleFile :: Ext -> [FilePath] -> String -> Ghc (Maybe FilePath) moduleFile ext paths name | ext `elem` [Hs, LHs] = do - graph <- getModuleGraph + graph <- mgModSummaries <$> getModuleGraph case find (\m -> not (isBootSummary m) && name == moduleNameString (ms_mod_name m)) graph of Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs index d1e4fc8284..2d7ff384df 100644 --- a/src/Language/Haskell/Liquid/GHC/Misc.hs +++ b/src/Language/Haskell/Liquid/GHC/Misc.hs @@ -716,7 +716,7 @@ symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText type Prec = TyPrec lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) -lintCoreBindings = CoreLint.lintCoreBindings (defaultDynFlags undefined) CoreDoNothing +lintCoreBindings = CoreLint.lintCoreBindings (defaultDynFlags undefined (undefined "LlvmTargets")) CoreDoNothing synTyConRhs_maybe :: TyCon -> Maybe Type synTyConRhs_maybe = TC.synTyConRhs_maybe diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs index 02ab1317d1..a1ac7075d7 100644 --- a/src/Language/Haskell/Liquid/Measure.hs +++ b/src/Language/Haskell/Liquid/Measure.hs @@ -26,7 +26,7 @@ import DataCon import GHC hiding (Located) import Outputable (Outputable) import Prelude hiding (error) -import Text.PrettyPrint.HughesPJ hiding (first) +import Text.PrettyPrint.HughesPJ.Compat import Type import Var -- import Data.Serialize (Serialize) @@ -140,8 +140,8 @@ checkDuplicateMeasure ms -- MOVE TO TYPES -instance Monoid (Spec ty bndr) where - mappend s1 s2 +instance Semigroup (Spec ty bndr) where + s1 <> s2 = Spec { measures = measures s1 ++ measures s2 , asmSigs = asmSigs s1 ++ asmSigs s2 , sigs = sigs s1 ++ sigs s2 @@ -179,6 +179,8 @@ instance Monoid (Spec ty bndr) where , autois = M.union (autois s1) (autois s2) } +instance Monoid (Spec ty bndr) where + mappend = (<>) mempty = Spec { measures = [] , asmSigs = [] diff --git a/src/Language/Haskell/Liquid/Misc.hs b/src/Language/Haskell/Liquid/Misc.hs index 2e5a7b08b6..19b4c11a15 100644 --- a/src/Language/Haskell/Liquid/Misc.hs +++ b/src/Language/Haskell/Liquid/Misc.hs @@ -19,7 +19,7 @@ import Data.Time import Data.Function (on) import qualified Data.ByteString as B import Data.ByteString.Char8 (pack, unpack) -import Text.PrettyPrint.HughesPJ ((<>), char, Doc) +import Text.PrettyPrint.HughesPJ.Compat ((<->), char, Doc) import Text.Printf import Language.Fixpoint.Misc import Paths_liquidhaskell @@ -228,7 +228,7 @@ sortDiff x1s x2s = go (sortNub x1s) (sortNub x2s) go [] _ = [] angleBrackets :: Doc -> Doc -angleBrackets p = char '<' <> p <> char '>' +angleBrackets p = char '<' <-> p <-> char '>' mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> M.HashMap a (S.HashSet b) mkGraph = fmap S.fromList . group diff --git a/src/Language/Haskell/Liquid/Termination/Structural.hs b/src/Language/Haskell/Liquid/Termination/Structural.hs index 62766d5013..0869e201b9 100644 --- a/src/Language/Haskell/Liquid/Termination/Structural.hs +++ b/src/Language/Haskell/Liquid/Termination/Structural.hs @@ -14,9 +14,8 @@ import CoreSyn import Var import Name (getSrcSpan) import VarSet -import Data.Monoid ((<>)) -import Text.PrettyPrint.HughesPJ hiding ((<>)) +import Text.PrettyPrint.HughesPJ.Compat import qualified Data.HashSet as S @@ -29,10 +28,13 @@ terminationCheck info = mconcat $ map (resultToDoc . checkBind (cbs info)) (S.to data Result = OK | Error [UserError] instance Monoid Result where - mempty = OK - mappend OK e = e - mappend e OK = e - mappend (Error e1) (Error e2) = Error (e1 ++ e2) + mempty = OK + mappend = (<>) + +instance Semigroup Result where + OK <> e = e + e <> OK = e + Error e1 <> Error e2 = Error (e1 ++ e2) resultToDoc :: Result -> Output Doc resultToDoc OK = mempty diff --git a/src/Language/Haskell/Liquid/Types.hs b/src/Language/Haskell/Liquid/Types.hs index 3ea0b975e4..f318b58d5a 100644 --- a/src/Language/Haskell/Liquid/Types.hs +++ b/src/Language/Haskell/Liquid/Types.hs @@ -260,7 +260,7 @@ import Data.Text (Text) -import Text.PrettyPrint.HughesPJ hiding (first) +import Text.PrettyPrint.HughesPJ.Compat import Text.Printf import Language.Fixpoint.Misc @@ -361,7 +361,7 @@ data GhcSpec = SP { , gsNewTypes :: ![(TyCon, LocSpecType)] -- ^ Mapping of 'newtype' type constructors with their refined types. , gsLvars :: !(S.HashSet Var) -- ^ Variables that should be checked in the environment they are used , gsLazy :: !(S.HashSet Var) -- ^ Binders to IGNORE during termination checking - , gsStTerm :: !(S.HashSet Var) -- ^ Binders to be for structural termination + , gsStTerm :: !(S.HashSet Var) -- ^ Binders to be for structural termination , gsAutosize :: !(S.HashSet TyCon) -- ^ Binders to IGNORE during termination checking , gsAutoInst :: !(M.HashMap Var (Maybe Int)) -- ^ Binders to expand with automatic axiom instances maybe with specified fuel , gsConfig :: !Config -- ^ Configuration Options @@ -396,8 +396,11 @@ data LogicMap = LM } deriving (Show) instance Monoid LogicMap where - mempty = LM M.empty M.empty - mappend (LM x1 x2) (LM y1 y2) = LM (M.union x1 y1) (M.union x2 y2) + 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 @@ -533,12 +536,18 @@ instance NFData Predicate where rnf _ = () instance Monoid Predicate where - mempty = pdTrue - mappend p p' = pdAnd [p, p'] + mempty = pdTrue + mappend = (<>) + +instance Semigroup Predicate where + p <> p' = pdAnd [p, p'] + +instance Semigroup a => Semigroup (UReft a) where + MkUReft x y z <> MkUReft x' y' z' = MkUReft (x <> x') (y <> y') (z <> z') instance (Monoid a) => Monoid (UReft a) where - mempty = MkUReft mempty mempty mempty - mappend (MkUReft x y z) (MkUReft x' y' z') = MkUReft (mappend x x') (mappend y y') (mappend z z') + mempty = MkUReft mempty mempty mempty + mappend = (<>) pdTrue :: Predicate @@ -1094,7 +1103,7 @@ instance (B.Binary t) => B.Binary (RInstance t) instance (B.Binary t) => B.Binary (RISig t) newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol (RISig ty))) - deriving (Monoid, Show) + deriving (Semigroup, Monoid, Show) type RDEnv = DEnv Var SpecType @@ -1468,13 +1477,13 @@ ppTy_ureft u@(MkUReft r p s) d | otherwise = ppr_reft r (F.ppTy p d) s ppr_reft :: (F.PPrint [t], F.Reftable r) => r -> Doc -> [t] -> Doc -ppr_reft r d s = braces (F.pprint v <+> colon <+> d <> ppr_str s <+> text "|" <+> F.pprint r') +ppr_reft r d s = braces (F.pprint v <+> colon <+> d <-> ppr_str s <+> text "|" <+> F.pprint r') where r'@(F.Reft (v, _)) = F.toReft r ppr_str :: F.PPrint [t] => [t] -> Doc ppr_str [] = empty -ppr_str s = text "^" <> F.pprint s +ppr_str s = text "^" <-> F.pprint s instance F.Subable r => F.Subable (UReft r) where syms (MkUReft r p _) = F.syms r ++ F.syms p @@ -1511,7 +1520,7 @@ instance F.Reftable Predicate where -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX. ppTy r d | F.isTauto r = d | not (ppPs ppEnv) = d - | otherwise = d <> (angleBrackets $ F.pprint r) + | otherwise = d <-> (angleBrackets $ F.pprint r) toReft (Pr ps@(p:_)) = F.Reft (parg p, F.pAnd $ pToRef <$> ps) toReft _ = mempty @@ -1984,8 +1993,11 @@ data RTEnv = RTE } instance Monoid RTEnv where - mempty = RTE M.empty M.empty - (RTE x y) `mappend` (RTE x' y') = RTE (x `M.union` x') (y `M.union` y') + mempty = RTE M.empty M.empty + mappend = (<>) + +instance Semigroup RTEnv where + RTE x y <> RTE x' y' = RTE (x `M.union` x') (y `M.union` y') mapRT :: (M.HashMap Symbol (RTAlias RTyVar SpecType) -> M.HashMap Symbol (RTAlias RTyVar SpecType)) @@ -2057,7 +2069,7 @@ instance F.PPrint a => F.PPrint (Def t a) where pprintTidy k (Def m p c _ bs body) = F.pprintTidy k m <+> F.pprintTidy k (fst <$> p) <+> cbsd <+> "=" <+> F.pprintTidy k body where - cbsd = parens (F.pprintTidy k c <> hsep (F.pprintTidy k `fmap` (fst <$> bs))) + 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 @@ -2137,8 +2149,11 @@ data Annot t deriving (Data, Typeable, Generic, Functor) instance Monoid (AnnInfo a) where - mempty = AI M.empty - mappend (AI m1) (AI m2) = AI $ M.unionWith (++) m1 m2 + 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) @@ -2161,14 +2176,17 @@ emptyOutput :: Output a emptyOutput = O Nothing {- [] -} mempty mempty [] mempty instance Monoid (Output a) where - mempty = emptyOutput - mappend o1 o2 = O { o_vars = sortNub <$> mappend (o_vars o1) (o_vars o2) - -- , o_errors = sortNub $ mappend (o_errors o1) (o_errors o2) - , o_types = mappend (o_types o1) (o_types o2) - , o_templs = mappend (o_templs o1) (o_templs o2) - , o_bots = sortNub $ mappend (o_bots o1) (o_bots o2) - , o_result = mappend (o_result o1) (o_result o2) - } + mempty = emptyOutput + mappend = (<>) + +instance Semigroup (Output a) where + o1 <> o2 = O { o_vars = sortNub <$> mappend (o_vars o1) (o_vars o2) + -- , o_errors = sortNub $ mappend (o_errors o1) (o_errors o2) + , o_types = mappend (o_types o1) (o_types o2) + , o_templs = mappend (o_templs o1) (o_templs o2) + , o_bots = sortNub $ mappend (o_bots o1) (o_bots o2) + , o_result = mappend (o_result o1) (o_result o2) + } -------------------------------------------------------------------------------- -- | KVar Profile -------------------------------------------------------------- @@ -2261,9 +2279,8 @@ instance (Show ty, Show ctor, F.PPrint ctor, F.PPrint ty) => Show (MSpec ty ctor "\nimeas:\t " ++ show im ++ "\n" -instance Eq ctor => Monoid (MSpec ty ctor) where - mempty = MSpec M.empty M.empty M.empty [] - (MSpec c1 m1 cm1 im1) `mappend` (MSpec c2 m2 cm2 im2) +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 @@ -2274,6 +2291,10 @@ instance Eq ctor => Monoid (MSpec ty ctor) where 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 = (<>) + -------------------------------------------------------------------------------- @@ -2300,7 +2321,7 @@ instance (F.PPrint r, F.Reftable r, F.PPrint t, F.PPrint (RType c tv r)) => F.PP ppRefArgs :: F.Tidy -> [Symbol] -> Doc ppRefArgs _ [] = empty -ppRefArgs k ss = text "\\" <> hsep (ppRefSym k <$> ss ++ [F.vv Nothing]) <+> "->" +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 "_" diff --git a/src/Language/Haskell/Liquid/Types/Errors.hs b/src/Language/Haskell/Liquid/Types/Errors.hs index 5e397fe62a..02b8e06a1a 100644 --- a/src/Language/Haskell/Liquid/Types/Errors.hs +++ b/src/Language/Haskell/Liquid/Types/Errors.hs @@ -59,7 +59,7 @@ import Data.Typeable (Typeable) import Data.Generics (Data) import qualified Data.Binary as B import Data.Maybe -import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint.HughesPJ.Compat import Data.Aeson hiding (Result) import qualified Data.HashMap.Strict as M import Language.Fixpoint.Types (pprint, showpp, Tidy (..), PPrint (..), Symbol, Expr) @@ -153,7 +153,7 @@ makeContext1 l c c' s = vcat [ text " " ] where lnum n = text (show n) <+> text "|" - cursor = blanks (c - 1) <> pointer (max 1 (c' - c)) + cursor = blanks (c - 1) <-> pointer (max 1 (c' - c)) blanks n = text $ replicate n ' ' pointer n = text $ replicate n '^' @@ -445,20 +445,20 @@ pprSrcSpan (RealSrcSpan s) = pprRealSrcSpan s pprRealSrcSpan :: RealSrcSpan -> Doc pprRealSrcSpan span | sline == eline && scol == ecol = - hcat [ pathDoc <> colon - , int sline <> colon + hcat [ pathDoc <-> colon + , int sline <-> colon , int scol ] | sline == eline = - hcat $ [ pathDoc <> colon - , int sline <> colon + hcat $ [ pathDoc <-> colon + , int sline <-> colon , int scol - ] ++ if ecol - scol <= 1 then [] else [char '-' <> int (ecol - 1)] + ] ++ if ecol - scol <= 1 then [] else [char '-' <-> int (ecol - 1)] | otherwise = - hcat [ pathDoc <> colon - , parens (int sline <> comma <> int scol) + hcat [ pathDoc <-> colon + , parens (int sline <-> comma <-> int scol) , char '-' - , parens (int eline <> comma <> int ecol') + , parens (int eline <-> comma <-> int ecol') ] where path = srcSpanFile span @@ -519,7 +519,7 @@ ppError :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc -------------------------------------------------------------------------------- ppError k dCtx e = ppError' k dSp dCtx e where - dSp = pprint (pos e) <> text ": Error:" + dSp = pprint (pos e) <-> text ": Error:" nests :: Foldable t => Int -> t Doc -> Doc nests n = foldr (\d acc -> nest n (d $+$ acc)) empty @@ -883,7 +883,7 @@ ppError' _ dSp dCtx (ErrParseAnn _ msg) $+$ nest 4 msg ppVar :: PPrint a => a -> Doc -ppVar v = text "`" <> pprint v <> text "`" +ppVar v = text "`" <-> pprint v <-> text "`" ppSrcSpans :: [SrcSpan] -> Doc ppSrcSpans = ppList (text "Conflicting definitions at") diff --git a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs index 98248c7831..c2c6671fea 100644 --- a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs +++ b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs @@ -35,7 +35,7 @@ import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.Types hiding (sort) import Prelude hiding (error) import SrcLoc -import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint.HughesPJ.Compat import TyCon (TyCon) import Language.Haskell.Liquid.GHC.TypeRep hiding (maybeParen) import Var (Var) @@ -54,7 +54,7 @@ pprintLongList k = brackets . vcat . map (pprintTidy k) -------------------------------------------------------------------------------- pprintSymbol :: F.Symbol -> Doc -------------------------------------------------------------------------------- -pprintSymbol x = char '‘' <> pprint x <> char '’' +pprintSymbol x = char '‘' <-> pprint x <-> char '’' -------------------------------------------------------------------------------- @@ -179,10 +179,10 @@ ppr_rtype bb p t@(RFun _ _ _ _) = maybeParen p FunPrec $ ppr_rty_fun bb empty t ppr_rtype bb p (RApp c [t] rs r) | isList c - = F.ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb p rs + = F.ppTy r $ brackets (ppr_rtype bb p t) <-> ppReftPs bb p rs ppr_rtype bb p (RApp c ts rs r) | isTuple c - = F.ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb p rs + = F.ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <-> ppReftPs bb p rs ppr_rtype bb p (RApp c ts rs r) | isEmpty rsDoc && isEmpty tsDoc = F.ppTy r $ ppT c @@ -230,7 +230,7 @@ ppr_rsubtype bb p e (env, l) = (init el, last el) tr = snd $ r tl = snd $ l - pprint_bind (x, t) = pprint x <+> colon <> colon <+> ppr_rtype bb p t + pprint_bind (x, t) = pprint x <+> colon <-> colon <+> ppr_rtype bb p t pprint_env = hsep $ punctuate comma (pprint_bind <$> env) -- | From GHC: TypeRep @@ -245,7 +245,7 @@ ppExists F.Reftable (RTProp c tv ())) => PPEnv -> Prec -> RType c tv r -> Doc ppExists bb p t - = text "exists" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t' + = text "exists" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <-> dot <-> ppr_rtype bb p t' where (zs, t') = split [] t split zs (REx x t t') = split ((x,t):zs) t' split zs t = (reverse zs, t) @@ -254,7 +254,7 @@ ppAllExpr :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ())) => PPEnv -> Prec -> RType c tv r -> Doc ppAllExpr bb p t - = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t' + = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <-> dot <-> ppr_rtype bb p t' where (zs, t') = split [] t split zs (RAllE x t t') = split ((x,t):zs) t' split zs t = (reverse zs, t) @@ -275,7 +275,7 @@ ppr_dbind bb p x t | F.isNonSymbol x || (x == F.dummySymbol) = ppr_rtype bb p t | otherwise - = pprint x <> colon <> ppr_rtype bb p t + = pprint x <-> colon <-> ppr_rtype bb p t ppr_rty_fun @@ -306,7 +306,7 @@ ppr_forall bb p t = maybeParen p FunPrec $ sep [ ppr_foralls False _ _ _ = empty ppr_foralls _ [] [] [] = empty - ppr_foralls True αs πs ss = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <+> ppr_symbols ss <> dot + ppr_foralls True αs πs ss = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <+> ppr_symbols ss <-> dot ppr_clss [] = empty ppr_clss cs = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>" @@ -359,7 +359,7 @@ ppr_ref (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint s ppRefArgs :: [F.Symbol] -> Doc ppRefArgs [] = empty -ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> text "->" +ppRefArgs ss = text "\\" <-> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> text "->" ppRefSym :: (Eq a, IsString a, PPrint a) => a -> Doc ppRefSym "" = text "_" @@ -372,6 +372,6 @@ 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 + | otherwise = pprintTidy k p <-> text " & " <-> pprintTidy k r -------------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs index e26915dfbe..22eb27f209 100644 --- a/src/Language/Haskell/Liquid/Types/RefType.hs +++ b/src/Language/Haskell/Liquid/Types/RefType.hs @@ -105,7 +105,7 @@ import qualified Data.List as L import Control.Monad (void) import Text.Printf -import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint.HughesPJ.Compat import Language.Haskell.Liquid.Types.Errors import Language.Haskell.Liquid.Types.PrettyPrint @@ -211,7 +211,18 @@ uTop r = MkUReft r mempty mempty -- 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 @@ -233,21 +244,32 @@ instance ( SubsTy tv (RType c tv ()) c , 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 (RProp s1 (RHole r1)) (RProp s2 (RHole r2)) + => 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) - mappend (RProp s1 t1) (RProp s2 t2) + (<>) (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 diff --git a/src/Test/Target/Util.hs b/src/Test/Target/Util.hs index 17ddbc45ae..640b9104c4 100644 --- a/src/Test/Target/Util.hs +++ b/src/Test/Target/Util.hs @@ -166,7 +166,7 @@ loadModule f = do target <- GHC.guessTarget f Nothing GHC.setTargets [target] -- [target,lcheck] _ <- GHC.load GHC.LoadAllTargets modGraph <- GHC.getModuleGraph - let m = fromJust $ find ((==f) . GHC.msHsFilePath) modGraph + let m = fromJust $ find ((==f) . GHC.msHsFilePath) (GHC.mgModSummaries modGraph) GHC.setContext [ GHC.IIModule (GHC.ms_mod_name m) --, GHC.IIDecl $ GHC.simpleImportDecl -- $ GHC.mkModuleName "Test.Target" diff --git a/updating-ghc.txt b/updating-ghc.txt new file mode 100644 index 0000000000..3ff6a61336 --- /dev/null +++ b/updating-ghc.txt @@ -0,0 +1,19 @@ +export GHCSRC=$HOME/Documents/ghc + +# Checkout GHC-8.2.2 +(cd $GHCSRC && git checkout ghc-8.2.2 && git pull) + +# make a patch +diff -ur $GHCSRC/compiler/deSugar src/Language/Haskell/Liquid/Desugar > liquid.patch + +# Checkout GHC-8.4.3 +(cd $GHCSRC && git checkout ghc-8.2.2 && git pull) + +# Copy GHC desugarer to temporary directory +cp -r $GHCSRC/compiler/deSugar . + +# Patch +(cd deSugar && patch -p5 --merge --ignore-whitespace < ../liquid.patch) + +# Copy stuff over +for i in src/Language/Haskell/Liquid/Desugar/*.*; do j=$(basename $i); echo $j; cp deSugar/$j src/Language/Haskell/Liquid/Desugar; done