summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Hs.hs2
-rw-r--r--compiler/GHC/Hs/Decls.hs3
-rw-r--r--compiler/GHC/Hs/Extension.hs4
-rw-r--r--compiler/GHC/Parser.y17
-rw-r--r--compiler/GHC/Parser/PostProcess.hs5
-rw-r--r--compiler/GHC/Parser/PostProcess/Haddock.hs16
-rw-r--r--compiler/GHC/Rename/Module.hs11
-rw-r--r--compiler/GHC/ThToHs.hs2
-rw-r--r--compiler/GHC/Types/SrcLoc.hs40
9 files changed, 43 insertions, 57 deletions
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs
index fcea4fc332..c327ff1fd4 100644
--- a/compiler/GHC/Hs.hs
+++ b/compiler/GHC/Hs.hs
@@ -68,7 +68,7 @@ import Data.Data hiding ( Fixity )
data XModulePs
= XModulePs {
hsmodAnn :: EpAnn AnnsModule,
- hsmodLayout :: LayoutInfo,
+ hsmodLayout :: LayoutInfo GhcPs,
-- ^ Layout info for the module.
-- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.
hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)),
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index e1e368a76b..d296f2b0a6 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -353,7 +353,8 @@ data DataDeclRn = DataDeclRn
, tcdFVs :: NameSet }
deriving Data
-type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo]
+type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey)
+
-- TODO:AZ:tidy up AnnSortKey above
type instance XClassDecl GhcRn = NameSet -- FVs
type instance XClassDecl GhcTc = NameSet -- FVs
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 922288650f..8e73f60b85 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -11,6 +11,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc]
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module Language.Haskell.Syntax.Extension
@@ -27,6 +28,7 @@ import GHC.Prelude
import GHC.TypeLits (KnownSymbol, symbolVal)
import Data.Data hiding ( Fixity )
+import Language.Haskell.Syntax.Concrete
import Language.Haskell.Syntax.Extension
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -258,3 +260,5 @@ instance KnownSymbol tok => Outputable (HsToken tok) where
instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where
ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok))
ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok))
+
+deriving instance Typeable p => Data (LayoutInfo (GhcPass p))
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index fd1cd5d3ae..2a4f66f057 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -925,17 +925,17 @@ maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }
body :: { (AnnList
,([LImportDecl GhcPs], [LHsDecl GhcPs])
- ,LayoutInfo) }
+ ,LayoutInfo GhcPs) }
: '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)
- , snd $2, ExplicitBraces) }
+ , snd $2, explicitBraces $1 $3) }
| vocurly top close { (AnnList Nothing Nothing Nothing [] (fst $2)
, snd $2, VirtualBraces (getVOCURLY $1)) }
body2 :: { (AnnList
,([LImportDecl GhcPs], [LHsDecl GhcPs])
- ,LayoutInfo) }
+ ,LayoutInfo GhcPs) }
: '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)
- , snd $2, ExplicitBraces) }
+ , snd $2, explicitBraces $1 $3) }
| missing_module_keyword top close { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) }
@@ -1712,9 +1712,9 @@ decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
decllist_cls
:: { Located ([AddEpAnn]
, OrdList (LHsDecl GhcPs)
- , LayoutInfo) } -- Reversed
+ , LayoutInfo GhcPs) } -- Reversed
: '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
- ,snd $ unLoc $2, ExplicitBraces) }
+ ,snd $ unLoc $2, explicitBraces $1 $3) }
| vocurly decls_cls close { let { L l (anns, decls) = $2 }
in L l (anns, decls, VirtualBraces (getVOCURLY $1)) }
@@ -1722,7 +1722,7 @@ decllist_cls
--
where_cls :: { Located ([AddEpAnn]
,(OrdList (LHsDecl GhcPs)) -- Reversed
- ,LayoutInfo) }
+ ,LayoutInfo GhcPs) }
-- No implicit parameters
-- May have type declarations
: 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)
@@ -4409,6 +4409,9 @@ hsUniTok t@(L l _) =
L (mkTokenLocation l)
(if isUnicode t then HsUnicodeTok else HsNormalTok)
+explicitBraces :: Located Token -> Located Token -> LayoutInfo GhcPs
+explicitBraces t1 t2 = ExplicitBraces (hsTok t1) (hsTok t2)
+
-- -------------------------------------
addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 99e8fd10c8..02a4723f6f 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -193,7 +193,7 @@ mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
- -> LayoutInfo
+ -> LayoutInfo GhcPs
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
@@ -204,7 +204,8 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn
; tyvars <- checkTyVars (text "class") whereDots cls tparams
; cs <- getCommentsFor (locA loc) -- Get any remaining comments
; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs
- ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo)
+ ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey)
+ , tcdLayout = layoutInfo
, tcdCtxt = mcxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 2675921b04..706423c099 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -340,7 +340,7 @@ In this case, we should produce four HsDecl items (pseudo-code):
The inputs to addHaddockInterleaveItems are:
- * layout_info :: LayoutInfo
+ * layout_info :: LayoutInfo GhcPs
In the example above, note that the indentation level inside the module is
2 spaces. It would be represented as layout_info = VirtualBraces 2.
@@ -372,7 +372,7 @@ The inputs to addHaddockInterleaveItems are:
addHaddockInterleaveItems
:: forall a.
HasHaddock a
- => LayoutInfo
+ => LayoutInfo GhcPs
-> (PsLocated HdkComment -> Maybe a) -- Get a documentation item
-> [a] -- Unprocessed (non-documentation) items
-> HdkA [a] -- Documentation items & processed non-documentation items
@@ -389,7 +389,7 @@ addHaddockInterleaveItems layout_info get_doc_item = go
with_layout_info :: HdkA a -> HdkA a
with_layout_info = case layout_info of
NoLayoutInfo -> id
- ExplicitBraces -> id
+ ExplicitBraces{} -> id
VirtualBraces n ->
let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }
in hoistHdkA (inLocRange loc_range)
@@ -498,7 +498,7 @@ instance HasHaddock (HsDecl GhcPs) where
-- -- ^ Comment on the second method
--
addHaddock (TyClD _ decl)
- | ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout),
+ | ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout,
tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,
tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl
= do
@@ -509,7 +509,7 @@ instance HasHaddock (HsDecl GhcPs) where
flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])
pure $
let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls'
- decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout)
+ decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout
, tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs
, tcdSigs = tcdSigs'
, tcdMeths = tcdMeths'
@@ -1309,10 +1309,10 @@ reportExtraDocs =
* *
********************************************************************* -}
-mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)
+mkDocHsDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)
mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a
-mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)
+mkDocDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)
mkDocDecl layout_info (L l_comment hdk_comment)
| indent_mismatch = Nothing
| otherwise =
@@ -1346,7 +1346,7 @@ mkDocDecl layout_info (L l_comment hdk_comment)
-- -- ^ indent mismatch
indent_mismatch = case layout_info of
NoLayoutInfo -> False
- ExplicitBraces -> False
+ ExplicitBraces{} -> False
VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment)
mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs)
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 6748d60a56..17124a9000 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1839,7 +1839,8 @@ rnTyClDecl (DataDecl
, tcdDataDefn = defn'
, tcdDExt = rn_info }, fvs) } }
-rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
+rnTyClDecl (ClassDecl { tcdLayout = layout,
+ tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFixity = fixity,
tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
@@ -1893,7 +1894,8 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
; docs' <- traverse rnLDocDecl docs
- ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
+ ; return (ClassDecl { tcdLayout = rnLayoutInfo layout,
+ tcdCtxt = context', tcdLName = lcls',
tcdTyVars = tyvars', tcdFixity = fixity,
tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
@@ -1902,6 +1904,11 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
where
cls_doc = ClassDeclCtx lcls
+rnLayoutInfo :: LayoutInfo GhcPs -> LayoutInfo GhcRn
+rnLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb
+rnLayoutInfo (VirtualBraces n) = VirtualBraces n
+rnLayoutInfo NoLayoutInfo = NoLayoutInfo
+
-- Does the data type declaration include a CUSK?
data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool
data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 47e8b5758c..02ecec08fb 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -328,7 +328,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
<+> text "are not allowed:")
$$ (Outputable.ppr adts'))
; returnJustLA $ TyClD noExtField $
- ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)
+ ClassDecl { tcdCExt = (noAnn, NoAnnSortKey), tcdLayout = NoLayoutInfo
, tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs
index 1f6d285b38..b0a6568220 100644
--- a/compiler/GHC/Types/SrcLoc.hs
+++ b/compiler/GHC/Types/SrcLoc.hs
@@ -16,6 +16,7 @@ module GHC.Types.SrcLoc (
-- ** Constructing SrcLoc
mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
+ leftmostColumn,
noSrcLoc, -- "I'm sorry, I haven't a clue"
generatedSrcLoc, -- Code generated within the compiler
@@ -104,11 +105,6 @@ module GHC.Types.SrcLoc (
mkSrcSpanPs,
combineRealSrcSpans,
psLocatedToLocated,
-
- -- * Layout information
- LayoutInfo(..),
- leftmostColumn
-
) where
import GHC.Prelude
@@ -241,6 +237,10 @@ mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Strict.Nothing
mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col
+-- | Indentation level is 1-indexed, so the leftmost column is 1.
+leftmostColumn :: Int
+leftmostColumn = 1
+
getBufPos :: SrcLoc -> Strict.Maybe BufPos
getBufPos (RealSrcLoc _ mbpos) = mbpos
getBufPos (UnhelpfulLoc _) = Strict.Nothing
@@ -886,33 +886,3 @@ psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)
mkSrcSpanPs :: PsSpan -> SrcSpan
mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)
-
--- | Layout information for declarations.
-data LayoutInfo =
-
- -- | Explicit braces written by the user.
- --
- -- @
- -- class C a where { foo :: a; bar :: a }
- -- @
- ExplicitBraces
- |
- -- | Virtual braces inserted by the layout algorithm.
- --
- -- @
- -- class C a where
- -- foo :: a
- -- bar :: a
- -- @
- VirtualBraces
- !Int -- ^ Layout column (indentation level, begins at 1)
- |
- -- | Empty or compiler-generated blocks do not have layout information
- -- associated with them.
- NoLayoutInfo
-
- deriving (Eq, Ord, Show, Data)
-
--- | Indentation level is 1-indexed, so the leftmost column is 1.
-leftmostColumn :: Int
-leftmostColumn = 1
View Lorry Controller Status