{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
module GHC.Parser.Types
( SumOrTuple(..)
, pprSumOrTuple
, PatBuilder(..)
, DataConBuilder(..)
)
where
import GHC.Prelude
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Name.Reader
import GHC.Hs.Extension
import GHC.Hs.Lit
import GHC.Hs.Pat
import GHC.Hs.Type
import GHC.Utils.Outputable as Outputable
import GHC.Data.OrdList
import Data.Foldable
import GHC.Parser.Annotation
import Language.Haskell.Syntax
data SumOrTuple b
= Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation]
| Tuple [Either (EpAnn EpaLocation) (LocatedA b)]
pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple :: forall b. Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple Boxity
boxity = \case
Sum Int
alt Int
arity LocatedA b
e [EpaLocation]
_ [EpaLocation]
_ ->
SDoc
parOpen SDoc -> SDoc -> SDoc
<+> Int -> SDoc
ppr_bars (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SDoc -> SDoc -> SDoc
<+> LocatedA b -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA b
e SDoc -> SDoc -> SDoc
<+> Int -> SDoc
ppr_bars (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
alt)
SDoc -> SDoc -> SDoc
<+> SDoc
parClose
Tuple [Either (EpAnn EpaLocation) (LocatedA b)]
xs ->
SDoc
parOpen SDoc -> SDoc -> SDoc
<> ([SDoc] -> SDoc
fcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Either (EpAnn EpaLocation) (LocatedA b) -> SDoc)
-> [Either (EpAnn EpaLocation) (LocatedA b)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Either (EpAnn EpaLocation) (LocatedA b) -> SDoc
forall {a} {a}. Outputable a => Either a a -> SDoc
ppr_tup [Either (EpAnn EpaLocation) (LocatedA b)]
xs)
SDoc -> SDoc -> SDoc
<> SDoc
parClose
where
ppr_tup :: Either a a -> SDoc
ppr_tup (Left a
_) = SDoc
empty
ppr_tup (Right a
e) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
e
ppr_bars :: Int -> SDoc
ppr_bars Int
n = [SDoc] -> SDoc
hsep (Int -> SDoc -> [SDoc]
forall a. Int -> a -> [a]
replicate Int
n (Char -> SDoc
Outputable.char Char
'|'))
(SDoc
parOpen, SDoc
parClose) =
case Boxity
boxity of
Boxity
Boxed -> (String -> SDoc
text String
"(", String -> SDoc
text String
")")
Boxity
Unboxed -> (String -> SDoc
text String
"(#", String -> SDoc
text String
"#)")
data PatBuilder p
= PatBuilderPat (Pat p)
| PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p)
| PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
| PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs)
| PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)
(LocatedA (PatBuilder p)) (EpAnn [AddEpAnn])
| PatBuilderVar (LocatedN RdrName)
| PatBuilderOverLit (HsOverLit GhcPs)
instance Outputable (PatBuilder GhcPs) where
ppr :: PatBuilder GhcPs -> SDoc
ppr (PatBuilderPat Pat GhcPs
p) = Pat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcPs
p
ppr (PatBuilderPar LHsToken "(" GhcPs
_ (L SrcSpanAnnA
_ PatBuilder GhcPs
p) LHsToken ")" GhcPs
_) = SDoc -> SDoc
parens (PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p)
ppr (PatBuilderApp (L SrcSpanAnnA
_ PatBuilder GhcPs
p1) (L SrcSpanAnnA
_ PatBuilder GhcPs
p2)) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p1 SDoc -> SDoc -> SDoc
<+> PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p2
ppr (PatBuilderAppType (L SrcSpanAnnA
_ PatBuilder GhcPs
p) HsPatSigType GhcPs
t) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> HsPatSigType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPatSigType GhcPs
t
ppr (PatBuilderOpApp (L SrcSpanAnnA
_ PatBuilder GhcPs
p1) LocatedN RdrName
op (L SrcSpanAnnA
_ PatBuilder GhcPs
p2) EpAnn [AddEpAnn]
_) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p1 SDoc -> SDoc -> SDoc
<+> LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
op SDoc -> SDoc -> SDoc
<+> PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p2
ppr (PatBuilderVar LocatedN RdrName
v) = LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
v
ppr (PatBuilderOverLit HsOverLit GhcPs
l) = HsOverLit GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcPs
l
data DataConBuilder
= PrefixDataConBuilder
(OrdList (LHsType GhcPs))
(LocatedN RdrName)
| InfixDataConBuilder
(LHsType GhcPs)
(LocatedN RdrName)
(LHsType GhcPs)
instance Outputable DataConBuilder where
ppr :: DataConBuilder -> SDoc
ppr (PrefixDataConBuilder OrdList (LHsType GhcPs)
flds LocatedN RdrName
data_con) =
SDoc -> Int -> SDoc -> SDoc
hang (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
data_con) Int
2 ([SDoc] -> SDoc
sep ((GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdList (LHsType GhcPs)
OrdList (GenLocated SrcSpanAnnA (HsType GhcPs))
flds)))
ppr (InfixDataConBuilder LHsType GhcPs
lhs LocatedN RdrName
data_con LHsType GhcPs
rhs) =
GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
lhs SDoc -> SDoc -> SDoc
<+> LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
data_con SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs
type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL