recursion-ninja pushed to branch wip/26699 at Glasgow Haskell Compiler / GHC

Commits:

22 changed files:

Changes:

  • compiler/GHC/Hs/Decls.hs
    ... ... @@ -101,6 +101,7 @@ module GHC.Hs.Decls (
    101 101 
     import GHC.Prelude
    102 102
    103 103 
     import Language.Haskell.Syntax.Decls
    104 
    +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..))
    104 105 
     import Language.Haskell.Syntax.Extension
    105 106
    106 107 
     import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice )

  • compiler/GHC/Hs/Extension.hs
    ... ... @@ -16,10 +16,11 @@ import GHC.Prelude
    16 16 
     import Data.Data hiding ( Fixity )
    17 17 
     import Language.Haskell.Syntax.Extension
    18 18 
     import GHC.Types.Name
    19 
    -import GHC.Types.Name.RdrName
    19 
    +import GHC.Types.Name.Reader
    20 20 
     import GHC.Types.Var
    21 21 
     import GHC.Utils.Outputable hiding ((<>))
    22 22 
     import GHC.Types.SrcLoc (GenLocated(..), unLoc)
    23 
    +import GHC.Utils.Panic
    23 24 
     import GHC.Parser.Annotation
    24 25
    25 26 
     {-
    ... ... @@ -152,9 +153,9 @@ data GhcPass (c :: Pass) where
    152 153 
     -- This really should never be entered, but the data-deriving machinery
    153 154 
     -- needs the instance to exist.
    154 155 
     instance Typeable p => Data (GhcPass p) where
    155 
    -  gunfold _ _ _ = error "instance Data GhcPass"
    156 
    -  toConstr  _   = error "instance Data GhcPass"
    157 
    -  dataTypeOf _  = error "instance Data GhcPass"
    156 
    +  gunfold _ _ _ = panic "instance Data GhcPass"
    157 
    +  toConstr  _   = panic "instance Data GhcPass"
    158 
    +  dataTypeOf _  = panic "instance Data GhcPass"
    158 159
    159 160 
     data Pass = Parsed | Renamed | Typechecked
    160 161 
              deriving (Data)

  • compiler/GHC/Hs/Extension.hs-boot deleted
    1 
    -{-# LANGUAGE DataKinds #-}
    2 
    -{-# LANGUAGE RoleAnnotations #-}
    3 
    -{-# LANGUAGE KindSignatures #-}
    4 
    -{-# LANGUAGE FlexibleContexts #-}
    5 
    -{-# LANGUAGE FlexibleInstances #-}
    6 
    -{-# LANGUAGE TypeFamilies #-}
    7 
    -{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc]
    8 
    -
    9 
    -module GHC.Hs.Extension where
    10 
    -
    11 
    -import Data.Type.Equality (type (~))
    12 
    -
    13 
    --- | Used as a data type index for the hsSyn AST; also serves
    14 
    --- as a singleton type for Pass
    15 
    -data GhcPass (c :: Pass) where
    16 
    -  GhcPs :: GhcPass 'Parsed
    17 
    -  GhcRn :: GhcPass 'Renamed
    18 
    -  GhcTc :: GhcPass 'Typechecked
    19 
    -
    20 
    -data Pass = Parsed | Renamed | Typechecked
    21 
    -
    22 
    --- Type synonyms as a shorthand for tagging
    23 
    -type GhcPs   = GhcPass 'Parsed      -- Output of parser
    24 
    -type GhcRn   = GhcPass 'Renamed     -- Output of renamer
    25 
    -type GhcTc   = GhcPass 'Typechecked -- Output of typechecker
    26 
    -
    27 
    -type family NoGhcTcPass (p :: Pass) :: Pass where
    28 
    -  NoGhcTcPass 'Typechecked = 'Renamed
    29 
    -  NoGhcTcPass other        = other
    30 
    -
    31 
    -class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p
    32 
    -      , IsPass (NoGhcTcPass p)
    33 
    -      ) => IsPass p where
    34 
    -  ghcPass :: GhcPass p

  • compiler/GHC/Hs/Instances.hs
    ... ... @@ -32,8 +32,8 @@ import GHC.Parser.Annotation
    32 32 
     import GHC.Types.Name.Reader (WithUserRdr(..))
    33 33 
     import GHC.Types.InlinePragma (ActivationGhc)
    34 34 
     import GHC.Data.BooleanFormula (BooleanFormula(..))
    35 
    -import Language.Haskell.Syntax.Basic
    36 35 
     import Language.Haskell.Syntax.Decls
    36 
    +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..))
    37 37 
     import Language.Haskell.Syntax.Extension (Anno)
    38 38 
     import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..))
    39 39

  • compiler/GHC/HsToCore/Quote.hs
    ... ... @@ -72,6 +72,7 @@ import GHC.Types.ForeignCall
    72 72 
     import GHC.Types.Var
    73 73 
     import GHC.Types.Id
    74 74 
     import GHC.Types.InlinePragma
    75 
    +import GHC.Types.OverlapMode
    75 76 
     import GHC.Types.SourceText
    76 77 
     import GHC.Types.TyThing
    77 78 
     import GHC.Types.Name hiding( varName, tcName )

  • compiler/GHC/Parser.y
    ... ... @@ -70,6 +70,7 @@ import GHC.Types.Error ( GhcHint(..) )
    70 70 
     import GHC.Types.Fixity
    71 71 
     import GHC.Types.ForeignCall
    72 72 
     import GHC.Types.InlinePragma
    73 
    +import GHC.Types.OverlapMode
    73 74 
     import GHC.Types.SourceFile
    74 75 
     import GHC.Types.SourceText
    75 76 
     import GHC.Types.PkgQual

  • compiler/GHC/ThToHs.hs
    ... ... @@ -39,10 +39,11 @@ import qualified GHC.Core.Coercion as Coercion ( Role(..) )
    39 39 
     import GHC.Builtin.Types
    40 40 
     import GHC.Builtin.Types.Prim( fUNTyCon )
    41 41 
     import GHC.Types.Basic as Hs
    42 
    -import GHC.Types.InlinePragma as Hs
    43 42 
     import GHC.Types.ForeignCall
    44 
    -import GHC.Types.Unique
    43 
    +import GHC.Types.InlinePragma as Hs
    44 
    +import GHC.Types.OverlapMode as Hs
    45 45 
     import GHC.Types.SourceText
    46 
    +import GHC.Types.Unique
    46 47 
     import GHC.Utils.Lexeme
    47 48 
     import GHC.Utils.Misc
    48 49 
     import GHC.Data.FastString

  • compiler/GHC/Types/ImportLevel.hs
    1 1 
     {-# LANGUAGE DerivingVia #-}
    2 2
    3 3 
     module GHC.Types.ImportLevel (
    4 
    -        ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels,
    4 
    +        -- * ImportLevel
    5 
    +        -- ** Data-type
    6 
    +        ImportLevel(..),
    7 
    +        -- ** Enumeration
    8 
    +        allImportLevels,
    9 
    +        -- ** Conversion
    10 
    +        convImportLevel,
    11 
    +        convImportLevelSpec
    5 12 
        ) where
    6 13
    7 14 
     import GHC.Prelude

  • compiler/GHC/Types/Name/RdrName.hs deleted
    1 
    -{-
    2 
    -(c) The University of Glasgow 2006
    3 
    -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    4 
    --}
    5 
    -
    6 
    -{-# LANGUAGE CPP #-}
    7 
    -{-# LANGUAGE PatternSynonyms #-}
    8 
    -
    9 
    --- |
    10 
    --- Export /only/ the 'RdrName' data-type.
    11 
    ---
    12 
    --- Since 'RdrName' is an integral data-type found in many places throughout
    13 
    --- the compiler, importing a module which exposes 'RdrName' can cause module
    14 
    --- import cycles. By having a dedicated module which exports the bare minimum
    15 
    --- necessary to expose the data-type definition, these module import cycles
    16 
    --- can easily be avoided!
    17 
    -module GHC.Types.Name.RdrName (
    18 
    -        -- * The main type
    19 
    -        RdrName(..),
    20 
    -        WithUserRdr(..),
    21 
    -        isExact_maybe,
    22 
    -        rdrNameOcc,
    23 
    -  ) where
    24 
    -
    25 
    -import GHC.Prelude
    26 
    -
    27 
    -import GHC.Types.Name
    28 
    -import GHC.Unit.Module
    29 
    -import GHC.Utils.Outputable
    30 
    -
    31 
    -import Data.Data
    32 
    -import qualified Data.Semigroup as S
    33 
    -
    34 
    -{-
    35 
    -************************************************************************
    36 
    -*                                                                      *
    37 
    -\subsection{The main data type}
    38 
    -*                                                                      *
    39 
    -************************************************************************
    40 
    --}
    41 
    -
    42 
    --- | Reader Name
    43 
    ---
    44 
    --- Do not use the data constructors of RdrName directly: prefer the family
    45 
    --- of functions that creates them, such as 'mkRdrUnqual'
    46 
    ---
    47 
    --- - Note: A Located RdrName will only have API Annotations if it is a
    48 
    ---         compound one,
    49 
    ---   e.g.
    50 
    ---
    51 
    --- > `bar`
    52 
    --- > ( ~ )
    53 
    ---
    54 
    -data RdrName
    55 
    -  = Unqual OccName
    56 
    -        -- ^ Unqualified  name
    57 
    -        --
    58 
    -        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.
    59 
    -        -- Create such a 'RdrName' with 'mkRdrUnqual'
    60 
    -
    61 
    -  | Qual ModuleName OccName
    62 
    -        -- ^ Qualified name
    63 
    -        --
    64 
    -        -- A qualified name written by the user in
    65 
    -        -- /source/ code.  The module isn't necessarily
    66 
    -        -- the module where the thing is defined;
    67 
    -        -- just the one from which it is imported.
    68 
    -        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.
    69 
    -        -- Create such a 'RdrName' with 'mkRdrQual'
    70 
    -
    71 
    -  | Orig Module OccName
    72 
    -        -- ^ Original name
    73 
    -        --
    74 
    -        -- An original name; the module is the /defining/ module.
    75 
    -        -- This is used when GHC generates code that will be fed
    76 
    -        -- into the renamer (e.g. from deriving clauses), but where
    77 
    -        -- we want to say \"Use Prelude.map dammit\". One of these
    78 
    -        -- can be created with 'mkOrig'
    79 
    -
    80 
    -  | Exact Name
    81 
    -        -- ^ Exact name
    82 
    -        --
    83 
    -        -- We know exactly the 'Name'. This is used:
    84 
    -        --
    85 
    -        --  (1) When the parser parses built-in syntax like @[]@
    86 
    -        --      and @(,)@, but wants a 'RdrName' from it
    87 
    -        --
    88 
    -        --  (2) By Template Haskell, when TH has generated a unique name
    89 
    -        --
    90 
    -        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'
    91 
    -  deriving Data
    92 
    -
    93 
    -{-
    94 
    -************************************************************************
    95 
    -*                                                                      *
    96 
    -\subsection{Instances}
    97 
    -*                                                                      *
    98 
    -************************************************************************
    99 
    --}
    100 
    -
    101 
    -instance Eq RdrName where
    102 
    -  (Exact n1)    == (Exact n2)    = n1==n2
    103 
    -    -- Convert exact to orig
    104 
    -  (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2
    105 
    -  r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2
    106 
    -
    107 
    -  (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2
    108 
    -  (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2
    109 
    -  (Unqual o1)   == (Unqual o2)   = o1==o2
    110 
    -  _             == _             = False
    111 
    -
    112 
    -instance HasOccName RdrName where
    113 
    -  occName = rdrNameOcc
    114 
    -
    115 
    -instance Ord RdrName where
    116 
    -  a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
    117 
    -  a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
    118 
    -  a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
    119 
    -  a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
    120 
    -
    121 
    -    -- Exact < Unqual < Qual < Orig
    122 
    -    -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig
    123 
    -    --      before comparing so that Prelude.map == the exact Prelude.map, but
    124 
    -    --      that meant that we reported duplicates when renaming bindings
    125 
    -    --      generated by Template Haskell; e.g
    126 
    -    --      do { n1 <- newName "foo"; n2 <- newName "foo";
    127 
    -    --           <decl involving n1,n2> }
    128 
    -    --      I think we can do without this conversion
    129 
    -  compare (Exact n1) (Exact n2) = n1 `compare` n2
    130 
    -  compare (Exact _)  _          = LT
    131 
    -
    132 
    -  compare (Unqual _)   (Exact _)    = GT
    133 
    -  compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2
    134 
    -  compare (Unqual _)   _            = LT
    135 
    -
    136 
    -  compare (Qual _ _)   (Exact _)    = GT
    137 
    -  compare (Qual _ _)   (Unqual _)   = GT
    138 
    -  compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2
    139 
    -  compare (Qual _ _)   (Orig _ _)   = LT
    140 
    -
    141 
    -  compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2
    142 
    -  compare (Orig _ _)   _            = GT
    143 
    -
    144 
    -instance Outputable RdrName where
    145 
    -    ppr (Exact name)   = ppr name
    146 
    -    ppr (Unqual occ)   = ppr occ
    147 
    -    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
    148 
    -    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ)
    149 
    -
    150 
    -instance OutputableBndr RdrName where
    151 
    -    pprBndr _ n
    152 
    -        | isTvOcc (rdrNameOcc n) = char '@' <> ppr n
    153 
    -        | otherwise              = ppr n
    154 
    -
    155 
    -    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
    156 
    -    pprPrefixOcc rdr
    157 
    -      | Just name <- isExact_maybe rdr = pprPrefixName name
    158 
    -             -- pprPrefixName has some special cases, so
    159 
    -             -- we delegate to them rather than reproduce them
    160 
    -      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
    161 
    -
    162 
    -isExact_maybe :: RdrName -> Maybe Name
    163 
    -isExact_maybe (Exact n) = Just n
    164 
    -isExact_maybe _         = Nothing
    165 
    -
    166 
    -nukeExact :: Name -> RdrName
    167 
    -nukeExact n
    168 
    -  | isExternalName n = Orig (nameModule n) (nameOccName n)
    169 
    -  | otherwise        = Unqual (nameOccName n)
    170 
    -
    171 
    -rdrNameOcc :: RdrName -> OccName
    172 
    -rdrNameOcc (Qual _ occ) = occ
    173 
    -rdrNameOcc (Unqual occ) = occ
    174 
    -rdrNameOcc (Orig _ occ) = occ
    175 
    -rdrNameOcc (Exact name) = nameOccName name
    176 
    -
    177 
    -rdrQual_maybe :: RdrName -> Maybe ModuleName
    178 
    -rdrQual_maybe = \case
    179 
    -  Qual q _ -> Just q
    180 
    -  _        -> Nothing
    181 
    -
    182 
    ---------------------------------------------------------------------------------
    183 
    --- Preserving user-written qualification
    184 
    -
    185 
    --- | 'WithUserRdr' allows us to keep track of the original user-written
    186 
    --- 'RdrName', and in particular, any user-written module qualification.
    187 
    ---
    188 
    --- See Note [IdOcc] in Language.Haskell.Syntax.Extension.
    189 
    -data WithUserRdr a = WithUserRdr RdrName a
    190 
    -  deriving stock (Functor, Foldable, Traversable)
    191 
    -
    192 
    -instance NamedThing a => NamedThing (WithUserRdr a) where
    193 
    -  getName (WithUserRdr _rdr a) = getName a
    194 
    -instance Outputable (WithUserRdr Name) where
    195 
    -    ppr (WithUserRdr rdr name) =
    196 
    -      pprName_userQual (rdrQual_maybe rdr) name
    197 
    -instance OutputableBndr (WithUserRdr Name) where
    198 
    -    pprBndr _ (WithUserRdr rdr name) =
    199 
    -      pprName_userQual (rdrQual_maybe rdr) name
    200 
    -    pprInfixOcc :: WithUserRdr Name -> SDoc
    201 
    -    pprInfixOcc  = pprInfixName
    202 
    -    pprPrefixOcc = pprPrefixName

  • compiler/GHC/Types/Name/Reader.hs
    ... ... @@ -117,13 +117,12 @@ import GHC.Data.FastString
    117 117 
     import GHC.Data.Maybe
    118 118
    119 119 
     import GHC.Types.Avail
    120 
    -import GHC.Types.Basic
    120 
    +import GHC.Types.Basic ( TyConFlavour(..), tyConFlavourAssoc_maybe )
    121 121 
     import GHC.Types.FieldLabel
    122 122 
     import GHC.Types.GREInfo
    123 123 
     import GHC.Types.ImportLevel
    124 124 
     import GHC.Types.Name
    125 125 
     import GHC.Types.Name.Env
    126 
    -import GHC.Types.Name.RdrName
    127 126 
     import GHC.Types.Name.Set
    128 127 
     import GHC.Types.PkgQual
    129 128 
     import GHC.Types.SrcLoc as SrcLoc
    ... ... @@ -152,6 +151,65 @@ import qualified Data.Map.Strict as Map
    152 151 
     import qualified Data.Semigroup as S
    153 152 
     import System.IO.Unsafe ( unsafePerformIO )
    154 153
    154 
    +{-
    155 
    +************************************************************************
    156 
    +*                                                                      *
    157 
    +\subsection{The main data type}
    158 
    +*                                                                      *
    159 
    +************************************************************************
    160 
    +-}
    161 
    +
    162 
    +-- | Reader Name
    163 
    +--
    164 
    +-- Do not use the data constructors of RdrName directly: prefer the family
    165 
    +-- of functions that creates them, such as 'mkRdrUnqual'
    166 
    +--
    167 
    +-- - Note: A Located RdrName will only have API Annotations if it is a
    168 
    +--         compound one,
    169 
    +--   e.g.
    170 
    +--
    171 
    +-- > `bar`
    172 
    +-- > ( ~ )
    173 
    +--
    174 
    +data RdrName
    175 
    +  = Unqual OccName
    176 
    +        -- ^ Unqualified  name
    177 
    +        --
    178 
    +        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.
    179 
    +        -- Create such a 'RdrName' with 'mkRdrUnqual'
    180 
    +
    181 
    +  | Qual ModuleName OccName
    182 
    +        -- ^ Qualified name
    183 
    +        --
    184 
    +        -- A qualified name written by the user in
    185 
    +        -- /source/ code.  The module isn't necessarily
    186 
    +        -- the module where the thing is defined;
    187 
    +        -- just the one from which it is imported.
    188 
    +        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.
    189 
    +        -- Create such a 'RdrName' with 'mkRdrQual'
    190 
    +
    191 
    +  | Orig Module OccName
    192 
    +        -- ^ Original name
    193 
    +        --
    194 
    +        -- An original name; the module is the /defining/ module.
    195 
    +        -- This is used when GHC generates code that will be fed
    196 
    +        -- into the renamer (e.g. from deriving clauses), but where
    197 
    +        -- we want to say \"Use Prelude.map dammit\". One of these
    198 
    +        -- can be created with 'mkOrig'
    199 
    +
    200 
    +  | Exact Name
    201 
    +        -- ^ Exact name
    202 
    +        --
    203 
    +        -- We know exactly the 'Name'. This is used:
    204 
    +        --
    205 
    +        --  (1) When the parser parses built-in syntax like @[]@
    206 
    +        --      and @(,)@, but wants a 'RdrName' from it
    207 
    +        --
    208 
    +        --  (2) By Template Haskell, when TH has generated a unique name
    209 
    +        --
    210 
    +        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'
    211 
    +  deriving Data
    212 
    +
    155 213 
     {-
    156 214 
     ************************************************************************
    157 215 
     *                                                                      *
    ... ... @@ -160,6 +218,15 @@ import System.IO.Unsafe ( unsafePerformIO )
    160 218 
     ************************************************************************
    161 219 
     -}
    162 220
    221 
    +instance HasOccName RdrName where
    222 
    +  occName = rdrNameOcc
    223 
    +
    224 
    +rdrNameOcc :: RdrName -> OccName
    225 
    +rdrNameOcc (Qual _ occ) = occ
    226 
    +rdrNameOcc (Unqual occ) = occ
    227 
    +rdrNameOcc (Orig _ occ) = occ
    228 
    +rdrNameOcc (Exact name) = nameOccName name
    229 
    +
    163 230 
     rdrNameSpace :: RdrName -> NameSpace
    164 231 
     rdrNameSpace = occNameSpace . rdrNameOcc
    165 232
    ... ... @@ -226,6 +293,11 @@ nameRdrName name = Exact name
    226 293 
     -- unique is still there for debug printing, particularly
    227 294 
     -- of Types (which are converted to IfaceTypes before printing)
    228 295
    296 
    +nukeExact :: Name -> RdrName
    297 
    +nukeExact n
    298 
    +  | isExternalName n = Orig (nameModule n) (nameOccName n)
    299 
    +  | otherwise        = Unqual (nameOccName n)
    300 
    +
    229 301 
     isRdrDataCon :: RdrName -> Bool
    230 302 
     isRdrTyVar   :: RdrName -> Bool
    231 303 
     isRdrTc      :: RdrName -> Bool
    ... ... @@ -263,6 +335,76 @@ isExact :: RdrName -> Bool
    263 335 
     isExact (Exact _) = True
    264 336 
     isExact _         = False
    265 337
    338 
    +isExact_maybe :: RdrName -> Maybe Name
    339 
    +isExact_maybe (Exact n) = Just n
    340 
    +isExact_maybe _         = Nothing
    341 
    +
    342 
    +{-
    343 
    +************************************************************************
    344 
    +*                                                                      *
    345 
    +\subsection{Instances}
    346 
    +*                                                                      *
    347 
    +************************************************************************
    348 
    +-}
    349 
    +
    350 
    +instance Outputable RdrName where
    351 
    +    ppr (Exact name)   = ppr name
    352 
    +    ppr (Unqual occ)   = ppr occ
    353 
    +    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
    354 
    +    ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ)
    355 
    +
    356 
    +instance OutputableBndr RdrName where
    357 
    +    pprBndr _ n
    358 
    +        | isTvOcc (rdrNameOcc n) = char '@' <> ppr n
    359 
    +        | otherwise              = ppr n
    360 
    +
    361 
    +    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
    362 
    +    pprPrefixOcc rdr
    363 
    +      | Just name <- isExact_maybe rdr = pprPrefixName name
    364 
    +             -- pprPrefixName has some special cases, so
    365 
    +             -- we delegate to them rather than reproduce them
    366 
    +      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
    367 
    +
    368 
    +instance Eq RdrName where
    369 
    +    (Exact n1)    == (Exact n2)    = n1==n2
    370 
    +        -- Convert exact to orig
    371 
    +    (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2
    372 
    +    r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2
    373 
    +
    374 
    +    (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2
    375 
    +    (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2
    376 
    +    (Unqual o1)   == (Unqual o2)   = o1==o2
    377 
    +    _             == _             = False
    378 
    +
    379 
    +instance Ord RdrName where
    380 
    +    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
    381 
    +    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
    382 
    +    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
    383 
    +    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
    384 
    +
    385 
    +        -- Exact < Unqual < Qual < Orig
    386 
    +        -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig
    387 
    +        --      before comparing so that Prelude.map == the exact Prelude.map, but
    388 
    +        --      that meant that we reported duplicates when renaming bindings
    389 
    +        --      generated by Template Haskell; e.g
    390 
    +        --      do { n1 <- newName "foo"; n2 <- newName "foo";
    391 
    +        --           <decl involving n1,n2> }
    392 
    +        --      I think we can do without this conversion
    393 
    +    compare (Exact n1) (Exact n2) = n1 `compare` n2
    394 
    +    compare (Exact _)  _          = LT
    395 
    +
    396 
    +    compare (Unqual _)   (Exact _)    = GT
    397 
    +    compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2
    398 
    +    compare (Unqual _)   _            = LT
    399 
    +
    400 
    +    compare (Qual _ _)   (Exact _)    = GT
    401 
    +    compare (Qual _ _)   (Unqual _)   = GT
    402 
    +    compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2
    403 
    +    compare (Qual _ _)   (Orig _ _)   = LT
    404 
    +
    405 
    +    compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2
    406 
    +    compare (Orig _ _)   _            = GT
    407 
    +
    266 408 
     {-
    267 409 
     ************************************************************************
    268 410 
     *                                                                      *
    ... ... @@ -2076,6 +2218,29 @@ pprLoc (UnhelpfulSpan {}) = empty
    2076 2218 
     opIsAt :: RdrName -> Bool
    2077 2219 
     opIsAt e = e == mkUnqual varName (fsLit "@")
    2078 2220
    2221 
    +
    2222 
    +--------------------------------------------------------------------------------
    2223 
    +-- Preserving user-written qualification
    2224 
    +
    2225 
    +-- | 'WithUserRdr' allows us to keep track of the original user-written
    2226 
    +-- 'RdrName', and in particular, any user-written module qualification.
    2227 
    +--
    2228 
    +-- See Note [IdOcc] in Language.Haskell.Syntax.Extension.
    2229 
    +data WithUserRdr a = WithUserRdr RdrName a
    2230 
    +  deriving stock (Functor, Foldable, Traversable)
    2231 
    +
    2232 
    +instance NamedThing a => NamedThing (WithUserRdr a) where
    2233 
    +  getName (WithUserRdr _rdr a) = getName a
    2234 
    +instance Outputable (WithUserRdr Name) where
    2235 
    +    ppr (WithUserRdr rdr name) =
    2236 
    +      pprName_userQual (rdrQual_maybe rdr) name
    2237 
    +instance OutputableBndr (WithUserRdr Name) where
    2238 
    +    pprBndr _ (WithUserRdr rdr name) =
    2239 
    +      pprName_userQual (rdrQual_maybe rdr) name
    2240 
    +    pprInfixOcc :: WithUserRdr Name -> SDoc
    2241 
    +    pprInfixOcc  = pprInfixName
    2242 
    +    pprPrefixOcc = pprPrefixName
    2243 
    +
    2079 2244 
     unLocWithUserRdr :: GenLocated l (WithUserRdr a) -> a
    2080 2245 
     unLocWithUserRdr (L _ (WithUserRdr _ a)) = a
    2081 2246
    ... ... @@ -2084,3 +2249,10 @@ noUserRdr n = WithUserRdr (nameRdrName n) n
    2084 2249
    2085 2250 
     userRdrName :: WithUserRdr Name -> RdrName
    2086 2251 
     userRdrName (WithUserRdr rdr _) = rdr
    2252 
    +
    2253 
    +rdrQual_maybe :: RdrName -> Maybe ModuleName
    2254 
    +rdrQual_maybe = \case
    2255 
    +  Qual q _ -> Just q
    2256 
    +  _        -> Nothing
    2257 
    +
    2258 
    +--------------------------------------------------------------------------------

  • compiler/GHC/Types/OverlapFlag.hs
    ... ... @@ -41,7 +41,7 @@ import GHC.Utils.Binary
    41 41 
     import GHC.Utils.Outputable
    42 42 
     import GHC.Types.OverlapMode (changeOverlapModePass)
    43 43
    44 
    -import Language.Haskell.Syntax.Basic (OverlapMode(..))
    44 
    +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..))
    45 45
    46 46 
     import Control.DeepSeq (NFData(..))
    47 47

  • compiler/GHC/Types/OverlapMode.hs
    ... ... @@ -5,6 +5,13 @@
    5 5
    6 6 
     {-# LANGUAGE TypeFamilies #-}
    7 7
    8 
    +{-# OPTIONS_GHC -fno-warn-orphans #-}
    9 
    +{-
    10 
    +  * (type class):  Binary OverlapMode
    11 
    +  * (type family): XOverlapMode  (GhcPass p)
    12 
    +  * (type family): XXOverlapMode (GhcPass p)
    13 
    +-}
    14 
    +
    8 15 
     module GHC.Types.OverlapMode (
    9 16 
             -- * OverlapMode
    10 17 
             -- ** Data-type
    ... ... @@ -21,15 +28,13 @@ module GHC.Types.OverlapMode (
    21 28
    22 29 
     import GHC.Prelude
    23 30
    24 
    -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass)
    25 
    -
    31 
    +import GHC.Hs.Extension (GhcPass)
    26 32 
     import GHC.Types.SourceText
    33 
    +import GHC.Utils.Binary
    27 34
    28 
    -import Language.Haskell.Syntax.Basic (OverlapMode(..))
    35 
    +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..))
    29 36 
     import Language.Haskell.Syntax.Extension
    30 37
    31 
    -import Control.DeepSeq ( NFData(..) )
    32 
    -
    33 38 
     type instance XOverlapMode  (GhcPass _) = SourceText
    34 39 
     type instance XXOverlapMode (GhcPass _) = DataConCantHappen
    35 40
    ... ... @@ -77,3 +82,21 @@ hasNonCanonicalFlag :: OverlapMode (GhcPass p) -> Bool
    77 82 
     hasNonCanonicalFlag = \case
    78 83 
       NonCanonical{} -> True
    79 84 
       _              -> False
    85 
    +
    86 
    +instance Binary (OverlapMode (GhcPass p)) where
    87 
    +    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
    88 
    +    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
    89 
    +    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
    90 
    +    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
    91 
    +    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
    92 
    +    put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s
    93 
    +
    94 
    +    get bh = do
    95 
    +        h <- getByte bh
    96 
    +        case h of
    97 
    +            0 -> (get bh) >>= \s -> return $ NoOverlap s
    98 
    +            1 -> (get bh) >>= \s -> return $ Overlaps s
    99 
    +            2 -> (get bh) >>= \s -> return $ Incoherent s
    100 
    +            3 -> (get bh) >>= \s -> return $ Overlapping s
    101 
    +            4 -> (get bh) >>= \s -> return $ Overlappable s
    102 
    +            _ -> (get bh) >>= \s -> return $ NonCanonical s

  • compiler/GHC/Types/SourceText.hs
    ... ... @@ -32,6 +32,7 @@ import GHC.Prelude
    32 32 
     import GHC.Data.FastString
    33 33
    34 34 
     import GHC.Utils.Outputable
    35 
    +import GHC.Utils.Binary
    35 36 
     import GHC.Utils.Panic
    36 37
    37 38 
     import Data.Function (on)
    ... ... @@ -112,6 +113,21 @@ instance NFData SourceText where
    112 113 
             SourceText s -> rnf s
    113 114 
             NoSourceText -> ()
    114 115
    116 
    +instance Binary SourceText where
    117 
    +  put_ bh NoSourceText = putByte bh 0
    118 
    +  put_ bh (SourceText s) = do
    119 
    +        putByte bh 1
    120 
    +        put_ bh s
    121 
    +
    122 
    +  get bh = do
    123 
    +    h <- getByte bh
    124 
    +    case h of
    125 
    +      0 -> return NoSourceText
    126 
    +      1 -> do
    127 
    +        s <- get bh
    128 
    +        return (SourceText s)
    129 
    +      _ -> panic $ "Binary SourceText:" ++ show h
    130 
    +
    115 131 
     -- | Special combinator for showing string literals.
    116 132 
     pprWithSourceText :: SourceText -> SDoc -> SDoc
    117 133 
     pprWithSourceText NoSourceText     d = d

  • compiler/GHC/Unit/Types.hs
    ... ... @@ -82,6 +82,7 @@ import GHC.Prelude
    82 82
    83 83 
     import GHC.Types.Unique
    84 84 
     import GHC.Types.Unique.DSet
    85 
    +import GHC.Utils.Binary
    85 86 
     import GHC.Utils.Outputable
    86 87 
     import GHC.Data.FastString
    87 88 
     import GHC.Utils.Encoding
    ... ... @@ -135,6 +136,11 @@ mkModule = Module
    135 136 
     instance Uniquable Module where
    136 137 
       getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n)
    137 138
    139 
    +instance Binary a => Binary (GenModule a) where
    140 
    +  put_ bh (Module p n) = put_ bh p >> put_ bh n
    141 
    +  -- Module has strict fields, so use $! in order not to allocate a thunk
    142 
    +  get bh = do p <- get bh; n <- get bh; return $! Module p n
    143 
    +
    138 144 
     instance NFData (GenModule a) where
    139 145 
       rnf (Module unit name) = unit `seq` name `seq` ()
    140 146
    ... ... @@ -293,6 +299,23 @@ instance Eq (GenInstantiatedUnit unit) where
    293 299 
     instance Ord (GenInstantiatedUnit unit) where
    294 300 
       u1 `compare` u2 = instUnitFS u1 `lexicalCompareFS` instUnitFS u2
    295 301
    302 
    +instance Binary InstantiatedUnit where
    303 
    +  put_ bh indef = do
    304 
    +    put_ bh (instUnitInstanceOf indef)
    305 
    +    put_ bh (instUnitInsts indef)
    306 
    +  get bh = do
    307 
    +    cid   <- get bh
    308 
    +    insts <- get bh
    309 
    +    let fs = mkInstantiatedUnitHash cid insts
    310 
    +    -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk
    311 
    +    return $! InstantiatedUnit {
    312 
    +                instUnitInstanceOf = cid,
    313 
    +                instUnitInsts = insts,
    314 
    +                instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
    315 
    +                instUnitFS = fs,
    316 
    +                instUnitKey = getUnique fs
    317 
    +              }
    318 
    +
    296 319 
     instance IsUnitId u => Eq (GenUnit u) where
    297 320 
       uid1 == uid2 = unitUnique uid1 == unitUnique uid2
    298 321
    ... ... @@ -326,6 +349,24 @@ pprUnit HoleUnit = ftext holeFS
    326 349 
     instance Show Unit where
    327 350 
         show = unitString
    328 351
    352 
    +-- Performance: would prefer to have a NameCache like thing
    353 
    +instance Binary Unit where
    354 
    +  put_ bh (RealUnit def_uid) = do
    355 
    +    putByte bh 0
    356 
    +    put_ bh def_uid
    357 
    +  put_ bh (VirtUnit indef_uid) = do
    358 
    +    putByte bh 1
    359 
    +    put_ bh indef_uid
    360 
    +  put_ bh HoleUnit =
    361 
    +    putByte bh 2
    362 
    +  get bh = do b <- getByte bh
    363 
    +              u <- case b of
    364 
    +                0 -> fmap RealUnit (get bh)
    365 
    +                1 -> fmap VirtUnit (get bh)
    366 
    +                _ -> pure HoleUnit
    367 
    +              -- Unit has strict fields that need forcing; otherwise we allocate a thunk.
    368 
    +              pure $! u
    369 
    +
    329 370 
     -- | Retrieve the set of free module holes of a 'Unit'.
    330 371 
     unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName
    331 372 
     unitFreeModuleHoles (VirtUnit x) = instUnitHoles x
    ... ... @@ -468,6 +509,10 @@ newtype UnitId = UnitId
    468 509 
     instance NFData UnitId where
    469 510 
       rnf (UnitId fs) = rnf fs `seq` ()
    470 511
    512 
    +instance Binary UnitId where
    513 
    +  put_ bh (UnitId fs) = put_ bh fs
    514 
    +  get bh = do fs <- get bh; return (UnitId fs)
    515 
    +
    471 516 
     instance Eq UnitId where
    472 517 
         uid1 == uid2 = getUnique uid1 == getUnique uid2
    473 518
    ... ... @@ -503,7 +548,7 @@ stringToUnitId = UnitId . mkFastString
    503 548 
     -- | A definite unit (i.e. without any free module hole)
    504 549 
     newtype Definite unit = Definite { unDefinite :: unit }
    505 550 
        deriving (Functor)
    506 
    -   deriving newtype (Eq, Ord, Outputable, Uniquable, IsUnitId)
    551 
    +   deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
    507 552
    508 553 
     ---------------------------------------------------------------------
    509 554 
     -- WIRED-IN UNITS
    ... ... @@ -651,6 +696,15 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
    651 696
    652 697 
     type ModuleWithIsBoot = GenWithIsBoot Module
    653 698
    699 
    +instance Binary a => Binary (GenWithIsBoot a) where
    700 
    +  put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
    701 
    +    put_ bh gwib_mod
    702 
    +    put_ bh gwib_isBoot
    703 
    +  get bh = do
    704 
    +    gwib_mod <- get bh
    705 
    +    gwib_isBoot <- get bh
    706 
    +    pure $ GWIB { gwib_mod, gwib_isBoot }
    707 
    +
    654 708 
     instance Outputable a => Outputable (GenWithIsBoot a) where
    655 709 
       ppr (GWIB  { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of
    656 710 
         IsBoot -> [ text "{-# SOURCE #-}" ]

  • compiler/GHC/Utils/Binary.hs
    ... ... @@ -120,8 +120,8 @@ import GHC.Prelude
    120 120 
     import Language.Haskell.Syntax.Basic
    121 121 
     import Language.Haskell.Syntax.Binds.InlinePragma
    122 122 
     import Language.Haskell.Syntax.Module.Name (ModuleName(..))
    123 
    +import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
    123 124
    124 
    -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass)
    125 125 
     import {-# SOURCE #-} GHC.Types.Name (Name)
    126 126 
     import GHC.Data.FastString
    127 127 
     import GHC.Data.TrieMap
    ... ... @@ -130,19 +130,14 @@ import GHC.Utils.Panic.Plain
    130 130 
     import GHC.Types.Unique.FM
    131 131 
     import GHC.Data.FastMutInt
    132 132 
     import GHC.Utils.Fingerprint
    133 
    -import GHC.Types.OverlapMode
    134 
    -import GHC.Types.SourceText
    135 133 
     import GHC.Types.SrcLoc
    136 134 
     import GHC.Types.Unique
    137 
    -import GHC.Unit.Types
    138 135 
     import qualified GHC.Data.Strict as Strict
    139 136 
     import GHC.Utils.Outputable( JoinPointHood(..) )
    140 137 
     import GHCi.FFI
    141 138 
     import GHCi.Message
    142 139
    143 
    -import GHC.Types.Unique.DSet ( unionManyUniqDSets )
    144 
    -
    145 
    -import Control.DeepSeq ( NFData(..) )
    140 
    +import Control.DeepSeq
    146 141 
     import Control.Monad            ( when, (<$!>), unless, forM_, void )
    147 142 
     import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
    148 143 
     import Data.Array
    ... ... @@ -2017,85 +2012,6 @@ instance NFData a => NFData (FingerprintWithValue a) where
    2017 2012 
       rnf (FingerprintWithValue fp mflags)
    2018 2013 
         = rnf fp `seq` rnf mflags `seq` ()
    2019 2014
    2020 
    -instance Binary SourceText where
    2021 
    -  put_ bh NoSourceText = putByte bh 0
    2022 
    -  put_ bh (SourceText s) = do
    2023 
    -        putByte bh 1
    2024 
    -        put_ bh s
    2025 
    -
    2026 
    -  get bh = do
    2027 
    -    h <- getByte bh
    2028 
    -    case h of
    2029 
    -      0 -> return NoSourceText
    2030 
    -      1 -> do
    2031 
    -        s <- get bh
    2032 
    -        return (SourceText s)
    2033 
    -      _ -> panic $ "Binary SourceText:" ++ show h
    2034 
    -
    2035 
    ---------------------------------------------------------------------------------
    2036 
    --- Instances for the GHC.Unit.Types module
    2037 
    ---------------------------------------------------------------------------------
    2038 
    -
    2039 
    -instance Binary a => Binary (GenModule a) where
    2040 
    -  put_ bh (Module p n) = put_ bh p >> put_ bh n
    2041 
    -  -- Module has strict fields, so use $! in order not to allocate a thunk
    2042 
    -  get bh = do p <- get bh; n <- get bh; return $! Module p n
    2043 
    -
    2044 
    -instance Binary InstantiatedUnit where
    2045 
    -  put_ bh indef = do
    2046 
    -    put_ bh (instUnitInstanceOf indef)
    2047 
    -    put_ bh (instUnitInsts indef)
    2048 
    -  get bh = do
    2049 
    -    cid   <- get bh
    2050 
    -    insts <- get bh
    2051 
    -    let fs = mkInstantiatedUnitHash cid insts
    2052 
    -    -- InstantiatedUnit has strict fields, so use $! in order not to allocate a t\
    2053 
    -hunk
    2054 
    -    return $! InstantiatedUnit {
    2055 
    -                instUnitInstanceOf = cid,
    2056 
    -                instUnitInsts = insts,
    2057 
    -                instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) ins\
    2058 
    -ts),
    2059 
    -                instUnitFS = fs,
    2060 
    -                instUnitKey = getUnique fs
    2061 
    -              }
    2062 
    -
    2063 
    --- Performance: would prefer to have a NameCache like thing
    2064 
    -instance Binary Unit where
    2065 
    -  put_ bh (RealUnit def_uid) = do
    2066 
    -    putByte bh 0
    2067 
    -    put_ bh def_uid
    2068 
    -  put_ bh (VirtUnit indef_uid) = do
    2069 
    -    putByte bh 1
    2070 
    -    put_ bh indef_uid
    2071 
    -  put_ bh HoleUnit =
    2072 
    -    putByte bh 2
    2073 
    -  get bh = do b <- getByte bh
    2074 
    -              u <- case b of
    2075 
    -                0 -> fmap RealUnit (get bh)
    2076 
    -                1 -> fmap VirtUnit (get bh)
    2077 
    -                _ -> pure HoleUnit
    2078 
    -              -- Unit has strict fields that need forcing; otherwise we allocate \
    2079 
    -a thunk.
    2080 
    -              pure $! u
    2081 
    -
    2082 
    -instance Binary UnitId where
    2083 
    -  put_ bh (UnitId fs) = put_ bh fs
    2084 
    -  get bh = do fs <- get bh; return (UnitId fs)
    2085 
    -
    2086 
    -instance Binary a => Binary (GenWithIsBoot a) where
    2087 
    -  put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
    2088 
    -    put_ bh gwib_mod
    2089 
    -    put_ bh gwib_isBoot
    2090 
    -  get bh = do
    2091 
    -    gwib_mod <- get bh
    2092 
    -    gwib_isBoot <- get bh
    2093 
    -    pure $ GWIB { gwib_mod, gwib_isBoot }
    2094 
    -
    2095 
    -deriving newtype instance Binary x => Binary (Definite x)
    2096 
    -
    2097 
    ---------------------------------------------------------------------------------
    2098 
    -
    2099 2015 
     instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool
    2100 2016 
       put_ bh = put_ bh . isBoxed
    2101 2017 
       get bh  = do
    ... ... @@ -2164,21 +2080,3 @@ instance Binary RuleMatchInfo where
    2164 2080 
           h <- getByte bh
    2165 2081 
           if h == 1 then pure ConLike
    2166 2082 
                     else pure FunLike
    2167 
    -
    2168 
    -instance Binary (OverlapMode (GhcPass p)) where
    2169 
    -    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
    2170 
    -    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
    2171 
    -    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
    2172 
    -    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
    2173 
    -    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
    2174 
    -    put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s
    2175 
    -
    2176 
    -    get bh = do
    2177 
    -        h <- getByte bh
    2178 
    -        case h of
    2179 
    -            0 -> (get bh) >>= \s -> return $ NoOverlap s
    2180 
    -            1 -> (get bh) >>= \s -> return $ Overlaps s
    2181 
    -            2 -> (get bh) >>= \s -> return $ Incoherent s
    2182 
    -            3 -> (get bh) >>= \s -> return $ Overlapping s
    2183 
    -            4 -> (get bh) >>= \s -> return $ Overlappable s
    2184 
    -            _ -> (get bh) >>= \s -> return $ NonCanonical s

  • compiler/GHC/Utils/Outputable.hs
    ... ... @@ -114,6 +114,7 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName )
    114 114
    115 115 
     import Language.Haskell.Syntax.Basic
    116 116 
     import Language.Haskell.Syntax.Binds.InlinePragma
    117 
    +import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) )
    117 118 
     import Language.Haskell.Syntax.Module.Name ( ModuleName(..) )
    118 119
    119 120 
     import GHC.Prelude.Basic

  • compiler/Language/Haskell/Syntax/Basic.hs
    ... ... @@ -3,8 +3,11 @@
    3 3 
     {-# LANGUAGE OverlappingInstances #-}
    4 4 
     {-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode
    5 5
    6 
    +-- | Data-type defintions of the Abstrast Sytntax Tree
    7 
    +-- which *do not* have any /Trees That Grow/ extension points.
    6 8 
     module Language.Haskell.Syntax.Basic where
    7 9
    10 
    +import Control.DeepSeq
    8 11 
     import Data.Data (Data)
    9 12 
     import Data.Eq
    10 13 
     import Data.Ord
    ... ... @@ -12,8 +15,6 @@ import Data.Bool
    12 15 
     import Prelude
    13 16
    14 17 
     import GHC.Data.FastString (FastString)
    15 
    -import Language.Haskell.Syntax.Extension
    16 
    -import Control.DeepSeq
    17 18
    18 19 
     {-
    19 20 
     ************************************************************************
    ... ... @@ -161,81 +162,3 @@ data Fixity = Fixity Int FixityDirection
    161 162
    162 163 
     instance NFData Fixity where
    163 164 
       rnf (Fixity i d) = rnf i `seq` rnf d `seq` ()
    164 
    -
    165 
    -data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv
    166 
    -  = NoOverlap (XOverlapMode pass)
    167 
    -                  -- See Note [Pragma source text]
    168 
    -    -- ^ This instance must not overlap another `NoOverlap` instance.
    169 
    -    -- However, it may be overlapped by `Overlapping` instances,
    170 
    -    -- and it may overlap `Overlappable` instances.
    171 
    -
    172 
    -
    173 
    -  | Overlappable (XOverlapMode pass)
    174 
    -                  -- See Note [Pragma source text]
    175 
    -    -- ^ Silently ignore this instance if you find a
    176 
    -    -- more specific one that matches the constraint
    177 
    -    -- you are trying to resolve
    178 
    -    --
    179 
    -    -- Example: constraint (Foo [Int])
    180 
    -    --   instance                      Foo [Int]
    181 
    -    --   instance {-# OVERLAPPABLE #-} Foo [a]
    182 
    -    --
    183 
    -    -- Since the second instance has the Overlappable flag,
    184 
    -    -- the first instance will be chosen (otherwise
    185 
    -    -- its ambiguous which to choose)
    186 
    -
    187 
    -  | Overlapping (XOverlapMode pass)
    188 
    -                  -- See Note [Pragma source text]
    189 
    -    -- ^ Silently ignore any more general instances that may be
    190 
    -    --   used to solve the constraint.
    191 
    -    --
    192 
    -    -- Example: constraint (Foo [Int])
    193 
    -    --   instance {-# OVERLAPPING #-} Foo [Int]
    194 
    -    --   instance                     Foo [a]
    195 
    -    --
    196 
    -    -- Since the first instance has the Overlapping flag,
    197 
    -    -- the second---more general---instance will be ignored (otherwise
    198 
    -    -- it is ambiguous which to choose)
    199 
    -
    200 
    -  | Overlaps (XOverlapMode pass)
    201 
    -                  -- See Note [Pragma source text]
    202 
    -    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
    203 
    -
    204 
    -  | Incoherent (XOverlapMode pass)
    205 
    -                  -- See Note [Pragma source text]
    206 
    -    -- ^ Behave like Overlappable and Overlapping, and in addition pick
    207 
    -    -- an arbitrary one if there are multiple matching candidates, and
    208 
    -    -- don't worry about later instantiation
    209 
    -    --
    210 
    -    -- Example: constraint (Foo [b])
    211 
    -    -- instance {-# INCOHERENT -} Foo [Int]
    212 
    -    -- instance                   Foo [a]
    213 
    -    -- Without the Incoherent flag, we'd complain that
    214 
    -    -- instantiating 'b' would change which instance
    215 
    -    -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv"
    216 
    -
    217 
    -  | NonCanonical (XOverlapMode pass)
    218 
    -    -- ^ Behave like Incoherent, but the instance choice is observable
    219 
    -    -- by the program behaviour. See Note [Coherence and specialisation: overview].
    220 
    -    --
    221 
    -    -- We don't have surface syntax for the distinction between
    222 
    -    -- Incoherent and NonCanonical instances; instead, the flag
    223 
    -    -- `-f{no-}specialise-incoherents` (on by default) controls
    224 
    -    -- whether `INCOHERENT` instances are regarded as Incoherent or
    225 
    -    -- NonCanonical.
    226 
    -
    227 
    -  | XOverlapMode !(XXOverlapMode pass)
    228 
    -    -- ^ The /Trees That Grow/ extension point constructor.
    229 
    -
    230 
    -deriving instance ( Eq (XOverlapMode pass)
    231 
    -                  , Eq (XXOverlapMode pass)) => Eq (OverlapMode pass)
    232 
    -
    233 
    -instance ( NFData (XOverlapMode pass)
    234 
    -         , XXOverlapMode pass ~ DataConCantHappen) => NFData (OverlapMode pass) where
    235 
    -  rnf = \case
    236 
    -    NoOverlap    s -> rnf s
    237 
    -    Overlappable s -> rnf s
    238 
    -    Overlapping  s -> rnf s
    239 
    -    Overlaps     s -> rnf s
    240 
    -    Incoherent   s -> rnf s
    241 
    -    NonCanonical s -> rnf s

  • compiler/Language/Haskell/Syntax/Decls.hs
    ... ... @@ -88,16 +88,17 @@ module Language.Haskell.Syntax.Decls (
    88 88
    89 89 
     -- friends:
    90 90 
     import {-# SOURCE #-} Language.Haskell.Syntax.Expr
    91 
    -  ( HsExpr, HsUntypedSplice )
    91 
    +  (HsExpr, HsUntypedSplice)
    92 92 
             -- Because Expr imports Decls via HsBracket
    93 93
    94 
    -import Language.Haskell.Syntax.Basic (OverlapMode, RuleName, TopLevelFlag)
    94 
    +import Language.Haskell.Syntax.Basic
    95 
    +  (LexicalFixity, Role, RuleName, TopLevelFlag)
    95 96 
     import Language.Haskell.Syntax.Binds
    96 97 
     import Language.Haskell.Syntax.Binds.InlinePragma (Activation)
    98 
    +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode)
    97 99 
     import Language.Haskell.Syntax.Extension
    98 
    -import Language.Haskell.Syntax.Type
    99 
    -import Language.Haskell.Syntax.Basic (Role, LexicalFixity)
    100 100 
     import Language.Haskell.Syntax.Specificity (Specificity)
    101 
    +import Language.Haskell.Syntax.Type
    101 102
    102 103 
     import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec)
    103 104
    ... ... @@ -118,7 +119,7 @@ import Prelude (Show)
    118 119 
     import Data.Foldable
    119 120 
     import Data.Traversable
    120 121 
     import Data.List.NonEmpty (NonEmpty (..))
    121 
    -import GHC.Generics ( Generic )
    122 
    +import GHC.Generics (Generic)
    122 123
    123 124
    124 125 
     {-

  • compiler/Language/Haskell/Syntax/Decls/Overlap.hs
    1 
    +{-# LANGUAGE GeneralisedNewtypeDeriving #-}
    2 
    +{-# LANGUAGE LambdaCase #-}
    3 
    +{-# LANGUAGE OverlappingInstances #-}
    4 
    +{-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode
    5 
    +
    6 
    +{- |
    7 
    +Data-type describing the state of "overlapping instances" for a type.
    8 
    +-}
    9 
    +module Language.Haskell.Syntax.Decls.Overlap where
    10 
    +
    11 
    +import Control.DeepSeq
    12 
    +import Data.Eq
    13 
    +import Prelude
    14 
    +
    15 
    +import Language.Haskell.Syntax.Extension
    16 
    +
    17 
    +-- | The status of overlapping instances /(including no overlap)/ for a type.
    18 
    +data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv
    19 
    +  = NoOverlap (XOverlapMode pass)
    20 
    +                  -- See Note [Pragma source text]
    21 
    +    -- ^ This instance must not overlap another `NoOverlap` instance.
    22 
    +    -- However, it may be overlapped by `Overlapping` instances,
    23 
    +    -- and it may overlap `Overlappable` instances.
    24 
    +
    25 
    +
    26 
    +  | Overlappable (XOverlapMode pass)
    27 
    +                  -- See Note [Pragma source text]
    28 
    +    -- ^ Silently ignore this instance if you find a
    29 
    +    -- more specific one that matches the constraint
    30 
    +    -- you are trying to resolve
    31 
    +    --
    32 
    +    -- Example: constraint (Foo [Int])
    33 
    +    --   instance                      Foo [Int]
    34 
    +    --   instance {-# OVERLAPPABLE #-} Foo [a]
    35 
    +    --
    36 
    +    -- Since the second instance has the Overlappable flag,
    37 
    +    -- the first instance will be chosen (otherwise
    38 
    +    -- its ambiguous which to choose)
    39 
    +
    40 
    +  | Overlapping (XOverlapMode pass)
    41 
    +                  -- See Note [Pragma source text]
    42 
    +    -- ^ Silently ignore any more general instances that may be
    43 
    +    --   used to solve the constraint.
    44 
    +    --
    45 
    +    -- Example: constraint (Foo [Int])
    46 
    +    --   instance {-# OVERLAPPING #-} Foo [Int]
    47 
    +    --   instance                     Foo [a]
    48 
    +    --
    49 
    +    -- Since the first instance has the Overlapping flag,
    50 
    +    -- the second---more general---instance will be ignored (otherwise
    51 
    +    -- it is ambiguous which to choose)
    52 
    +
    53 
    +  | Overlaps (XOverlapMode pass)
    54 
    +                  -- See Note [Pragma source text]
    55 
    +    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
    56 
    +
    57 
    +  | Incoherent (XOverlapMode pass)
    58 
    +                  -- See Note [Pragma source text]
    59 
    +    -- ^ Behave like Overlappable and Overlapping, and in addition pick
    60 
    +    -- an arbitrary one if there are multiple matching candidates, and
    61 
    +    -- don't worry about later instantiation
    62 
    +    --
    63 
    +    -- Example: constraint (Foo [b])
    64 
    +    -- instance {-# INCOHERENT -} Foo [Int]
    65 
    +    -- instance                   Foo [a]
    66 
    +    -- Without the Incoherent flag, we'd complain that
    67 
    +    -- instantiating 'b' would change which instance
    68 
    +    -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv"
    69 
    +
    70 
    +  | NonCanonical (XOverlapMode pass)
    71 
    +    -- ^ Behave like Incoherent, but the instance choice is observable
    72 
    +    -- by the program behaviour. See Note [Coherence and specialisation: overview].
    73 
    +    --
    74 
    +    -- We don't have surface syntax for the distinction between
    75 
    +    -- Incoherent and NonCanonical instances; instead, the flag
    76 
    +    -- `-f{no-}specialise-incoherents` (on by default) controls
    77 
    +    -- whether `INCOHERENT` instances are regarded as Incoherent or
    78 
    +    -- NonCanonical.
    79 
    +
    80 
    +  | XOverlapMode !(XXOverlapMode pass)
    81 
    +    -- ^ The /Trees That Grow/ extension point constructor.
    82 
    +
    83 
    +deriving instance ( Eq (XOverlapMode pass)
    84 
    +                  , Eq (XXOverlapMode pass)
    85 
    +                  ) => Eq (OverlapMode pass)
    86 
    +
    87 
    +instance ( NFData (XOverlapMode pass)
    88 
    +         , XXOverlapMode pass ~ DataConCantHappen
    89 
    +         ) => NFData (OverlapMode pass) where
    90 
    +  rnf = \case
    91 
    +    NoOverlap    s -> rnf s
    92 
    +    Overlappable s -> rnf s
    93 
    +    Overlapping  s -> rnf s
    94 
    +    Overlaps     s -> rnf s
    95 
    +    Incoherent   s -> rnf s
    96 
    +    NonCanonical s -> rnf s

  • ghc/GHCi/UI.hs
    ... ... @@ -75,6 +75,7 @@ import GHC.Core.TyCo.Ppr
    75 75 
     import GHC.Types.SafeHaskell ( getSafeMode )
    76 76 
     import GHC.Types.SourceError ( SourceError, initSourceErrorContext )
    77 77 
     import GHC.Types.Name
    78 
    +import GHC.Types.ImportLevel ( convImportLevel )
    78 79 
     import GHC.Types.Var ( varType )
    79 80 
     import GHC.Iface.Syntax ( showToHeader )
    80 81 
     import GHC.Builtin.Names

  • utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
    ... ... @@ -40,7 +40,7 @@ import GHC.Driver.DynFlags (getDynFlags)
    40 40 
     import GHC.Types.Basic (TupleSort (..))
    41 41 
     import GHC.Types.Name
    42 42 
     import GHC.Types.Name.Reader (RdrName (Exact))
    43 
    -import GHC.Types.OverlapMode (changeOverlapModeType)
    43 
    +import GHC.Types.OverlapMode (OverlapMode, changeOverlapModeType)
    44 44 
     import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))
    45 45
    46 46 
     import Haddock.Backends.Hoogle (ppExportD)

  • utils/haddock/haddock-api/src/Haddock/Types.hs
    ... ... @@ -59,6 +59,7 @@ import GHC.Core.InstEnv (is_dfun_name)
    59 59 
     import GHC.Types.Name (stableNameCmp)
    60 60 
     import GHC.Types.Name.Occurrence
    61 61 
     import GHC.Types.Name.Reader (RdrName (..))
    62 
    +import GHC.Types.OverlapMode (OverlapMode)
    62 63 
     import GHC.Types.SrcLoc (srcSpanToRealSrcSpan)
    63 64 
     import GHC.Types.Var (Specificity)
    64 65 
     import GHC.Utils.Outputable

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help