{-# 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) [EpToken "|"] [EpToken "|"]
  -- ^ Last two are the locations of the '|' before and after the payload
  | Tuple [Either (EpAnn Bool) (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 [EpToken "|"]
_ [EpToken "|"]
_ ->
      SDoc
parOpen SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall {doc}. IsLine doc => Int -> doc
ppr_bars (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LocatedA b -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA b
e SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall {doc}. IsLine doc => Int -> doc
ppr_bars (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
alt)
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
parClose
    Tuple [Either (EpAnn Bool) (LocatedA b)]
xs ->
      SDoc
parOpen SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ([SDoc] -> SDoc
fcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Either (EpAnn Bool) (LocatedA b) -> SDoc)
-> [Either (EpAnn Bool) (LocatedA b)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Either (EpAnn Bool) (LocatedA b) -> SDoc
forall {a} {a}. Outputable a => Either a a -> SDoc
ppr_tup [Either (EpAnn Bool) (LocatedA b)]
xs)
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
parClose
  where
    ppr_tup :: Either a a -> SDoc
ppr_tup (Left a
_)  = SDoc
forall doc. IsOutput doc => doc
empty
    ppr_tup (Right a
e) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
e

    ppr_bars :: Int -> doc
ppr_bars Int
n = [doc] -> doc
forall doc. IsLine doc => [doc] -> doc
hsep (Int -> doc -> [doc]
forall a. Int -> a -> [a]
replicate Int
n (Char -> doc
forall doc. IsLine doc => Char -> doc
Outputable.char Char
'|'))
    (SDoc
parOpen, SDoc
parClose) =
      case Boxity
boxity of
        Boxity
Boxed -> (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(", String -> SDoc
forall doc. IsLine doc => String -> doc
text String
")")
        Boxity
Unboxed -> (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(#", String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#)")


-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]
data PatBuilder p
  = PatBuilderPat (Pat p)
  | PatBuilderPar (EpToken "(") (LocatedA (PatBuilder p)) (EpToken ")")
  | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
  | PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs)
  | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)
                    (LocatedA (PatBuilder p)) ([EpToken "("], [EpToken ")"])
  | PatBuilderVar (LocatedN RdrName)
  | PatBuilderOverLit (HsOverLit GhcPs)

-- These instances are here so that they are not orphans
type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs)))             = EpAnnCO
type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW
type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs)))            = SrcSpanAnnA
type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))     = SrcSpanAnnA

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 EpToken "("
_ (L SrcSpanAnnA
_ PatBuilder GhcPs
p) EpToken ")"
_) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<+> PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p2
  ppr (PatBuilderAppType (L SrcSpanAnnA
_ PatBuilder GhcPs
p) EpToken "@"
_ HsTyPat GhcPs
t) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"@" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HsTyPat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsTyPat GhcPs
t
  ppr (PatBuilderOpApp (L SrcSpanAnnA
_ PatBuilder GhcPs
p1) LocatedN RdrName
op (L SrcSpanAnnA
_ PatBuilder GhcPs
p2) ([EpToken "("], [EpToken ")"])
_) = PatBuilder GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatBuilder GhcPs
p1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
op SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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

-- | An accumulator to build a prefix data constructor,
--   e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:
--
--  @
--  1. PrefixDataConBuilder []        MkT
--  2. PrefixDataConBuilder [A]       MkT
--  3. PrefixDataConBuilder [A, B]    MkT
--  4. PrefixDataConBuilder [A, B, C] MkT
--  @
--
--  There are two reasons we have a separate builder type instead of using
--  @HsConDeclDetails GhcPs@ directly:
--
--  1. It's faster, because 'OrdList' gives us constant-time snoc.
--  2. Having a separate type helps ensure that we don't forget to finalize a
--     'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').
--
--  See Note [PatBuilder] for another builder type used in the parser.
--  Here the technique is similar, but the motivation is different.
data DataConBuilder
  = PrefixDataConBuilder
      (OrdList (LHsType GhcPs))  -- Data constructor fields
      (LocatedN RdrName)         -- Data constructor name
  | InfixDataConBuilder
      (LHsType GhcPs)    -- LHS field
      (LocatedN RdrName) -- Data constructor name
      (LHsType GhcPs)    -- RHS field

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
forall doc. IsLine doc => [doc] -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<+> LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
data_con SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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)))] = SrcSpanAnnLW