Merge remote-tracking branch 'obsidian/skip-associated-type-defaults-in-sig' into miri-bundle-0

compiler/backpack/BkpSyn.hs

@@ -12,13 +12,13 @@ module BkpSyn (
     HsComponentId(..),
     LHsUnit, HsUnit(..),
     LHsUnitDecl, HsUnitDecl(..),
-    HsDeclType(..),
     IncludeDecl(..),
     LRenaming, Renaming(..),
     ) where
 
 import GhcPrelude
 
+import DriverPhases
 import GHC.Hs
 import SrcLoc
 import Outputable
@@ -60,9 +60,8 @@ type LHsUnit n = Located (HsUnit n)
 
 -- | A declaration in a package, e.g. a module or signature definition,
 -- or an include.
-data HsDeclType = ModuleD | SignatureD
 data HsUnitDecl n
-    = DeclD   HsDeclType (Located ModuleName) (Maybe (Located (HsModule GhcPs)))
+    = DeclD   HscSource (Located ModuleName) (Maybe (Located (HsModule GhcPs)))
     | IncludeD   (IncludeDecl n)
 type LHsUnitDecl n = Located (HsUnitDecl n)
 

compiler/backpack/DriverBkp.hs

@@ -106,8 +106,9 @@ computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
   where
     cid = hsComponentId (unLoc (hsunitName unit))
     reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
-    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
-    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
+    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname
+    get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet
+    get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet
     get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
         unitIdFreeHoles (convertHsUnitId hsuid)
 
@@ -642,10 +643,7 @@ hsunitModuleGraph dflags unit = do
 
     --  1. Create a HsSrcFile/HsigFile summary for every
     --  explicitly mentioned module/signature.
-    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
-          let hsc_src = case dt of
-                          ModuleD    -> HsSrcFile
-                          SignatureD -> HsigFile
+    let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do
           Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
         get_decl _ = return Nothing
     nodes <- catMaybes `fmap` mapM get_decl decls

compiler/parser/Parser.y

@@ -47,6 +47,7 @@ import Control.Applicative ((<$))
 import GHC.Hs
 
 -- compiler/main
+import DriverPhases     ( HscSource(..) )
 import HscTypes         ( IsBootInterface, WarningTxt(..) )
 import DynFlags
 import BkpSyn
@@ -719,17 +720,27 @@ unitdecls :: { OrdList (LHsUnitDecl PackageName) }
         | unitdecl              { unitOL $1 }
 
 unitdecl :: { LHsUnitDecl PackageName }
-        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
+        : maybedocheader 'module' maybe_src  modid maybemodwarning maybeexports 'where' body
              -- XXX not accurate
-             { sL1 $2 $ DeclD ModuleD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }
+             { sL1 $2 $ DeclD
+                 (case snd $3 of
+                   Nothing -> HsSrcFile
+                   Just _ -> HsBootFile)
+                 $4
+                 (Just $ sL1 $2 (HsModule (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) }
         | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
-             { sL1 $2 $ DeclD SignatureD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) }
+             { sL1 $2 $ DeclD
+                 HsigFile
+                 $3
+                 (Just $ sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1)) }
         -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict
         -- will prevent us from parsing both forms.
-        | maybedocheader 'module' modid
-             { sL1 $2 $ DeclD ModuleD $3 Nothing }
+        | maybedocheader 'module' maybe_src modid
+             { sL1 $2 $ DeclD (case snd $3 of
+                   Nothing -> HsSrcFile
+                   Just _ -> HsBootFile) $4 Nothing }
         | maybedocheader 'signature' modid
-             { sL1 $2 $ DeclD SignatureD $3 Nothing }
+             { sL1 $2 $ DeclD HsigFile $3 Nothing }
         | 'dependency' unitid mayberns
              { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2
                                               , idModRenaming = $3
@@ -961,22 +972,24 @@ importdecl :: { LImportDecl GhcPs }
                   ; checkImportDecl $4 $7
                   ; ams (cL (comb4 $1 $6 (snd $8) $9) $
                       ImportDecl { ideclExt = noExtField
-                                  , ideclSourceSrc = snd $ fst $2
+                                  , ideclSourceSrc = fst $2
                                   , ideclName = $6, ideclPkgQual = snd $5
-                                  , ideclSource = snd $2, ideclSafe = snd $3
+                                  , ideclSource = isJust $ snd $2, ideclSafe = snd $3
                                   , ideclQualified = importDeclQualifiedStyle $4 $7
                                   , ideclImplicit = False
                                   , ideclAs = unLoc (snd $8)
                                   , ideclHiding = unLoc $9 })
-                         ((mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList $4)
+                         ((mj AnnImport $1 : fst $3 ++ fmap (mj AnnQualified) (maybeToList $4)
                                           ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList $7) ++ fst $8))
                   }
                 }
 
-maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }
-        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],getSOURCE_PRAGs $1)
-                                      ,True) }
-        | {- empty -}               { (([],NoSourceText),False) }
+maybe_src :: { (SourceText, Maybe SrcSpan) }
+        : '{-# SOURCE' '#-}'        {% do { let { openL = getLoc $1 }
+                                          ; addAnnsAt openL [mo $1,mc $2]
+                                          ; pure (getSOURCE_PRAGs $1, Just openL)
+                                          } }
+        | {- empty -}               { (NoSourceText, Nothing) }
 
 maybe_safe :: { ([AddAnn],Bool) }
         : 'safe'                                { ([mj AnnSafe $1],True) }

compiler/typecheck/TcClassDcl.hs

@@ -544,8 +544,8 @@ warnMissingAT name
   = do { warn <- woptM Opt_WarnMissingMethods
        ; traceTc "warn" (ppr name <+> ppr warn)
        ; hsc_src <- fmap tcg_src getGblEnv
-       -- Warn only if -Wmissing-methods AND not a signature
-       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)
+       -- Warn only if -Wmissing-methods AND not a concrete module
+       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile)
                 (text "No explicit" <+> text "associated type"
                     <+> text "or default declaration for"
                     <+> quotes (ppr name)) }

compiler/typecheck/TcInstDcls.hs

@@ -482,6 +482,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
 
         ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)
 
+        ; is_boot <- tcIsHsBootOrSig
+
         -- Next, process any associated types.
         ; (datafam_stuff, tyfam_insts)
              <- tcExtendNameTyVarEnv tv_skol_prs $
@@ -496,7 +498,12 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
                       -- Check for missing associated types and build them
                       -- from their defaults (if available)
                     ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)
-                                        (classATItems clas)
+                      -- Don't default type family instances, but rather omit,
+                      -- in hsig/hs-boot. There's no way to opt out of this, and
+                      -- it's meaningful restriction on possible instantiations,
+                      -- unlike default methods. Plus, type families sneaking in
+                      -- like this breaks the current implementation.
+                                        (if is_boot then [] else classATItems clas)
 
                     ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
 
@@ -522,7 +529,6 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
               all_insts                      = tyfam_insts ++ datafam_insts
 
          -- In hs-boot files there should be no bindings
-        ; is_boot <- tcIsHsBootOrSig
         ; let no_binds = isEmptyLHsBinds binds && null uprags
         ; failIfTc (is_boot && not no_binds) badBootDeclErr
 

testsuite/tests/backpack/should_compile/all.T

@@ -47,6 +47,11 @@ test('bkp52', normal, backpack_compile, [''])
 test('bkp53', normal, backpack_compile, [''])
 test('bkp54', normal, backpack_compile, [''])
 test('bkp55', normal, backpack_compile, [''])
+test('bkp56', normal, backpack_compile, [''])
+test('bkp57', normal, backpack_compile, [''])
+test('bkp58', normal, backpack_compile, [''])
+test('bkp59', normal, backpack_compile, [''])
+test('bkp60', normal, backpack_compile, [''])
 
 test('T13140', normal, backpack_compile, [''])
 test('T13149', expect_broken(13149), backpack_compile, [''])

testsuite/tests/backpack/should_compile/bkp56.bkp

+-- Test the evil combination of backpack and hs-boot
+unit common where
+  module Class where
+    class C x where
+unit consumer-abs where
+  dependency common
+  signature Instance where
+    import Class
+    data I = I Int
+    instance C I where
+unit consumer-impl where
+  dependency common
+  module {-# SOURCE #-} Impl where
+    import Class
+    data I = I Int
+    instance C I where
+  module Impl where
+    import Class
+    data I = I Int
+    instance C I where

testsuite/tests/backpack/should_compile/bkp56.stderr

+[1 of 3] Processing common
+  Instantiating common
+  [1 of 1] Compiling Class            ( common/Class.hs, bkp56.out/common/Class.o )
+[2 of 3] Processing consumer-abs
+  [1 of 1] Compiling Instance[sig]    ( consumer-abs/Instance.hsig, nothing )
+[3 of 3] Processing consumer-impl
+  Instantiating consumer-impl
+  [1 of 1] Including common
+  [1 of 2] Compiling Impl[boot]       ( consumer-impl/Impl.hs-boot, bkp56.out/consumer-impl/Impl.o-boot )
+  [2 of 2] Compiling Impl             ( consumer-impl/Impl.hs, bkp56.out/consumer-impl/Impl.o )

testsuite/tests/backpack/should_compile/bkp57.bkp

+-- no default method, backpack
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+  module Class where
+    class Show (T x) => C x where
+      type T x
+      def :: T x
+      --type T x = ()
+unit consumer-abs where
+  dependency common
+  signature Instance where
+    import Class
+    data I = I Int
+    instance C I where
+      --type T I = ()
+  module Downstream where
+    import Class
+    import Instance
+    asdf :: C I => String
+    asdf = show $ def @I
+unit consumer-impl where
+  dependency common
+  module Impl where
+    import Class
+    data I = I Int
+    instance C I where
+      type T I = ()
+      def = ()
+unit tie where
+  dependency consumer-impl
+  dependency consumer-abs[Instance=consumer-impl:Impl]
+  module Main where
+    import Downstream
+    main = print asdf

testsuite/tests/backpack/should_compile/bkp57.stderr

+[1 of 4] Processing common
+  Instantiating common
+  [1 of 1] Compiling Class            ( common/Class.hs, bkp57.out/common/Class.o )
+[2 of 4] Processing consumer-abs
+  [1 of 2] Compiling Instance[sig]    ( consumer-abs/Instance.hsig, nothing )
+  [2 of 2] Compiling Downstream       ( consumer-abs/Downstream.hs, nothing )
+[3 of 4] Processing consumer-impl
+  Instantiating consumer-impl
+  [1 of 1] Including common
+  [1 of 1] Compiling Impl             ( consumer-impl/Impl.hs, bkp57.out/consumer-impl/Impl.o )
+[4 of 4] Processing tie
+  Instantiating tie
+  [1 of 2] Including consumer-impl
+  [2 of 2] Including consumer-abs[Instance=consumer-impl:Impl]
+    Instantiating consumer-abs[Instance=consumer-impl:Impl]
+    [1 of 1] Including common
+    [1 of 2] Compiling Instance[sig]    ( consumer-abs/Instance.hsig, bkp57.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Instance.o )
+    [2 of 2] Compiling Downstream       ( consumer-abs/Downstream.hs, bkp57.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Downstream.o )
+  [1 of 1] Compiling Main             ( tie/Main.hs, bkp57.out/tie/Main.o )

testsuite/tests/backpack/should_compile/bkp58.bkp

+-- no default method, hs-boot
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+  module Class where
+    class Show (T x) => C x where
+      type T x
+      --type T x = ()
+      def :: T x
+unit consumer-impl where
+  dependency common
+  module {-# SOURCE #-} Impl where
+    import Class
+    data I = I Int
+    instance C I where
+      --type T I = ()
+  module Downstream where
+    import Class
+    import {-# SOURCE #-} Impl
+    asdf :: C I => String
+    asdf = show $ def @I
+  module Impl where
+    import Class
+    data I = I Int
+    instance C I where
+      type T I = ()
+      def = ()
+unit tie where
+  dependency consumer-impl
+  module Main where
+    import Downstream
+    import Impl
+    main = print asdf

testsuite/tests/backpack/should_compile/bkp58.stderr

+[1 of 3] Processing common
+  Instantiating common
+  [1 of 1] Compiling Class            ( common/Class.hs, bkp58.out/common/Class.o )
+[2 of 3] Processing consumer-impl
+  Instantiating consumer-impl
+  [1 of 1] Including common
+  [1 of 3] Compiling Impl[boot]       ( consumer-impl/Impl.hs-boot, bkp58.out/consumer-impl/Impl.o-boot )
+  [2 of 3] Compiling Downstream       ( consumer-impl/Downstream.hs, bkp58.out/consumer-impl/Downstream.o )
+  [3 of 3] Compiling Impl             ( consumer-impl/Impl.hs, bkp58.out/consumer-impl/Impl.o )
+[3 of 3] Processing tie
+  Instantiating tie
+  [1 of 1] Including consumer-impl
+  [1 of 1] Compiling Main             ( tie/Main.hs, bkp58.out/tie/Main.o )

testsuite/tests/backpack/should_compile/bkp59.bkp

+-- default method, backpack
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+  module Class where
+    class Show (T x) => C x where
+      type T x
+      type T x = ()
+      def :: T x
+    class D x where
+unit consumer-abs where
+  dependency common
+  signature Instance where
+    import Class
+    data I = I Int
+    instance C I where
+      --type T I = ()
+  module Downstream where
+    import Class
+    import Instance
+    asdf :: C I => String
+    asdf = show $ def @I
+unit consumer-impl where
+  dependency common
+  module Impl where
+    import Class
+    data I = I Int
+    instance C I where
+      type T I = ()
+      def = ()
+unit tie where
+  dependency consumer-impl
+  dependency consumer-abs[Instance=consumer-impl:Impl]
+  module Main where
+    import Downstream
+    main = print asdf

testsuite/tests/backpack/should_compile/bkp59.stderr

+[1 of 4] Processing common
+  Instantiating common
+  [1 of 1] Compiling Class            ( common/Class.hs, bkp59.out/common/Class.o )
+[2 of 4] Processing consumer-abs
+  [1 of 2] Compiling Instance[sig]    ( consumer-abs/Instance.hsig, nothing )
+  [2 of 2] Compiling Downstream       ( consumer-abs/Downstream.hs, nothing )
+[3 of 4] Processing consumer-impl
+  Instantiating consumer-impl
+  [1 of 1] Including common
+  [1 of 1] Compiling Impl             ( consumer-impl/Impl.hs, bkp59.out/consumer-impl/Impl.o )
+[4 of 4] Processing tie
+  Instantiating tie
+  [1 of 2] Including consumer-impl
+  [2 of 2] Including consumer-abs[Instance=consumer-impl:Impl]
+    Instantiating consumer-abs[Instance=consumer-impl:Impl]
+    [1 of 1] Including common
+    [1 of 2] Compiling Instance[sig]    ( consumer-abs/Instance.hsig, bkp59.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Instance.o )
+    [2 of 2] Compiling Downstream       ( consumer-abs/Downstream.hs, bkp59.out/consumer-abs/consumer-abs-EtqPCpl4Hcf9otzJUe9fPM/Downstream.o )
+  [1 of 1] Compiling Main             ( tie/Main.hs, bkp59.out/tie/Main.o )

testsuite/tests/backpack/should_compile/bkp60.bkp

+-- default method, hs-boot
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+unit common where
+  module Class where
+    class Show (T x) => C x where
+      type T x
+      type T x = ()
+      def :: T x
+unit consumer-impl where
+  dependency common
+  module {-# SOURCE #-} Impl where
+    import Class
+    data I = I Int
+    instance C I where
+      --type T I = ()
+  module Downstream where
+    import Class
+    import {-# SOURCE #-} Impl
+    asdf :: C I => String
+    asdf = show $ def @I
+  module Impl where
+    import Class
+    data I = I Int
+    instance C I where
+      type T I = ()
+      def = ()
+unit tie where
+  dependency consumer-impl
+  module Main where
+    import Downstream
+    import Impl
+    main = print asdf

testsuite/tests/backpack/should_compile/bkp60.stderr

+[1 of 3] Processing common
+  Instantiating common
+  [1 of 1] Compiling Class            ( common/Class.hs, bkp60.out/common/Class.o )
+[2 of 3] Processing consumer-impl
+  Instantiating consumer-impl
+  [1 of 1] Including common
+  [1 of 3] Compiling Impl[boot]       ( consumer-impl/Impl.hs-boot, bkp60.out/consumer-impl/Impl.o-boot )
+  [2 of 3] Compiling Downstream       ( consumer-impl/Downstream.hs, bkp60.out/consumer-impl/Downstream.o )
+  [3 of 3] Compiling Impl             ( consumer-impl/Impl.hs, bkp60.out/consumer-impl/Impl.o )
+[3 of 3] Processing tie
+  Instantiating tie
+  [1 of 1] Including consumer-impl
+  [1 of 1] Compiling Main             ( tie/Main.hs, bkp60.out/tie/Main.o )