Commit 0d2f7330 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Read COMPLETE sets from external packages

Currently, `COMPLETE` pragmas are not read from external packages at
all, which quite limits their usefulness. This extends
`ExternalPackageState` to include `COMPLETE` sets from other packages,
and plumbs around the appropriate values to make it work the way you'd
expect it to.

Fixes #13350.

Test Plan: make test TEST=T13350

Reviewers: rwbarton, mpickering, austin, simonpj, bgamari

Reviewed By: simonpj

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D3257
parent 615ded12
......@@ -1097,11 +1097,12 @@ allCompleteMatches cl tys = do
[(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]
PatSynCon _ -> []
from_pragma <- map ((FromComplete,) . completeMatch) <$>
case splitTyConApp_maybe (conLikeResTy cl tys) of
Just (tc, _) -> dsGetCompleteMatches tc
Nothing -> return []
pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of
Just (tc, _) -> dsGetCompleteMatches tc
Nothing -> return []
let fams cm = fmap (FromComplete,) $
mapM dsLookupConLike (completeMatchConLikes cm)
from_pragma <- mapM fams pragmas
let final_groups = fam ++ from_pragma
tracePmD "allCompleteMatches" (ppr final_groups)
......
......@@ -23,7 +23,8 @@ module DsMonad (
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon,
dsLookupDataCon, dsLookupConLike,
PArrBuiltin(..),
dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
......@@ -67,6 +68,7 @@ import RdrName
import HscTypes
import Bag
import DataCon
import ConLike
import TyCon
import PmExpr
import Id
......@@ -543,6 +545,10 @@ dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
= tyThingDataCon <$> dsLookupGlobal name
dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike name
= tyThingConLike <$> dsLookupGlobal name
-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
-- Panic if there isn't one, or if it is defined multiple times.
dsLookupDPHRdrEnv :: OccName -> DsM Name
......@@ -619,8 +625,12 @@ dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
-- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches tc = do
eps <- getEps
env <- getGblEnv
return $ (lookupWithDefaultUFM (ds_complete_matches env) [] tc)
let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
eps_matches_list = lookup_completes $ eps_complete_matches eps
env_matches_list = lookup_completes $ ds_complete_matches env
return $ eps_matches_list ++ env_matches_list
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
......
......@@ -33,7 +33,8 @@ module LoadIface (
#include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
tcIfaceFamInst, tcIfaceVectInfo,
tcIfaceAnnotations, tcIfaceCompleteSigs )
import DynFlags
import IfaceSyn
......@@ -462,6 +463,7 @@ loadInterface doc_str mod from
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface)
; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
; let { final_iface = iface {
mi_decls = panic "No mi_decls in PIT",
......@@ -480,6 +482,10 @@ loadInterface doc_str mod from
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
= extendCompleteMatchMap
(eps_complete_matches eps)
new_eps_complete_sigs,
eps_inst_env = extendInstEnvList (eps_inst_env eps)
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
......@@ -910,18 +916,19 @@ readIface wanted_mod file_path
initExternalPackageState :: ExternalPackageState
initExternalPackageState
= EPS {
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_free_holes = emptyInstalledModuleEnv,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_free_holes = emptyInstalledModuleEnv,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
-- Initialise the EPS rule pool with the built-in rules
eps_mod_fam_inst_env
= emptyModuleEnv,
eps_vect_info = noVectInfo,
eps_ann_env = emptyAnnEnv,
= emptyModuleEnv,
eps_vect_info = noVectInfo,
eps_complete_matches = emptyUFM,
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
, n_rules_in = length builtinRules, n_rules_out = 0 }
......
......@@ -1001,8 +1001,7 @@ mkOrphMap get_key decls
-}
mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteSig (CompleteMatch cls tc) =
IfaceCompleteMatch (map conLikeName cls) (tyConName tc)
mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
{-
......
......@@ -15,7 +15,7 @@ module TcIface (
typecheckIfacesForMerging,
typecheckIfaceForInstantiate,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceVectInfo, tcIfaceAnnotations,
tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceCompleteSigs,
tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
tcIfaceGlobal
) where
......@@ -1096,9 +1096,7 @@ tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
tcIfaceCompleteSig cm@(IfaceCompleteMatch ms t) =
forkM (text "COMPLETE" <+> ppr cm) $
CompleteMatch <$> mapM tcIfaceConLike ms <*> tcIfaceTyConByName t
tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
{-
************************************************************************
......@@ -1760,14 +1758,6 @@ tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
AConLike (RealDataCon dc) -> return dc
_ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceConLike :: Name -> IfL ConLike
tcIfaceConLike name =
do { thing <- tcIfaceGlobal name
; case thing of
AConLike cl -> return cl
_ -> pprPanic "tcIfaceExtCL" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
; case thing of
......
module TcIface where
import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,
IfaceAnnotation, IfaceCompleteMatch )
import TyCoRep ( TyThing )
import TcRnTypes ( IfL )
import InstEnv ( ClsInst )
import FamInstEnv ( FamInst )
import CoreSyn ( CoreRule )
import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo )
import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo, CompleteMatch )
import Module ( Module )
import Annotations ( Annotation )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
......@@ -47,6 +47,7 @@ module HscTypes (
lookupIfaceByModule, emptyModIface, lookupHptByModule,
PackageInstEnv, PackageFamInstEnv, PackageRuleBase,
PackageCompleteMatchMap,
mkSOName, mkHsSOName, soExt,
......@@ -81,7 +82,7 @@ module HscTypes (
-- * TyThings and type environments
TyThing(..), tyThingAvailInfo,
tyThingTyCon, tyThingDataCon,
tyThingTyCon, tyThingDataCon, tyThingConLike,
tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars,
implicitTyThings, implicitTyConThings, implicitClassThings,
isImplicitTyThing,
......@@ -134,7 +135,8 @@ module HscTypes (
handleFlagWarnings, printOrThrowWarnings,
-- * COMPLETE signature
CompleteMatch(..)
CompleteMatch(..), CompleteMatchMap,
mkCompleteMatchMap, extendCompleteMatchMap
) where
#include "HsVersions.h"
......@@ -2089,6 +2091,12 @@ tyThingDataCon :: TyThing -> DataCon
tyThingDataCon (AConLike (RealDataCon dc)) = dc
tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other)
-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing.
-- Panics otherwise
tyThingConLike :: TyThing -> ConLike
tyThingConLike (AConLike dc) = dc
tyThingConLike other = pprPanic "tyThingConLike" (ppr other)
-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise
tyThingId :: TyThing -> Id
tyThingId (AnId id) = id
......@@ -2427,12 +2435,13 @@ instance Binary Usage where
************************************************************************
-}
type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
type PackageFamInstEnv = FamInstEnv
type PackageVectInfo = VectInfo
type PackageAnnEnv = AnnEnv
type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
type PackageFamInstEnv = FamInstEnv
type PackageVectInfo = VectInfo
type PackageAnnEnv = AnnEnv
type PackageCompleteMatchMap = CompleteMatchMap
-- | Information about other packages that we have slurped in by reading
-- their interface files
......@@ -2496,6 +2505,9 @@ data ExternalPackageState
-- from all the external-package modules
eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated
-- from all the external-package modules
eps_complete_matches :: !PackageCompleteMatchMap,
-- ^ The total 'CompleteMatchMap' accumulated
-- from all the external-package modules
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external
-- packages, keyed off the module that declared them
......@@ -3008,11 +3020,78 @@ byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
-- | A list of conlikes which represents a complete pattern match.
-- These arise from @COMPLETE@ signatures.
-- See Note [Implementation of COMPLETE signatures]
data CompleteMatch = CompleteMatch {
completeMatch :: [ConLike]
, completeMatchType :: TyCon
completeMatchConLikes :: [Name]
-- ^ The ConLikes that form a covering family
-- (e.g. Nothing, Just)
, completeMatchTyCon :: Name
-- ^ The TyCon that they cover (e.g. Maybe)
}
instance Outputable CompleteMatch where
ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl
<+> dcolon <+> ppr ty
<+> dcolon <+> ppr ty
-- | A map keyed by the 'completeMatchTyCon'.
-- See Note [Implementation of COMPLETE signatures]
type CompleteMatchMap = UniqFM [CompleteMatch]
mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap
mkCompleteMatchMap = extendCompleteMatchMap emptyUFM
extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch]
-> CompleteMatchMap
extendCompleteMatchMap = foldl' insertMatch
where
insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap
insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c]
{-
Note [Implementation of COMPLETE signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A COMPLETE signature represents a set of conlikes (i.e., constructors or
pattern synonyms) such that if they are all pattern-matched against in a
function, it gives rise to a total function. An example is:
newtype Boolean = Boolean Int
pattern F, T :: Boolean
pattern F = Boolean 0
pattern T = Boolean 1
{-# COMPLETE F, T #-}
-- This is a total function
booleanToInt :: Boolean -> Int
booleanToInt F = 0
booleanToInt T = 1
COMPLETE sets are represented internally in GHC with the CompleteMatch data
type. For example, {-# COMPLETE F, T #-} would be represented as:
CompleteMatch { complateMatchConLikes = [F, T]
, completeMatchTyCon = Boolean }
Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the
cases in which it's ambiguous, you can also explicitly specify it in the source
language by writing this:
{-# COMPLETE F, T :: Boolean #-}
For efficiency purposes, GHC collects all of the CompleteMatches that it knows
about into a CompleteMatchMap, which is a map that is keyed by the
completeMatchTyCon. In other words, you could have a multiple COMPLETE sets
for the same TyCon:
{-# COMPLETE F, T1 :: Boolean #-}
{-# COMPLETE F, T2 :: Boolean #-}
And looking up the values in the CompleteMatchMap associated with Boolean
would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean].
dsGetCompleteMatches in DsMeta accomplishes this lookup.
Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed
explanation for how GHC ensures that all the conlikes in a COMPLETE set are
consistent.
-}
......@@ -245,12 +245,18 @@ tcCompleteSigs sigs =
(res, cls) <- checkCLTypes AcceptAny
case res of
AcceptAny -> failWithTc ambiguousError
Fixed _ tc -> return $ CompleteMatch cls tc
Fixed _ tc -> return $ mkMatch cls tc
check_complete_match tc_name = do
ty_con <- tcLookupLocatedTyCon tc_name
(_, cls) <- checkCLTypes (Fixed Nothing ty_con)
return $ CompleteMatch cls ty_con
return $ mkMatch cls ty_con
mkMatch :: [ConLike] -> TyCon -> CompleteMatch
mkMatch cls ty_con = CompleteMatch {
completeMatchConLikes = map conLikeName cls,
completeMatchTyCon = tyConName ty_con
}
doOne _ = return Nothing
ambiguousError :: SDoc
......
......@@ -47,7 +47,8 @@ module TcRnTypes(
-- Desugaring types
DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..),
DsMetaEnv, DsMetaVal(..), CompleteMatchMap, mkCompleteMatchMap,
DsMetaEnv, DsMetaVal(..), CompleteMatchMap,
mkCompleteMatchMap, extendCompleteMatchMap,
-- Template Haskell
ThStage(..), SpliceType(..), PendingStuff(..),
......@@ -174,7 +175,6 @@ import FastString
import qualified GHC.LanguageExtensions as LangExt
import Fingerprint
import Util
import UniqFM ( emptyUFM, addToUFM_C, UniqFM )
import Control.Monad (ap, liftM, msum)
#if __GLASGOW_HASKELL__ > 710
......@@ -189,8 +189,6 @@ import Data.Typeable ( TypeRep )
import GHCi.Message
import GHCi.RemoteTypes
import Data.List (foldl')
import qualified Language.Haskell.TH as TH
-- | A 'NameShape' is a substitution on 'Name's that can be used
......@@ -384,14 +382,6 @@ data DsGblEnv
-- Additional complete pattern matches
}
type CompleteMatchMap = UniqFM [CompleteMatch]
mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap
mkCompleteMatchMap cms = foldl' insertMatch emptyUFM cms
where
insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap
insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c]
instance ContainsModule DsGblEnv where
extractModule = ds_mod
......
......@@ -674,7 +674,6 @@ instance Binary KindRep where
put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r
put_ _ _ = fail "Binary.putKindRep: impossible"
get bh = do
tag <- getByte bh
......
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
LOCAL_PKGCONF=local.package.conf
T13350:
"$(GHC_PKG)" init $(LOCAL_PKGCONF)
cd boolean && "$(TEST_HC)" -v0 --make Setup.hs
cd boolean && ./Setup configure -v0 --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=../$(LOCAL_PKGCONF)
cd boolean && ./Setup build -v0
cd boolean && ./Setup register -v0 --inplace
"$(TEST_HC)" $(TEST_HC_OPTS) -c T13350.hs -package-db $(LOCAL_PKGCONF)
{-# OPTIONS_GHC -Wincomplete-patterns #-}
module T13350 where
import Boolean
booleanToInt :: Boolean -> Int
booleanToInt F = 0
booleanToInt T = 1
# Test that importing COMPLETE sets from external packages works
test('T13350', extra_files(['T13350.hs', 'boolean']), run_command,
['$MAKE -s --no-print-directory T13350'])
{-# LANGUAGE PatternSynonyms #-}
module Boolean (Boolean, pattern F, pattern T) where
newtype Boolean = Boolean Int
pattern F, T :: Boolean
pattern F = Boolean 0
pattern T = Boolean 1
{-# COMPLETE F, T #-}
import Distribution.Simple
main = defaultMain
name: boolean
version: 1.0
build-type: Simple
library
build-depends: base
exposed-modules: Boolean
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment