summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/Check.hs11
-rw-r--r--compiler/deSugar/DsMonad.hs14
-rw-r--r--compiler/iface/LoadIface.hs29
-rw-r--r--compiler/iface/MkIface.hs3
-rw-r--r--compiler/iface/TcIface.hs14
-rw-r--r--compiler/iface/TcIface.hs-boot18
-rw-r--r--compiler/main/HscTypes.hs101
-rw-r--r--compiler/typecheck/TcBinds.hs10
-rw-r--r--compiler/typecheck/TcRnTypes.hs14
-rw-r--r--compiler/utils/Binary.hs1
-rw-r--r--testsuite/tests/patsyn/should_compile/T13350/Makefile13
-rw-r--r--testsuite/tests/patsyn/should_compile/T13350/T13350.hs8
-rw-r--r--testsuite/tests/patsyn/should_compile/T13350/all.T4
-rw-r--r--testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs9
-rw-r--r--testsuite/tests/patsyn/should_compile/T13350/boolean/Setup.hs2
-rw-r--r--testsuite/tests/patsyn/should_compile/T13350/boolean/boolean.cabal7
16 files changed, 192 insertions, 66 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 4a8a18d77c..792932df5a 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -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)
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 4f68100111..fcdf5821f1 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -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) }
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 0edf5d9794..a3f77614f9 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -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 }
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 7974c983d1..a3418860b5 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -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
{-
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 2a56392910..2d30f52b8a 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -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
diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot
index 9c1b16b520..4a99114fc0 100644
--- a/compiler/iface/TcIface.hs-boot
+++ b/compiler/iface/TcIface.hs-boot
@@ -1,18 +1,20 @@
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]
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 6473512411..793839a510 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -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.
+-}
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index bb20b43892..201da00504 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -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
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 8e526bc5b3..1adf16058a 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -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
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index a1ccee3ae7..9d385d23ea 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -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
diff --git a/testsuite/tests/patsyn/should_compile/T13350/Makefile b/testsuite/tests/patsyn/should_compile/T13350/Makefile
new file mode 100644
index 0000000000..ffd584a2a3
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T13350/Makefile
@@ -0,0 +1,13 @@
+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)
diff --git a/testsuite/tests/patsyn/should_compile/T13350/T13350.hs b/testsuite/tests/patsyn/should_compile/T13350/T13350.hs
new file mode 100644
index 0000000000..986c4f2462
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T13350/T13350.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+module T13350 where
+
+import Boolean
+
+booleanToInt :: Boolean -> Int
+booleanToInt F = 0
+booleanToInt T = 1
diff --git a/testsuite/tests/patsyn/should_compile/T13350/all.T b/testsuite/tests/patsyn/should_compile/T13350/all.T
new file mode 100644
index 0000000000..fa63e37c6f
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T13350/all.T
@@ -0,0 +1,4 @@
+# Test that importing COMPLETE sets from external packages works
+
+test('T13350', extra_files(['T13350.hs', 'boolean']), run_command,
+ ['$MAKE -s --no-print-directory T13350'])
diff --git a/testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs b/testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs
new file mode 100644
index 0000000000..181641dbad
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs
@@ -0,0 +1,9 @@
+{-# 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 #-}
diff --git a/testsuite/tests/patsyn/should_compile/T13350/boolean/Setup.hs b/testsuite/tests/patsyn/should_compile/T13350/boolean/Setup.hs
new file mode 100644
index 0000000000..9a994af677
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T13350/boolean/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/testsuite/tests/patsyn/should_compile/T13350/boolean/boolean.cabal b/testsuite/tests/patsyn/should_compile/T13350/boolean/boolean.cabal
new file mode 100644
index 0000000000..0e1f308ce6
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T13350/boolean/boolean.cabal
@@ -0,0 +1,7 @@
+name: boolean
+version: 1.0
+build-type: Simple
+
+library
+ build-depends: base
+ exposed-modules: Boolean
View Lorry Controller Status