recursion-ninja pushed to branch wip/TTG-No-Orphans at Glasgow Haskell Compiler / GHC

Commits:

28 changed files:

Changes:

  • compiler/GHC/Core/Coercion/Axiom.hs
    1 
    -{-# OPTIONS_GHC -Wno-orphans     #-} -- Outputable
    2 
    -
    3 1 
     -- (c) The University of Glasgow 2012
    4 2
    5 3 
     -- | Module for coercion axioms, used to represent type family instances
    ... ... @@ -22,7 +20,7 @@ module GHC.Core.Coercion.Axiom (
    22 20 
            coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,
    23 21 
            placeHolderIncomps,
    24 22
    25 
    -       Role(..), fsFromRole,
    23 
    +       Role(..),
    26 24
    27 25 
            CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn,
    28 26 
            coAxiomRuleArgRoles, coAxiomRuleRole,
    ... ... @@ -43,7 +41,6 @@ import GHC.Types.Name
    43 41 
     import GHC.Types.Unique
    44 42 
     import GHC.Types.Var
    45 43 
     import GHC.Utils.Misc
    46 
    -import GHC.Utils.Binary
    47 44 
     import GHC.Utils.Panic
    48 45 
     import GHC.Data.Pair
    49 46 
     import GHC.Types.Basic
    ... ... @@ -52,7 +49,6 @@ import GHC.Types.SrcLoc
    52 49 
     import qualified Data.Data as Data
    53 50 
     import Data.Array
    54 51 
     import Data.List ( mapAccumL )
    55 
    -import Control.DeepSeq
    56 52
    57 53 
     {-
    58 54 
     Note [Coercion axiom branches]
    ... ... @@ -521,44 +517,6 @@ instance Outputable CoAxBranch where
    521 517 
                                , ppUnless (null incomps) $
    522 518 
                                  text "incomps:" <+> vcat (map ppr incomps) ])
    523 519
    524 
    -{-
    525 
    -************************************************************************
    526 
    -*                                                                      *
    527 
    -                    Roles
    528 
    -*                                                                      *
    529 
    -************************************************************************
    530 
    -
    531 
    -Roles are defined here to avoid circular dependencies.
    532 
    --}
    533 
    -
    534 
    --- These names are slurped into the parser code. Changing these strings
    535 
    --- will change the **surface syntax** that GHC accepts! If you want to
    536 
    --- change only the pretty-printing, do some replumbing. See
    537 
    --- mkRoleAnnotDecl in GHC.Parser.PostProcess
    538 
    -fsFromRole :: Role -> FastString
    539 
    -fsFromRole Nominal          = fsLit "nominal"
    540 
    -fsFromRole Representational = fsLit "representational"
    541 
    -fsFromRole Phantom          = fsLit "phantom"
    542 
    -
    543 
    -instance Outputable Role where
    544 
    -  ppr = ftext . fsFromRole
    545 
    -
    546 
    -instance Binary Role where
    547 
    -  put_ bh Nominal          = putByte bh 1
    548 
    -  put_ bh Representational = putByte bh 2
    549 
    -  put_ bh Phantom          = putByte bh 3
    550 
    -
    551 
    -  get bh = do tag <- getByte bh
    552 
    -              case tag of 1 -> return Nominal
    553 
    -                          2 -> return Representational
    554 
    -                          3 -> return Phantom
    555 
    -                          _ -> panic ("get Role " ++ show tag)
    556 
    -
    557 
    -instance NFData Role where
    558 
    -  rnf Nominal = ()
    559 
    -  rnf Representational = ()
    560 
    -  rnf Phantom = ()
    561 
    -
    562 520 
     {-
    563 521 
     ************************************************************************
    564 522 
     *                                                                      *

  • compiler/GHC/Core/DataCon.hs
    ... ... @@ -5,8 +5,6 @@
    5 5 
     \section[DataCon]{@DataCon@: Data Constructors}
    6 6 
     -}
    7 7
    8 
    -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary
    9 
    -
    10 8 
     module GHC.Core.DataCon (
    11 9 
             -- * Main data types
    12 10 
             DataCon, DataConRep(..),
    ... ... @@ -109,7 +107,6 @@ import qualified Data.ByteString.Lazy as LBS
    109 107 
     import qualified Data.Data as Data
    110 108 
     import Data.Char
    111 109 
     import Data.List( find )
    112 
    -import Control.DeepSeq
    113 110
    114 111 
     {-
    115 112 
     Note [Data constructor representation]
    ... ... @@ -1030,16 +1027,6 @@ instance Outputable HsImplBang where
    1030 1027 
         ppr (HsUnpack (Just co))    = text "Unpacked" <> parens (ppr co)
    1031 1028 
         ppr (HsStrict b)            = text "StrictNotUnpacked" <> parens (ppr b)
    1032 1029
    1033 
    -instance Outputable SrcStrictness where
    1034 
    -    ppr SrcLazy     = char '~'
    1035 
    -    ppr SrcStrict   = char '!'
    1036 
    -    ppr NoSrcStrict = empty
    1037 
    -
    1038 
    -instance Outputable SrcUnpackedness where
    1039 
    -    ppr SrcUnpack   = text "{-# UNPACK #-}"
    1040 
    -    ppr SrcNoUnpack = text "{-# NOUNPACK #-}"
    1041 
    -    ppr NoSrcUnpack = empty
    1042 
    -
    1043 1030 
     instance Outputable StrictnessMark where
    1044 1031 
         ppr MarkedStrict    = text "!"
    1045 1032 
         ppr NotMarkedStrict = empty
    ... ... @@ -1054,40 +1041,6 @@ instance Binary StrictnessMark where
    1054 1041 
                1 -> return MarkedStrict
    1055 1042 
                _ -> panic "Invalid binary format"
    1056 1043
    1057 
    -instance Binary SrcStrictness where
    1058 
    -    put_ bh SrcLazy     = putByte bh 0
    1059 
    -    put_ bh SrcStrict   = putByte bh 1
    1060 
    -    put_ bh NoSrcStrict = putByte bh 2
    1061 
    -
    1062 
    -    get bh =
    1063 
    -      do h <- getByte bh
    1064 
    -         case h of
    1065 
    -           0 -> return SrcLazy
    1066 
    -           1 -> return SrcStrict
    1067 
    -           _ -> return NoSrcStrict
    1068 
    -
    1069 
    -instance Binary SrcUnpackedness where
    1070 
    -    put_ bh SrcNoUnpack = putByte bh 0
    1071 
    -    put_ bh SrcUnpack   = putByte bh 1
    1072 
    -    put_ bh NoSrcUnpack = putByte bh 2
    1073 
    -
    1074 
    -    get bh =
    1075 
    -      do h <- getByte bh
    1076 
    -         case h of
    1077 
    -           0 -> return SrcNoUnpack
    1078 
    -           1 -> return SrcUnpack
    1079 
    -           _ -> return NoSrcUnpack
    1080 
    -
    1081 
    -instance NFData SrcStrictness where
    1082 
    -  rnf SrcLazy = ()
    1083 
    -  rnf SrcStrict = ()
    1084 
    -  rnf NoSrcStrict = ()
    1085 
    -
    1086 
    -instance NFData SrcUnpackedness where
    1087 
    -  rnf SrcNoUnpack = ()
    1088 
    -  rnf SrcUnpack = ()
    1089 
    -  rnf NoSrcUnpack = ()
    1090 
    -
    1091 1044 
     -- | Compare strictness annotations
    1092 1045 
     eqHsBang :: HsImplBang -> HsImplBang -> Bool
    1093 1046 
     eqHsBang HsLazy               HsLazy              = True

  • compiler/GHC/Hs/Basic.hs
    1 
    -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary
    2 
    -{-# LANGUAGE TypeFamilies #-}
    3 
    -
    4 1 
     -- | Fixity
    5 2 
     module GHC.Hs.Basic
    6 3 
        ( module Language.Haskell.Syntax.Basic
    7 4 
        ) where
    8 5
    9 
    -import GHC.Prelude
    10 
    -
    11 
    -import GHC.Utils.Outputable
    12 
    -import GHC.Utils.Binary
    13 
    -
    14 6 
     import Language.Haskell.Syntax.Basic
    15 
    -
    16 
    -instance Outputable LexicalFixity where
    17 
    -  ppr Prefix = text "Prefix"
    18 
    -  ppr Infix  = text "Infix"
    19 
    -
    20 
    -instance Outputable FixityDirection where
    21 
    -    ppr InfixL = text "infixl"
    22 
    -    ppr InfixR = text "infixr"
    23 
    -    ppr InfixN = text "infix"
    24 
    -
    25 
    -instance Outputable Fixity where
    26 
    -    ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
    27 
    -
    28 
    -
    29 
    -instance Binary Fixity where
    30 
    -    put_ bh (Fixity aa ab) = do
    31 
    -            put_ bh aa
    32 
    -            put_ bh ab
    33 
    -    get bh = do
    34 
    -          aa <- get bh
    35 
    -          ab <- get bh
    36 
    -          return (Fixity aa ab)
    37 
    -
    38 
    -------------------------
    39 
    -
    40 
    -instance Binary FixityDirection where
    41 
    -    put_ bh InfixL =
    42 
    -            putByte bh 0
    43 
    -    put_ bh InfixR =
    44 
    -            putByte bh 1
    45 
    -    put_ bh InfixN =
    46 
    -            putByte bh 2
    47 
    -    get bh = do
    48 
    -            h <- getByte bh
    49 
    -            case h of
    50 
    -              0 -> return InfixL
    51 
    -              1 -> return InfixR
    52 
    -              _ -> return InfixN

  • compiler/GHC/Hs/Decls/Overlap.hs
    1 1 
     {-# LANGUAGE LambdaCase #-}
    2 2 
     {-# LANGUAGE TypeFamilies #-}
    3 3 
     {-# LANGUAGE UndecidableInstances #-} -- XOverlapMode, XXOverlapMode
    4 
    -
    5 
    -{-# OPTIONS_GHC -fno-warn-orphans #-}
    6 
    -{- Necessary for the following instances:
    7 
    -  * (type class):  Binary OverlapMode
    8 
    -  * (type class):  NFData OverlapMode
    9 
    --}
    4 
    +{-# OPTIONS_GHC -fno-warn-orphans #-} -- XOverlapMode, XXOverlapMode
    10 5
    11 6 
     {- |
    12 7 
     Data-types describing the overlap annotations for instances as well as
    ... ... @@ -74,34 +69,6 @@ type instance XOverlapMode (GhcPass _) = SourceText
    74 69
    75 70 
     type instance XXOverlapMode (GhcPass _) = DataConCantHappen
    76 71
    77 
    -instance NFData (OverlapMode (GhcPass p)) where
    78 
    -    rnf = \case
    79 
    -        NoOverlap    s -> rnf s
    80 
    -        Overlappable s -> rnf s
    81 
    -        Overlapping  s -> rnf s
    82 
    -        Overlaps     s -> rnf s
    83 
    -        Incoherent   s -> rnf s
    84 
    -        NonCanonical s -> rnf s
    85 
    -
    86 
    -instance Binary (OverlapMode (GhcPass p)) where
    87 
    -    put_ bh = \case
    88 
    -        NoOverlap    s -> putByte bh 0 >> put_ bh s
    89 
    -        Overlaps     s -> putByte bh 1 >> put_ bh s
    90 
    -        Incoherent   s -> putByte bh 2 >> put_ bh s
    91 
    -        Overlapping  s -> putByte bh 3 >> put_ bh s
    92 
    -        Overlappable s -> putByte bh 4 >> put_ bh s
    93 
    -        NonCanonical s -> putByte bh 5 >> put_ bh s
    94 
    -
    95 
    -    get bh = do
    96 
    -        h <- getByte bh
    97 
    -        case h of
    98 
    -            0 -> get bh >>= \s -> return $ NoOverlap    s
    99 
    -            1 -> get bh >>= \s -> return $ Overlaps     s
    100 
    -            2 -> get bh >>= \s -> return $ Incoherent   s
    101 
    -            3 -> get bh >>= \s -> return $ Overlapping  s
    102 
    -            4 -> get bh >>= \s -> return $ Overlappable s
    103 
    -            _ -> get bh >>= \s -> return $ NonCanonical s
    104 
    -
    105 72 
     pprSafeOverlap :: Bool -> SDoc
    106 73 
     pprSafeOverlap True  = text "[safe]"
    107 74 
     pprSafeOverlap False = empty

  • compiler/GHC/Hs/Doc.hs
    ... ... @@ -63,16 +63,6 @@ type instance Anno (WithHsDocIdentifiers (HsDocString (GhcPass pass)) (GhcPass p
    63 63 
     deriving instance (Data pass, Data (LIdP pass), Data a) => Data (WithHsDocIdentifiers a pass)
    64 64 
     deriving instance (Eq (LIdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass)
    65 65
    66 
    -instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where
    67 
    -  rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i)
    68 
    -
    69 
    --- | For compatibility with the existing @-ddump-parsed' output, we only show
    70 
    --- the docstring.
    71 
    ---
    72 
    --- Use 'pprHsDoc' to show `HsDoc`'s internals.
    73 
    -instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
    74 
    -  ppr (WithHsDocIdentifiers s _ids) = ppr s
    75 
    -
    76 66 
     instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where
    77 67 
       put_ bh (WithHsDocIdentifiers s ids) = do
    78 68 
           put_ bh s

  • compiler/GHC/Hs/DocString.hs
    ... ... @@ -5,6 +5,8 @@
    5 5 
     {-# LANGUAGE TypeFamilies #-}
    6 6 
     {-# LANGUAGE UndecidableInstances #-}
    7 7 
     {-# OPTIONS_GHC -Wno-orphans #-}
    8 
    +-- Binary HsDocString
    9 
    +-- Outputable HsDocString
    8 10
    9 11 
     module GHC.Hs.DocString
    10 12 
       ( LHsDocString
    ... ... @@ -44,7 +46,6 @@ import GHC.Hs.Extension.Pass (GhcPass, GhcPs, GhcRn, GhcTc)
    44 46 
     import Language.Haskell.Syntax.Doc
    45 47 
     import Language.Haskell.Syntax.Extension
    46 48
    47 
    -import Control.DeepSeq
    48 49 
     import Data.Data
    49 50 
     import Data.List.NonEmpty (NonEmpty(..))
    50 51 
     import Data.List (intercalate)
    ... ... @@ -68,25 +69,9 @@ instance (Eq (LHsDocStringChunk pass), XXHsDocString pass ~ DataConCantHappen) =
    68 69 
       GeneratedDocString _ x == GeneratedDocString _ x' = x == x'
    69 70 
       _ == _ = False
    70 71
    71 
    -instance (Show (LHsDocStringChunk pass), XXHsDocString pass ~ DataConCantHappen) => Show (HsDocString pass) where
    72 
    -  showsPrec d (MultiLineDocString _ dec xs) =
    73 
    -    showParen (d > 10) $
    74 
    -      showString "MultiLineDocString " . showsPrec 11 dec . showChar ' ' . showsPrec 11 xs
    75 
    -  showsPrec d (NestedDocString _ dec x) =
    76 
    -    showParen (d > 10) $
    77 
    -      showString "NestedDocString " . showsPrec 11 dec . showChar ' ' . showsPrec 11 x
    78 
    -  showsPrec d (GeneratedDocString _ x) =
    79 
    -    showParen (d > 10) $
    80 
    -      showString "GeneratedDocString " . showsPrec 11 x
    81 
    -
    82 72 
     instance Outputable (HsDocString (GhcPass p)) where
    83 73 
       ppr = text . renderHsDocString
    84 74
    85 
    -instance NFData (HsDocString (GhcPass p)) where
    86 
    -  rnf (MultiLineDocString _ a b) = rnf a `seq` rnf b
    87 
    -  rnf (NestedDocString _ a b) = rnf a `seq` rnf b
    88 
    -  rnf (GeneratedDocString _ a) = rnf a
    89 
    -
    90 75 
     -- | Annotate a pretty printed thing with its doc.
    91 76 
     -- The docstring comes after if it is 'HsDocStringPrevious'.
    92 77 
     -- Otherwise it comes before.
    ... ... @@ -120,37 +105,12 @@ instance Binary (HsDocString (GhcPass p)) where
    120 105 
           2 -> GeneratedDocString noExtField <$> get bh
    121 106 
           t -> fail $ "HsDocString: invalid tag " ++ show t
    122 107
    123 
    -instance Outputable HsDocStringDecorator where
    124 
    -  ppr = text . printDecorator
    125 
    -
    126 108 
     printDecorator :: HsDocStringDecorator -> String
    127 109 
     printDecorator HsDocStringNext = "|"
    128 110 
     printDecorator HsDocStringPrevious = "^"
    129 111 
     printDecorator (HsDocStringNamed n) = '$':n
    130 112 
     printDecorator (HsDocStringGroup n) = replicate n '*'
    131 113
    132 
    -instance Binary HsDocStringDecorator where
    133 
    -  put_ bh x = case x of
    134 
    -    HsDocStringNext -> putByte bh 0
    135 
    -    HsDocStringPrevious -> putByte bh 1
    136 
    -    HsDocStringNamed n -> putByte bh 2 >> put_ bh n
    137 
    -    HsDocStringGroup n -> putByte bh 3 >> put_ bh n
    138 
    -  get bh = do
    139 
    -    tag <- getByte bh
    140 
    -    case tag of
    141 
    -      0 -> pure HsDocStringNext
    142 
    -      1 -> pure HsDocStringPrevious
    143 
    -      2 -> HsDocStringNamed <$> get bh
    144 
    -      3 -> HsDocStringGroup <$> get bh
    145 
    -      t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t
    146 
    -
    147 
    -instance Binary HsDocStringChunk where
    148 
    -  put_ bh (HsDocStringChunk bs) = put_ bh bs
    149 
    -  get bh = HsDocStringChunk <$> get bh
    150 
    -
    151 
    -instance Outputable HsDocStringChunk where
    152 
    -  ppr = text . unpackHDSC
    153 
    -
    154 114 
     mkGeneratedHsDocStringGhc :: String -> HsDocString (GhcPass p)
    155 115 
     mkGeneratedHsDocStringGhc = mkGeneratedHsDocString noExtField . mkHsDocStringChunk
    156 116

  • compiler/GHC/Hs/ImpExp.hs
    ... ... @@ -447,8 +447,3 @@ coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace
    447 447 
     filterByNamespaceSpecifierGREs :: NamespaceSpecifier (GhcPass p) -> [GlobalRdrElt] -> [GlobalRdrElt]
    448 448 
     filterByNamespaceSpecifierGREs NoNamespaceSpecifier{} = id
    449 449 
     filterByNamespaceSpecifierGREs ns_spec = filterByNamespaceGREs (coveredByNamespaceSpecifier ns_spec)
    450 
    -
    451 
    -instance Outputable (NamespaceSpecifier (GhcPass p)) where
    452 
    -  ppr NoNamespaceSpecifier{} = empty
    453 
    -  ppr TypeNamespaceSpecifier{} = text "type"
    454 
    -  ppr DataNamespaceSpecifier{} = text "data"

  • compiler/GHC/Hs/Lit.hs
    ... ... @@ -505,17 +505,6 @@ instance Outputable (FractionalLit (GhcPass p)) where
    505 505 
             rat = fl_signi * (base ^^ fl_exp)
    506 506 
         in  pprWithSourceText fl_text $ rational rat
    507 507
    508 
    --- The 'Show' instance is required for the derived
    509 
    --- 'GHC.Parser.Lexer.Token' instance when DEBUG is enabled.
    510 
    -instance Show (FractionalLit (GhcPass p)) where
    511 
    -  show (FL{..}) = unwords
    512 
    -    [ show fl_text
    513 
    -    , show fl_neg
    514 
    -    , show fl_signi
    515 
    -    , show fl_exp
    516 
    -    , show fl_exp_base
    517 
    -    ]
    518 
    -
    519 508 
     mkFractionalLit ::
    520 509 
       SourceText ->
    521 510 
       Bool ->
    ... ... @@ -626,9 +615,6 @@ instance Outputable (IntegralLit (GhcPass p)) where
    626 615 
       ppr (IL (SourceText src) _ _) = ftext src
    627 616 
       ppr (IL NoSourceText _ value) = text (show value)
    628 617
    629 
    -instance Show (IntegralLit (GhcPass p)) where
    630 
    -  show (IL{..}) = unwords [ show il_text, show il_neg, show il_value ]
    631 
    -
    632 618 
     mkIntegralLit :: Integral a => a -> IntegralLit (GhcPass p)
    633 619 
     mkIntegralLit i = IL
    634 620 
       { il_text = SourceText (fsLit $ show i_integer)
    ... ... @@ -678,10 +664,6 @@ instance Eq (StringLiteral (GhcPass p)) where
    678 664 
     instance Outputable (StringLiteral (GhcPass p)) where
    679 665 
       ppr (StringLiteral{..}) = pprWithSourceText sl_src (doubleQuotes $ ppr sl_fs)
    680 666
    681 
    --- The 'Show' instance is required the 'parsed' test case of GHC's test-suite.
    682 
    -instance Show (StringLiteral (GhcPass p)) where
    683 
    -  show (StringLiteral srcTxt litFS) = unwords [ show srcTxt, show litFS ]
    684 
    -
    685 667 
     -- | Get the 'SourceText' of a 'StringLiteral'
    686 668 
     {-# INLINE stringLitSourceText #-}
    687 669 
     stringLitSourceText :: StringLiteral (GhcPass p) -> SourceText

  • compiler/GHC/Hs/Specificity.hs deleted
    1 
    -{-# OPTIONS_GHC -Wno-orphans #-}
    2 
    -module GHC.Hs.Specificity where
    3 
    -
    4 
    -import Prelude
    5 
    -import Control.DeepSeq (NFData(..))
    6 
    -
    7 
    -import GHC.Utils.Outputable
    8 
    -import GHC.Utils.Binary
    9 
    -
    10 
    -import Language.Haskell.Syntax.Specificity
    11 
    -
    12 
    -{- *********************************************************************
    13 
    -*                                                                      *
    14 
    -*                   ForAllTyFlag
    15 
    -*                                                                      *
    16 
    -********************************************************************* -}
    17 
    -
    18 
    -instance Outputable ForAllTyFlag where
    19 
    -  ppr Required  = text "[req]"
    20 
    -  ppr Specified = text "[spec]"
    21 
    -  ppr Inferred  = text "[infrd]"
    22 
    -
    23 
    -instance Binary Specificity where
    24 
    -  put_ bh SpecifiedSpec = putByte bh 0
    25 
    -  put_ bh InferredSpec  = putByte bh 1
    26 
    -
    27 
    -  get bh = do
    28 
    -    h <- getByte bh
    29 
    -    case h of
    30 
    -      0 -> return SpecifiedSpec
    31 
    -      _ -> return InferredSpec
    32 
    -
    33 
    -instance Binary ForAllTyFlag where
    34 
    -  put_ bh Required  = putByte bh 0
    35 
    -  put_ bh Specified = putByte bh 1
    36 
    -  put_ bh Inferred  = putByte bh 2
    37 
    -
    38 
    -  get bh = do
    39 
    -    h <- getByte bh
    40 
    -    case h of
    41 
    -      0 -> return Required
    42 
    -      1 -> return Specified
    43 
    -      _ -> return Inferred
    44 
    -
    45 
    -instance NFData Specificity where
    46 
    -  rnf SpecifiedSpec = ()
    47 
    -  rnf InferredSpec = ()
    48 
    -instance NFData ForAllTyFlag where
    49 
    -  rnf (Invisible spec) = rnf spec
    50 
    -  rnf Required = ()
    51 
    -

  • compiler/GHC/Parser/PostProcess.hs
    ... ... @@ -136,7 +136,6 @@ import GHC.Hs -- Lots of it
    136 136 
     import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
    137 137 
     import GHC.Core.DataCon        ( DataCon, dataConTyCon, dataConName )
    138 138 
     import GHC.Core.ConLike        ( ConLike(..) )
    139 
    -import GHC.Core.Coercion.Axiom ( fsFromRole )
    140 139 
     import GHC.Types.Name.Reader
    141 140 
     import GHC.Types.Name
    142 141 
     import GHC.Types.Basic
    ... ... @@ -424,7 +423,7 @@ mkRoleAnnotDecl loc tycon roles anns
    424 423 
       where
    425 424 
         role_data_type = dataTypeOf (undefined :: Role)
    426 425 
         all_roles = map fromConstr $ dataTypeConstrs role_data_type
    427 
    -    possible_roles = [(fsFromRole role, role) | role <- all_roles]
    426 
    +    possible_roles = [(strFromRole role, role) | role <- all_roles]
    428 427
    429 428 
         parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing
    430 429 
         parse_role (L loc_role (Just role))

  • compiler/GHC/Types/Basic.hs
    ... ... @@ -14,14 +14,6 @@ types that
    14 14 
     \end{itemize}
    15 15 
     -}
    16 16
    17 
    -{-# OPTIONS_GHC -Wno-orphans #-}
    18 
    -{-
    19 
    -Above flag is necessary for these instances:
    20 
    -  * Binary Boxity
    21 
    -  * Binary PromotionFlag
    22 
    -  * Outputable Boxity
    23 
    -  * Outputable PromotionFlag
    24 
    --}
    25 17 
     {-# LANGUAGE DerivingVia #-}
    26 18
    27 19 
     module GHC.Types.Basic (
    ... ... @@ -377,27 +369,6 @@ unSwap NotSwapped f a b = f a b
    377 369 
     unSwap IsSwapped  f a b = f b a
    378 370
    379 371
    380 
    -{- *********************************************************************
    381 
    -*                                                                      *
    382 
    -           Promotion flag
    383 
    -*                                                                      *
    384 
    -********************************************************************* -}
    385 
    -
    386 
    -instance Outputable PromotionFlag where
    387 
    -  ppr NotPromoted = text "NotPromoted"
    388 
    -  ppr IsPromoted  = text "IsPromoted"
    389 
    -
    390 
    -instance Binary PromotionFlag where
    391 
    -   put_ bh NotPromoted = putByte bh 0
    392 
    -   put_ bh IsPromoted  = putByte bh 1
    393 
    -
    394 
    -   get bh = do
    395 
    -       n <- getByte bh
    396 
    -       case n of
    397 
    -         0 -> return NotPromoted
    398 
    -         1 -> return IsPromoted
    399 
    -         _ -> fail "Binary(IsPromoted): fail)"
    400 
    -
    401 372 
     {-
    402 373 
     ************************************************************************
    403 374 
     *                                                                      *

  • compiler/GHC/Types/FieldLabel.hs
    1 1 
     {-# LANGUAGE UndecidableInstances #-}
    2 
    -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString
    3 2
    4 3 
     {-
    5 4 
     %
    ... ... @@ -48,7 +47,6 @@ import GHC.Prelude
    48 47
    49 48 
     import {-# SOURCE #-} GHC.Types.Name
    50 49
    51 
    -import GHC.Types.Unique (Uniquable(..))
    52 50 
     import GHC.Utils.Outputable
    53 51 
     import GHC.Utils.Binary
    54 52 
     import GHC.Data.FastString
    ... ... @@ -89,12 +87,6 @@ instance Outputable FieldLabel where
    89 87 
                                                     <> ppr (flHasDuplicateRecordFields fl)
    90 88 
                                                     <> ppr (flHasFieldSelector fl))
    91 89
    92 
    -instance Outputable FieldLabelString where
    93 
    -  ppr (FieldLabelString l) = ppr l
    94 
    -
    95 
    -instance Uniquable FieldLabelString where
    96 
    -  getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs)
    97 
    -
    98 90 
     -- | Flag to indicate whether the DuplicateRecordFields extension is enabled.
    99 91 
     data DuplicateRecordFields
    100 92 
         = DuplicateRecordFields   -- ^ Fields may be duplicated in a single module

  • compiler/GHC/Types/Fixity.hs
    1 
    -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances
    2 
    -
    3 1 
     -- | Fixity
    4 2 
     module GHC.Types.Fixity
    5 3 
        ( Fixity (..)
    ... ... @@ -11,14 +9,12 @@ module GHC.Types.Fixity
    11 9 
        , negateFixity
    12 10 
        , funTyFixity
    13 11 
        , compareFixity
    14 
    -   , module GHC.Hs.Basic
    15 12 
        )
    16 13 
     where
    17 14
    18 15 
     import GHC.Prelude
    19 16
    20 17 
     import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) )
    21 
    -import GHC.Hs.Basic () -- For instances only
    22 18
    23 19 
     ------------------------
    24 20

  • compiler/GHC/Types/ForeignCall.hs
    ... ... @@ -319,13 +319,6 @@ type instance XXHeader (GhcPass p) = DataConCantHappen
    319 319
    320 320 
     deriving instance Eq (Header (GhcPass p))
    321 321
    322 
    -instance NFData (CType (GhcPass p)) where
    323 
    -    rnf (CType ext mh fs) =
    324 
    -      rnf ext `seq` rnf mh `seq` rnf fs
    325 
    -
    326 
    -instance NFData (Header (GhcPass p)) where
    327 
    -    rnf (Header s h) =
    328 
    -      rnf s `seq` rnf h
    329 322
    330 323 
     instance NFData CCallStaticTargetUnit where
    331 324 
         rnf = \case
    ... ... @@ -388,14 +381,6 @@ instance forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where
    388 381 
               GhcTc -> x1 == x2
    389 382 
             _ -> False
    390 383
    391 
    -instance forall p. IsPass p => NFData (CCallTarget (GhcPass p)) where
    392 
    -    rnf = \case
    393 
    -      DynamicTarget NoExtField -> ()
    394 
    -      StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of
    395 
    -        GhcPs -> rnf x
    396 
    -        GhcRn -> rnf x
    397 
    -        GhcTc -> rnf x
    398 
    -
    399 384 
     instance forall p. IsPass p => Binary (CCallTarget (GhcPass p)) where
    400 385 
         put_ bh = \case
    401 386 
           StaticTarget x a b -> do

  • compiler/GHC/Types/InlinePragma.hs
    ... ... @@ -9,16 +9,8 @@
    9 9 
     -}
    10 10
    11 11 
     {-# OPTIONS_GHC -Wno-orphans #-}
    12 
    -{-
    13 
    -Suppression of warnings are required for instances:
    14 
    -  - Binary Activation
    15 
    -  - Binary CompilerPhase
    16 
    -  - Binary InlinePragma
    17 
    -  - Binary InlineSaturation
    18 
    -  - Binary XActivation
    19 
    -  - Binary XInlinePragmaGhc
    20 
    -  - Outputable CompilerPhase
    21 
    --}
    12 
    +-- Required for TTG type-family definitions,
    13 
    +-- There are no orphan type-class instances
    22 14
    23 15 
     module GHC.Types.InlinePragma
    24 16 
       ( -- * Inline Pragma Encoding
    ... ... @@ -494,10 +486,6 @@ no harm.
    494 486 
         always returns 'False' when its second argument is 'NeverActive'.
    495 487 
     -}
    496 488
    497 
    -{- TODO: These orphan instance should be moved to the GHC.Utils.{Binary,Outputable}
    498 
    -modules once TTG has progressed and the Language.Haskell.Syntax.Types module
    499 
    -no longer depends on importing GHC.Hs.Doc.
    500 
    --}
    501 489 
     instance Binary XInlinePragmaGhc where
    502 490 
         put_ bh (XInlinePragmaGhc s a) = do
    503 491 
                 put_ bh s
    ... ... @@ -508,26 +496,6 @@ instance Binary XInlinePragmaGhc where
    508 496 
                a <- get bh
    509 497 
                return (XInlinePragmaGhc s a)
    510 498
    511 
    -instance forall p. IsPass p => Binary (InlinePragma (GhcPass p)) where
    512 
    -    put_ bh (InlinePragma s a b c) = do
    513 
    -            put_ bh a
    514 
    -            put_ bh b
    515 
    -            put_ bh c
    516 
    -            case ghcPass @p of
    517 
    -              GhcPs -> put_ bh s
    518 
    -              GhcRn -> put_ bh s
    519 
    -              GhcTc -> put_ bh s
    520 
    -
    521 
    -    get bh = do
    522 
    -           a <- get bh
    523 
    -           b <- get bh
    524 
    -           c <- get bh
    525 
    -           s <- case ghcPass @p of
    526 
    -                  GhcPs -> get bh
    527 
    -                  GhcRn -> get bh
    528 
    -                  GhcTc -> get bh
    529 
    -           return (InlinePragma s a b c)
    530 
    -
    531 499 
     instance Binary InlineSaturation where
    532 500 
         put_ bh AnySaturation = putByte bh 0
    533 501 
         put_ bh (AppliedToAtLeast w) = putByte bh 1 *> put_ bh w
    ... ... @@ -620,5 +588,24 @@ pprInline' emptyInline (InlinePragma
    620 588 
             AnySaturation -> empty
    621 589 
             AppliedToAtLeast ar -> parens (text "sat-args=" <> int ar)
    622 590
    591 
    +{- TODO: This orphan instance should be moved to GHC.Utils.Outputable once that
    592 
    +module can import 'GhcPass' without causing an import cycle.
    593 
    +@
    594 
    +┌──────▶ GHC.Utils.Outputable
    595 
    +│               │
    596 
    +│               │ Needs to access GhcPass for instance:
    597 
    +│               │ Outputable (InlinePragma (GhcPass p))
    598 
    +│               ▼
    599 
    +│       GHC.Hs.Extension.GhcPass
    600 
    +│               │
    601 
    +│               │ For GenLocated, SrcSpan, unLoc
    602 
    +│               ▼
    603 
    +│       GHC.Types.SrcLoc
    604 
    +│               │
    605 
    +│               │ for Outputable, SDoc,
    606 
    +│               │ pprFastFilePath, ppr combinators
    607 
    +└───────────────┘
    608 
    +@
    609 
    +-}
    623 610 
     instance forall p. IsPass p => Outputable (InlinePragma (GhcPass p)) where
    624 611 
       ppr = pprInline

  • compiler/GHC/Types/Unique.hs
    ... ... @@ -68,7 +68,8 @@ import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))
    68 68 
     import GHC.Word         ( Word64 )
    69 69 
     import Data.Char        ( chr, ord, isPrint )
    70 70
    71 
    -import Language.Haskell.Syntax.Module.Name
    71 
    +import Language.Haskell.Syntax.Basic ( FieldLabelString(..) )
    72 
    +import Language.Haskell.Syntax.Module.Name ( ModuleName(..) )
    72 73
    73 74 
     {-
    74 75 
     ************************************************************************
    ... ... @@ -419,6 +420,8 @@ instance Uniquable Word64 where
    419 420 
     instance Uniquable ModuleName where
    420 421 
       getUnique (ModuleName nm) = getUnique nm
    421 422
    423 
    +instance Uniquable FieldLabelString where
    424 
    +  getUnique (FieldLabelString fs) = getUnique (mkFastStringShortText fs)
    422 425
    423 426 
     {-
    424 427 
     ************************************************************************

  • compiler/GHC/Types/Var.hs
    ... ... @@ -129,7 +129,6 @@ import GHC.Utils.Binary
    129 129 
     import GHC.Utils.Outputable
    130 130 
     import GHC.Utils.Panic
    131 131
    132 
    -import GHC.Hs.Specificity ()
    133 132 
     import Language.Haskell.Syntax.Specificity
    134 133 
     import Control.DeepSeq
    135 134

  • compiler/GHC/Utils/Binary.hs
    1 1 
     {-# LANGUAGE CPP #-}
    2 
    +{-# LANGUAGE FlexibleContexts #-}
    2 3 
     {-# LANGUAGE MagicHash #-}
    4 
    +{-# LANGUAGE TypeFamilies #-}
    5 
    +{-# LANGUAGE UndecidableInstances #-}
    3 6 
     {-# LANGUAGE UnboxedTuples #-}
    4 7 
     {-# LANGUAGE DerivingVia #-}
    5 8
    ... ... @@ -119,8 +122,13 @@ import GHC.Prelude
    119 122
    120 123 
     import Language.Haskell.Syntax.Basic
    121 124 
     import Language.Haskell.Syntax.Binds.InlinePragma
    125 
    +import Language.Haskell.Syntax.Decls.Overlap
    126 
    +import Language.Haskell.Syntax.Doc
    127 
    +import Language.Haskell.Syntax.Extension
    122 128 
     import Language.Haskell.Syntax.Module.Name (ModuleName(..))
    123 129 
     import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
    130 
    +import Language.Haskell.Syntax.Specificity
    131 
    +import Language.Haskell.Syntax.Type (PromotionFlag(..))
    124 132
    125 133 
     import {-# SOURCE #-} GHC.Types.Name (Name)
    126 134 
     import GHC.Data.ShortText (ShortText)
    ... ... @@ -164,7 +172,7 @@ import qualified Data.Map.Strict as Map
    164 172 
     import Data.Proxy
    165 173 
     import Data.Set                 ( Set )
    166 174 
     import qualified Data.Set as Set
    167 
    -import Data.Time
    175 
    +import Data.Time hiding ( Nominal )
    168 176 
     import Data.List (unfoldr)
    169 177 
     import System.IO as IO
    170 178 
     import System.IO.Error          ( mkIOError, eofErrorType )
    ... ... @@ -1926,6 +1934,85 @@ instance Binary ModuleName where
    1926 1934 
       put_ bh (ModuleName fs) = put_ bh fs
    1927 1935 
       get bh = do fs <- get bh; return (ModuleName fs)
    1928 1936
    1937 
    +instance Binary Specificity where
    1938 
    +  put_ bh SpecifiedSpec = putByte bh 0
    1939 
    +  put_ bh InferredSpec  = putByte bh 1
    1940 
    +
    1941 
    +  get bh = do
    1942 
    +    h <- getByte bh
    1943 
    +    case h of
    1944 
    +      0 -> return SpecifiedSpec
    1945 
    +      _ -> return InferredSpec
    1946 
    +
    1947 
    +instance Binary ForAllTyFlag where
    1948 
    +  put_ bh Required  = putByte bh 0
    1949 
    +  put_ bh Specified = putByte bh 1
    1950 
    +  put_ bh Inferred  = putByte bh 2
    1951 
    +
    1952 
    +  get bh = do
    1953 
    +    h <- getByte bh
    1954 
    +    case h of
    1955 
    +      0 -> return Required
    1956 
    +      1 -> return Specified
    1957 
    +      _ -> return Inferred
    1958 
    +
    1959 
    +instance Binary HsDocStringDecorator where
    1960 
    +  put_ bh x = case x of
    1961 
    +    HsDocStringNext -> putByte bh 0
    1962 
    +    HsDocStringPrevious -> putByte bh 1
    1963 
    +    HsDocStringNamed n -> putByte bh 2 >> put_ bh n
    1964 
    +    HsDocStringGroup n -> putByte bh 3 >> put_ bh n
    1965 
    +
    1966 
    +  get bh = do
    1967 
    +    tag <- getByte bh
    1968 
    +    case tag of
    1969 
    +      0 -> pure HsDocStringNext
    1970 
    +      1 -> pure HsDocStringPrevious
    1971 
    +      2 -> HsDocStringNamed <$> get bh
    1972 
    +      3 -> HsDocStringGroup <$> get bh
    1973 
    +      t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t
    1974 
    +
    1975 
    +instance Binary HsDocStringChunk where
    1976 
    +  put_ bh (HsDocStringChunk bs) = put_ bh bs
    1977 
    +  get bh = HsDocStringChunk <$> get bh
    1978 
    +
    1979 
    +instance ( Binary (XInlinePragma p)
    1980 
    +         , Binary (Activation p)
    1981 
    +         , XXInlinePragma p ~ DataConCantHappen
    1982 
    +         ) => Binary (InlinePragma p) where
    1983 
    +  put_ bh (InlinePragma s a b c) = do
    1984 
    +    put_ bh a
    1985 
    +    put_ bh b
    1986 
    +    put_ bh c
    1987 
    +    put_ bh s
    1988 
    +
    1989 
    +  get bh = do
    1990 
    +    a <- get bh
    1991 
    +    b <- get bh
    1992 
    +    c <- get bh
    1993 
    +    s <- get bh
    1994 
    +    return (InlinePragma s a b c)
    1995 
    +
    1996 
    +instance ( Binary (XOverlapMode p)
    1997 
    +         , XXOverlapMode p ~ DataConCantHappen
    1998 
    +         ) => Binary (OverlapMode p) where
    1999 
    +  put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
    2000 
    +  put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
    2001 
    +  put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
    2002 
    +  put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
    2003 
    +  put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
    2004 
    +  put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s
    2005 
    +
    2006 
    +  get bh = do
    2007 
    +    h <- getByte bh
    2008 
    +    case h of
    2009 
    +      0 -> get bh >>= \s -> return $ NoOverlap    s
    2010 
    +      1 -> get bh >>= \s -> return $ Overlaps     s
    2011 
    +      2 -> get bh >>= \s -> return $ Incoherent   s
    2012 
    +      3 -> get bh >>= \s -> return $ Overlapping  s
    2013 
    +      4 -> get bh >>= \s -> return $ Overlappable s
    2014 
    +      _ -> get bh >>= \s -> return $ NonCanonical s
    2015 
    +
    1929 2016 
     newtype BinLocated a = BinLocated { unBinLocated :: Located a }
    1930 2017
    1931 2018 
     instance Binary a => Binary (BinLocated a) where
    ... ... @@ -2087,6 +2174,26 @@ instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool
    2087 2174 
         b <- get bh
    2088 2175 
         pure $ if b then Boxed else Unboxed
    2089 2176
    2177 
    +instance Binary Fixity where
    2178 
    +  put_ bh (Fixity aa ab) = do
    2179 
    +    put_ bh aa
    2180 
    +    put_ bh ab
    2181 
    +  get bh = do
    2182 
    +    aa <- get bh
    2183 
    +    ab <- get bh
    2184 
    +    return (Fixity aa ab)
    2185 
    +
    2186 
    +instance Binary FixityDirection where
    2187 
    +  put_ bh InfixL = putByte bh 0
    2188 
    +  put_ bh InfixR = putByte bh 1
    2189 
    +  put_ bh InfixN = putByte bh 2
    2190 
    +  get bh = do
    2191 
    +    h <- getByte bh
    2192 
    +    case h of
    2193 
    +      0 -> return InfixL
    2194 
    +      1 -> return InfixR
    2195 
    +      _ -> return InfixN
    2196 
    +
    2090 2197 
     instance Binary ConInfoTable where
    2091 2198 
       get bh = Binary.decode <$> get bh
    2092 2199
    ... ... @@ -2149,3 +2256,49 @@ instance Binary RuleMatchInfo where
    2149 2256 
           h <- getByte bh
    2150 2257 
           if h == 1 then pure ConLike
    2151 2258 
                     else pure FunLike
    2259 
    +
    2260 
    +instance Binary Role where
    2261 
    +  put_ bh Nominal          = putByte bh 1
    2262 
    +  put_ bh Representational = putByte bh 2
    2263 
    +  put_ bh Phantom          = putByte bh 3
    2264 
    +
    2265 
    +  get bh = do tag <- getByte bh
    2266 
    +              case tag of 1 -> return Nominal
    2267 
    +                          2 -> return Representational
    2268 
    +                          3 -> return Phantom
    2269 
    +                          _ -> panic ("get Role " ++ show tag)
    2270 
    +
    2271 
    +instance Binary SrcStrictness where
    2272 
    +    put_ bh SrcLazy     = putByte bh 0
    2273 
    +    put_ bh SrcStrict   = putByte bh 1
    2274 
    +    put_ bh NoSrcStrict = putByte bh 2
    2275 
    +
    2276 
    +    get bh =
    2277 
    +      do h <- getByte bh
    2278 
    +         case h of
    2279 
    +           0 -> return SrcLazy
    2280 
    +           1 -> return SrcStrict
    2281 
    +           _ -> return NoSrcStrict
    2282 
    +
    2283 
    +instance Binary SrcUnpackedness where
    2284 
    +    put_ bh SrcNoUnpack = putByte bh 0
    2285 
    +    put_ bh SrcUnpack   = putByte bh 1
    2286 
    +    put_ bh NoSrcUnpack = putByte bh 2
    2287 
    +
    2288 
    +    get bh =
    2289 
    +      do h <- getByte bh
    2290 
    +         case h of
    2291 
    +           0 -> return SrcNoUnpack
    2292 
    +           1 -> return SrcUnpack
    2293 
    +           _ -> return NoSrcUnpack
    2294 
    +
    2295 
    +instance Binary PromotionFlag where
    2296 
    +   put_ bh NotPromoted = putByte bh 0
    2297 
    +   put_ bh IsPromoted  = putByte bh 1
    2298 
    +
    2299 
    +   get bh = do
    2300 
    +       n <- getByte bh
    2301 
    +       case n of
    2302 
    +         0 -> return NotPromoted
    2303 
    +         1 -> return IsPromoted
    2304 
    +         _ -> fail "Binary(IsPromoted): fail)"

  • compiler/GHC/Utils/Outputable.hs
    ... ... @@ -115,12 +115,17 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName )
    115 115 
     import Language.Haskell.Syntax.Basic
    116 116 
     import Language.Haskell.Syntax.Binds.InlinePragma
    117 117 
     import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) )
    118 
    +import Language.Haskell.Syntax.Doc
    119 
    +import Language.Haskell.Syntax.ImpExp ( NamespaceSpecifier(..) )
    118 120 
     import Language.Haskell.Syntax.Module.Name ( ModuleName(..) )
    121 
    +import Language.Haskell.Syntax.Specificity
    119 122 
     import Language.Haskell.Syntax.Text
    123 
    +import Language.Haskell.Syntax.Type ( PromotionFlag(..) )
    120 124
    121 125 
     import GHC.Prelude.Basic
    122 126
    123 127 
     import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS)
    128 
    +import GHC.Utils.Encoding ( utf8DecodeByteString )
    124 129 
     import GHC.Data.FastString
    125 130 
     import qualified GHC.Utils.Ppr as Pretty
    126 131 
     import qualified GHC.Utils.Ppr.Colour as Col
    ... ... @@ -1108,6 +1113,28 @@ instance Outputable Extension where
    1108 1113 
     instance Outputable ModuleName where
    1109 1114 
       ppr = pprModuleName
    1110 1115
    1116 
    +instance Outputable FieldLabelString where
    1117 
    +  ppr (FieldLabelString l) = ppr l
    1118 
    +
    1119 
    +instance Outputable ForAllTyFlag where
    1120 
    +  ppr Required  = text "[req]"
    1121 
    +  ppr Specified = text "[spec]"
    1122 
    +  ppr Inferred  = text "[infrd]"
    1123 
    +
    1124 
    +instance Outputable HsDocStringDecorator where
    1125 
    +  ppr HsDocStringNext        = text "|"
    1126 
    +  ppr HsDocStringPrevious    = text "^"
    1127 
    +  ppr (HsDocStringNamed n)   = char '$' <> text n
    1128 
    +  ppr (HsDocStringGroup n)   = text (replicate n '*')
    1129 
    +
    1130 
    +instance Outputable HsDocStringChunk where
    1131 
    +  ppr (HsDocStringChunk bs) = text (utf8DecodeByteString bs)
    1132 
    +
    1133 
    +-- | For compatibility with the existing @-ddump-parsed@ output, we only show
    1134 
    +-- the docstring.
    1135 
    +instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
    1136 
    +  ppr (WithHsDocIdentifiers s _ids) = ppr s
    1137 
    +
    1111 1138 
     instance Outputable OsPath where
    1112 1139 
       ppr p = text $ either show id (decodeUtf p)
    1113 1140
    ... ... @@ -2039,6 +2066,35 @@ instance Outputable TopLevelFlag where
    2039 2066 
       ppr TopLevel    = text "<TopLevel>"
    2040 2067 
       ppr NotTopLevel = text "<NotTopLevel>"
    2041 2068
    2069 
    +instance Outputable LexicalFixity where
    2070 
    +  ppr Prefix = text "Prefix"
    2071 
    +  ppr Infix  = text "Infix"
    2072 
    +
    2073 
    +instance Outputable FixityDirection where
    2074 
    +  ppr InfixL = text "infixl"
    2075 
    +  ppr InfixR = text "infixr"
    2076 
    +  ppr InfixN = text "infix"
    2077 
    +
    2078 
    +instance Outputable Fixity where
    2079 
    +  ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
    2080 
    +
    2081 
    +instance Outputable SrcStrictness where
    2082 
    +    ppr SrcLazy     = char '~'
    2083 
    +    ppr SrcStrict   = char '!'
    2084 
    +    ppr NoSrcStrict = empty
    2085 
    +
    2086 
    +instance Outputable SrcUnpackedness where
    2087 
    +    ppr SrcUnpack   = text "{-# UNPACK #-}"
    2088 
    +    ppr SrcNoUnpack = text "{-# NOUNPACK #-}"
    2089 
    +    ppr NoSrcUnpack = empty
    2090 
    +
    2091 
    +instance Outputable PromotionFlag where
    2092 
    +  ppr NotPromoted = text "NotPromoted"
    2093 
    +  ppr IsPromoted  = text "IsPromoted"
    2094 
    +
    2095 
    +instance Outputable Role where
    2096 
    +  ppr = ftext . strFromRole
    2097 
    +
    2042 2098 
     instance Outputable (OverlapMode p) where
    2043 2099 
       ppr (NoOverlap    _) = empty
    2044 2100 
       ppr (Overlappable _) = text "[overlappable]"
    ... ... @@ -2047,3 +2103,9 @@ instance Outputable (OverlapMode p) where
    2047 2103 
       ppr (Incoherent   _) = text "[incoherent]"
    2048 2104 
       ppr (NonCanonical _) = text "[noncanonical]"
    2049 2105 
       ppr (XOverlapMode _) = text "[user TTG extension]"
    2106 
    +
    2107 
    +instance Outputable (NamespaceSpecifier p) where
    2108 
    +  ppr NoNamespaceSpecifier{}   = empty
    2109 
    +  ppr TypeNamespaceSpecifier{} = text "type"
    2110 
    +  ppr DataNamespaceSpecifier{} = text "data"
    2111 
    +  ppr (XNamespaceSpecifier _)  = text "[user TTG extension]"

  • compiler/Language/Haskell/Syntax/Basic.hs
    ... ... @@ -8,6 +8,7 @@ import Data.Data (Data)
    8 8 
     import Data.Eq
    9 9 
     import Data.Ord
    10 10 
     import Data.Bool
    11 
    +import Data.String (IsString(..))
    11 12 
     import Prelude
    12 13
    13 14 
     {-
    ... ... @@ -93,6 +94,20 @@ Field Labels
    93 94 
     data Role = Nominal | Representational | Phantom
    94 95 
       deriving (Eq, Ord, Data)
    95 96
    97 
    +instance NFData Role where
    98 
    +  rnf Nominal = ()
    99 
    +  rnf Representational = ()
    100 
    +  rnf Phantom = ()
    101 
    +
    102 
    +-- These names are slurped into the parser code. Changing these strings
    103 
    +-- will change the **surface syntax** that GHC accepts! If you want to
    104 
    +-- change only the pretty-printing, do some replumbing. See
    105 
    +-- mkRoleAnnotDecl in GHC.Parser.PostProcess
    106 
    +strFromRole :: IsString s => Role -> s
    107 
    +strFromRole Nominal          = fromString "nominal"
    108 
    +strFromRole Representational = fromString "representational"
    109 
    +strFromRole Phantom          = fromString "phantom"
    110 
    +
    96 111 
     {-
    97 112 
     ************************************************************************
    98 113 
     *                                                                      *
    ... ... @@ -109,6 +124,11 @@ data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
    109 124 
                        | NoSrcStrict -- ^ no strictness annotation
    110 125 
          deriving (Eq, Data)
    111 126
    127 
    +instance NFData SrcStrictness where
    128 
    +  rnf SrcLazy = ()
    129 
    +  rnf SrcStrict = ()
    130 
    +  rnf NoSrcStrict = ()
    131 
    +
    112 132 
     -- | Source Unpackedness
    113 133 
     --
    114 134 
     -- What unpackedness the user requested
    ... ... @@ -117,6 +137,11 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
    117 137 
                          | NoSrcUnpack -- ^ no unpack pragma
    118 138 
          deriving (Eq, Data)
    119 139
    140 
    +instance NFData SrcUnpackedness where
    141 
    +  rnf SrcNoUnpack = ()
    142 
    +  rnf SrcUnpack = ()
    143 
    +  rnf NoSrcUnpack = ()
    144 
    +
    120 145 
     {-
    121 146 
     ************************************************************************
    122 147 
     *                                                                      *

  • compiler/Language/Haskell/Syntax/Decls/Foreign.hs
    ... ... @@ -74,7 +74,7 @@ import Control.DeepSeq
    74 74 
     import Data.Data        hiding (TyCon, Fixity, Infix)
    75 75 
     import Data.Maybe
    76 76 
     import Data.Eq
    77 
    -import Prelude (Enum, Show)
    77 
    +import Prelude (Enum, Show, seq)
    78 78
    79 79 
     {-
    80 80 
     ************************************************************************
    ... ... @@ -211,6 +211,12 @@ data CCallTarget pass
    211 211 
       | DynamicTarget (XDynamicTarget pass)
    212 212 
       | XCCallTarget !(XXCCallTarget pass)
    213 213
    214 
    +instance (NFData (XStaticTarget pass), NFData (XDynamicTarget pass), NFData (XXCCallTarget pass))
    215 
    +      => NFData (CCallTarget pass) where
    216 
    +  rnf (StaticTarget x a b) = rnf x `seq` rnf a `seq` rnf b
    217 
    +  rnf (DynamicTarget x) = rnf x
    218 
    +  rnf (XCCallTarget x) = rnf x
    219 
    +
    214 220 
     data CExportSpec
    215 221 
       -- | foreign export ccall foo :: ty
    216 222 
       = CExportStatic
    ... ... @@ -228,6 +234,11 @@ data CType pass
    228 234 
           HText
    229 235 
       | XCType !(XXCType pass)
    230 236
    237 
    +instance (NFData (XCType pass), NFData (Header pass), NFData (XXCType pass))
    238 
    +      => NFData (CType pass) where
    239 
    +  rnf (CType ext mh fs) = rnf ext `seq` rnf mh `seq` rnf fs
    240 
    +  rnf (XCType x) = rnf x
    241 
    +
    231 242 
     -- | The filename for a C header file
    232 243 
     data Header pass
    233 244 
       = Header
    ... ... @@ -235,6 +246,10 @@ data Header pass
    235 246 
           HText
    236 247 
       | XHeader !(XXHeader pass)
    237 248
    249 
    +instance (NFData (XHeader pass), NFData (XXHeader pass)) => NFData (Header pass) where
    250 
    +  rnf (Header s h) = rnf s `seq` rnf h
    251 
    +  rnf (XHeader x) = rnf x
    252 
    +
    238 253 
     data Safety
    239 254 
       = PlaySafe          -- ^ Might invoke Haskell GC, or do a call back, or
    240 255 
                           --   switch threads, etc.  So make sure things are

  • compiler/Language/Haskell/Syntax/Doc.hs
    ... ... @@ -65,6 +65,32 @@ data HsDocString pass
    65 65 
       | XHsDocString
    66 66 
           !(XXHsDocString pass)
    67 67
    68 
    +instance
    69 
    +  ( NFData (XMultiLineDocString pass)
    70 
    +  , NFData (XNestedDocString pass)
    71 
    +  , NFData (XGeneratedDocString pass)
    72 
    +  , NFData (XXHsDocString pass)
    73 
    +  , NFData (LHsDocStringChunk pass)
    74 
    +  ) => NFData (HsDocString pass) where
    75 
    +  rnf (MultiLineDocString x a b) = rnf x `seq` rnf a `seq` rnf b
    76 
    +  rnf (NestedDocString x a b) = rnf x `seq` rnf a `seq` rnf b
    77 
    +  rnf (GeneratedDocString x a) = rnf x `seq` rnf a
    78 
    +  rnf (XHsDocString x) = rnf x
    79 
    +
    80 
    +instance (Show (LHsDocStringChunk pass), Show (XXHsDocString pass)) => Show (HsDocString pass) where
    81 
    +  showsPrec d (MultiLineDocString _ dec xs) =
    82 
    +    showParen (d > 10) $
    83 
    +      showString "MultiLineDocString " . showsPrec 11 dec . showChar ' ' . showsPrec 11 xs
    84 
    +  showsPrec d (NestedDocString _ dec x) =
    85 
    +    showParen (d > 10) $
    86 
    +      showString "NestedDocString " . showsPrec 11 dec . showChar ' ' . showsPrec 11 x
    87 
    +  showsPrec d (GeneratedDocString _ x) =
    88 
    +    showParen (d > 10) $
    89 
    +      showString "GeneratedDocString " . showsPrec 11 x
    90 
    +  showsPrec d (XHsDocString x) =
    91 
    +    showParen (d > 10) $
    92 
    +      showString "XHsDocString " . showsPrec 11 x
    93 
    +
    68 94 
     mkGeneratedHsDocString :: XGeneratedDocString p -> HsDocStringChunk -> HsDocString p
    69 95 
     mkGeneratedHsDocString x = GeneratedDocString x
    70 96
    ... ... @@ -110,3 +136,6 @@ data WithHsDocIdentifiers a pass = WithHsDocIdentifiers
    110 136 
       { hsDocString      :: !a
    111 137 
       , hsDocIdentifiers :: ![LIdP pass]
    112 138 
       }
    139 
    +
    140 
    +instance (UnXRec pass, NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where
    141 
    +  rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf (map (unXRec @pass) i)

  • compiler/Language/Haskell/Syntax/Extension.hs
    ... ... @@ -9,6 +9,7 @@ module Language.Haskell.Syntax.Extension where
    9 9 
     -- This module captures the type families to precisely identify the extension
    10 10 
     -- points for GHC.Hs syntax
    11 11
    12 
    +import Control.DeepSeq
    12 13 
     import Data.Type.Equality (type (~))
    13 14
    14 15 
     import Data.Data hiding ( Fixity )
    ... ... @@ -16,6 +17,7 @@ import Data.Kind (Type)
    16 17
    17 18 
     import Data.Eq
    18 19 
     import Data.Ord
    20 
    +import Text.Show
    19 21
    20 22 
     {-
    21 23 
     Note [Trees That Grow]
    ... ... @@ -62,6 +64,9 @@ See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension.
    62 64 
     data NoExtField = NoExtField
    63 65 
       deriving (Data,Eq,Ord)
    64 66
    67 
    +instance NFData NoExtField where
    68 
    +  rnf NoExtField = ()
    69 
    +
    65 70 
     -- | Used when constructing a term with an unused extension point.
    66 71 
     noExtField :: NoExtField
    67 72 
     noExtField = NoExtField
    ... ... @@ -95,7 +100,10 @@ can only do that if the extension field was strict (#18764).
    95 100 
     See also [DataConCantHappen and strict fields].
    96 101 
     -}
    97 102 
     data DataConCantHappen
    98 
    -  deriving (Data,Eq,Ord)
    103 
    +  deriving (Data,Eq,Ord,Show)
    104 
    +
    105 
    +instance NFData DataConCantHappen where
    106 
    +  rnf = dataConCantHappen
    99 107
    100 108 
     -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur].
    101 109 
     dataConCantHappen :: DataConCantHappen -> a

  • compiler/Language/Haskell/Syntax/ImpExp.hs
    1 1 
     {-# LANGUAGE TypeFamilies #-}
    2 
    +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
    3 
    +                                      -- in module Language.Haskell.Syntax.Extension
    2 4 
     module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where
    3 5
    4 6 
     import Language.Haskell.Syntax.Doc (LHsDoc)
    ... ... @@ -6,9 +8,9 @@ import Language.Haskell.Syntax.Extension
    6 8 
     import Language.Haskell.Syntax.Module.Name
    7 9 
     import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) )
    8 10
    9 
    -import Data.Eq (Eq)
    11 
    +import Data.Eq (Eq(..))
    10 12 
     import Data.Data (Data)
    11 
    -import Data.Bool (Bool)
    13 
    +import Data.Bool (Bool(..))
    12 14 
     import Data.Maybe (Maybe)
    13 15 
     import Data.String (String)
    14 16 
     import Data.Int (Int)

  • compiler/Language/Haskell/Syntax/Lit.hs
    1 
    +{-# LANGUAGE RecordWildCards #-}
    1 2 
     {-# LANGUAGE TypeFamilies #-}
    2 3 
     {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
    3 4 
                                           -- in module Language.Haskell.Syntax.Extension
    ... ... @@ -118,6 +119,7 @@ data OverLitVal x
    118 119 
       = HsIntegral   !(IntegralLit   x) -- ^ Integer-looking literals
    119 120 
       | HsFractional !(FractionalLit x) -- ^    Frac-looking literals
    120 121 
       | HsIsString   !(StringLiteral x) -- ^  String-looking literals
    122 
    +
    121 123 
     -- | Haskell Qualified Literal
    122 124 
     data HsQualLit p
    123 125 
       = QualLit
    ... ... @@ -158,6 +160,18 @@ data FractionalLit pass = FL
    158 160 
       }
    159 161 
       | XFractionalLit !(XXFractionalLit pass)
    160 162
    163 
    +-- The 'Show' instance is required for the derived
    164 
    +-- 'GHC.Parser.Lexer.Token' instance when DEBUG is enabled.
    165 
    +instance (Show (XFractionalLit pass), Show (XXFractionalLit pass)) => Show (FractionalLit pass) where
    166 
    +  show (FL{..}) = unwords
    167 
    +    [ show fl_text
    168 
    +    , show fl_neg
    169 
    +    , show fl_signi
    170 
    +    , show fl_exp
    171 
    +    , show fl_exp_base
    172 
    +    ]
    173 
    +  show (XFractionalLit x) = show x
    174 
    +
    161 175 
     {- Note [fractional exponent bases]
    162 176 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    163 177 
     For hexadecimal rationals of
    ... ... @@ -183,6 +197,10 @@ data IntegralLit pass = IL
    183 197 
       }
    184 198 
       | XIntegralLit !(XXIntegralLit pass)
    185 199
    200 
    +instance (Show (XIntegralLit pass), Show (XXIntegralLit pass)) => Show (IntegralLit pass) where
    201 
    +  show (IL{..}) = unwords [ show il_text, show il_neg, show il_value ]
    202 
    +  show (XIntegralLit x) = show x
    203 
    +
    186 204 
     -- | Located Haskell String Literal
    187 205 
     type LStringLit p = XRec p (StringLiteral p)
    188 206
    ... ... @@ -193,3 +211,8 @@ data StringLiteral pass = StringLiteral
    193 211 
       , sl_fs  :: HText -- literal string value
    194 212 
       }
    195 213 
       | XStringLit !(XXStringLit pass)
    214 
    +
    215 
    +-- The 'Show' instance is required the 'parsed' test case of GHC's test-suite.
    216 
    +instance (Show (XStringLit pass), Show (XXStringLit pass)) => Show (StringLiteral pass) where
    217 
    +  show (StringLiteral srcTxt litFS) = unwords [ show srcTxt, show litFS ]
    218 
    +  show (XStringLit x) = show x

  • compiler/Language/Haskell/Syntax/Specificity.hs
    ... ... @@ -14,6 +14,7 @@ module Language.Haskell.Syntax.Specificity (
    14 14
    15 15 
     import Prelude
    16 16
    17 
    +import Control.DeepSeq (NFData(..))
    17 18 
     import Data.Data
    18 19
    19 20 
     -- | ForAllTyFlag
    ... ... @@ -27,6 +28,10 @@ data ForAllTyFlag = Invisible !Specificity
    27 28 
       deriving (Eq, Ord, Data)
    28 29 
       -- (<) on ForAllTyFlag means "is less visible than"
    29 30
    31 
    +instance NFData ForAllTyFlag where
    32 
    +  rnf (Invisible spec) = rnf spec
    33 
    +  rnf Required = ()
    34 
    +
    30 35 
     -- | Whether an 'Invisible' argument may appear in source Haskell.
    31 36 
     data Specificity = InferredSpec
    32 37 
                        -- ^ the argument may not appear in source Haskell, it is
    ... ... @@ -36,6 +41,10 @@ data Specificity = InferredSpec
    36 41 
                        -- required.
    37 42 
       deriving (Eq, Ord, Data)
    38 43
    44 
    +instance NFData Specificity where
    45 
    +  rnf SpecifiedSpec = ()
    46 
    +  rnf InferredSpec = ()
    47 
    +
    39 48 
     pattern Inferred, Specified :: ForAllTyFlag
    40 49 
     pattern Inferred  = Invisible InferredSpec
    41 50 
     pattern Specified = Invisible SpecifiedSpec

  • compiler/ghc.cabal.in
    ... ... @@ -566,7 +566,6 @@ Library
    566 566 
             GHC.Hs.Instances
    567 567 
             GHC.Hs.Lit
    568 568 
             GHC.Hs.Pat
    569 
    -        GHC.Hs.Specificity
    570 569 
             GHC.Hs.Stats
    571 570 
             GHC.HsToCore
    572 571 
             GHC.HsToCore.Arrows

  • testsuite/tests/count-deps/CountDepsParser.stdout
    ... ... @@ -113,7 +113,6 @@ GHC.Hs.ImpExp
    113 113 
     GHC.Hs.Instances
    114 114 
     GHC.Hs.Lit
    115 115 
     GHC.Hs.Pat
    116 
    -GHC.Hs.Specificity
    117 116 
     GHC.Hs.Type
    118 117 
     GHC.Hs.Utils
    119 118 
     GHC.HsToCore.Errors.Types

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