{-# OPTIONS_HADDOCK hide #-}
module Language.Haskell.Exts.ParseSyntax where

import Language.Haskell.Exts.Annotated.Syntax hiding ( Type(..), Asst(..), Exp(..), FieldUpdate(..), XAttr(..), Context(..) )
import qualified Language.Haskell.Exts.Annotated.Syntax as S ( Type(..), Asst(..), Exp(..), FieldUpdate(..), XAttr(..), Context(..) )

---------------------------------------
-- Expressions as we parse them (and patters, and regular patterns)

data PExp l
    = Var l (QName l)                       -- ^ variable
    | IPVar l (IPName l)                    -- ^ implicit parameter variable
    | Con l (QName l)                       -- ^ data constructor
    | Lit l (Literal l)                     -- ^ literal constant
    | InfixApp l (PExp l) (QOp l) (PExp l)  -- ^ infix application
    | App l (PExp l) (PExp l)               -- ^ ordinary application
    | NegApp l (PExp l)                     -- ^ negation expression @-@ /exp/
    | Lambda l [Pat l] (PExp l)             -- ^ lambda expression
    | Let l (Binds l) (PExp l)              -- ^ local declarations with @let@
    | If l (PExp l) (PExp l) (PExp l)       -- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/
    | Case l (PExp l) [Alt l]               -- ^ @case@ /exp/ @of@ /alts/
    | Do l [Stmt l]                         -- ^ @do@-expression:
                                            --   the last statement in the list
                                            --   should be an expression.
    | MDo l [Stmt l]                        -- ^ @mdo@-expression
--    | Tuple [PExp]                        -- ^ tuple expression
    | TupleSection l [Maybe (PExp l)]       -- ^ tuple section expression, e.g. @(,,3)@
    | List l [PExp l]                       -- ^ list expression
    | Paren l (PExp l)                      -- ^ parenthesized expression
--     RightSection QOp PExp                -- ^ right section @(@/qop/ /exp/@)@
    | RecConstr l (QName l) [PFieldUpdate l]
                                            -- ^ record construction expression
    | RecUpdate l (PExp l) [PFieldUpdate l]
                                            -- ^ record update expression
    | EnumFrom l (PExp l)                   -- ^ unbounded arithmetic sequence,
                                            --   incrementing by 1
    | EnumFromTo l (PExp l) (PExp l)        -- ^ bounded arithmetic sequence,
                                            --   incrementing by 1
    | EnumFromThen l (PExp l) (PExp l)      -- ^ unbounded arithmetic sequence,
                                            --   with first two elements given
    | EnumFromThenTo l (PExp l) (PExp l) (PExp l)
                                            -- ^ bounded arithmetic sequence,
                                            --   with first two elements given
    | ParComp l (PExp l) [[QualStmt l]]     -- ^ parallel list comprehension
    | ExpTypeSig l (PExp l) (S.Type l)      -- ^ expression type signature
    | AsPat l (Name l) (PExp l)             -- ^ patterns only
    | WildCard l                            -- ^ patterns only
    | IrrPat l (PExp l)                     -- ^ patterns only

-- Post-ops for parsing left sections and regular patterns. Not to be left in the final tree.
    | PostOp l (PExp l) (QOp l)             -- ^ post-ops
    | PreOp l (QOp l) (PExp l)              -- ^ pre-ops

-- View patterns
    | ViewPat l (PExp l) (PExp l)           -- ^ patterns only

-- HaRP
    | SeqRP l [PExp l]                      -- ^ regular patterns only
    | GuardRP l (PExp l) [Stmt l]           -- ^ regular patterns only
    | EitherRP l (PExp l) (PExp l)          -- ^ regular patterns only
    | CAsRP l (Name l) (PExp l)             -- ^ regular patterns only

-- Template Haskell
    | VarQuote l (QName l)                  -- ^ 'x
    | TypQuote l (QName l)                  -- ^ ''T
    | BracketExp l (Bracket l)
    | SpliceExp l (Splice l)
    | QuasiQuote l String String            -- ^ [$...|...]

-- Hsx
    | XTag  l (XName l) [ParseXAttr l] (Maybe (PExp l)) [PExp l]
                                            -- ^ <Name>...</Name>
    | XETag l (XName l) [ParseXAttr l] (Maybe (PExp l))
                                            -- ^ <Name />
    | XPcdata l String                      -- ^ PCDATA
    | XExpTag l (PExp l)                    -- ^ <% ... %>
    | XRPats l [PExp l]                     -- ^ <[ ... ]>

-- Pragmas
    | CorePragma l      String  (PExp l)    -- ^ {-# CORE #-} pragma
    | SCCPragma  l      String  (PExp l)    -- ^ {-# SCC #-} pragma
    | GenPragma  l      String (Int, Int) (Int, Int) (PExp l)
                                            -- ^ {-# GENERATED ... #-} pragma

-- Generics
    | ExplTypeArg l (QName l) (S.Type l)    -- ^ f {| Int |} x = ...

-- Bang Patterns
    | BangPat l (PExp l)                    -- ^ f !a = ...

-- Arrows
    | Proc l (Pat l) (PExp l)               -- ^ proc p -> do
    | LeftArrApp      l (PExp l) (PExp l)   -- ^ e -< e
    | RightArrApp     l (PExp l) (PExp l)   -- ^ e >- e
    | LeftArrHighApp  l (PExp l) (PExp l)   -- ^ e -<< e
    | RightArrHighApp l (PExp l) (PExp l)   -- ^ e >>- e
   deriving (Eq,Show)

data PFieldUpdate l
    = FieldUpdate l (QName l) (PExp l)
    | FieldPun l (Name l)
    | FieldWildcard l
  deriving (Eq,Show)

data ParseXAttr l = XAttr l (XName l) (PExp l)
  deriving (Eq,Show)

instance Annotated PExp where
    ann e = case e of
        Var l qn        -> l
        IPVar l ipn     -> l
        Con l qn        -> l
        Lit l lit       -> l
        InfixApp l e1 qop e2    -> l
        App l e1 e2     -> l
        NegApp l e      -> l
        Lambda l ps e   -> l
        Let l bs e      -> l
        If l ec et ee   -> l
        Case l e alts   -> l
        Do l ss         -> l
        MDo l ss        -> l
        TupleSection l mes  -> l
        List l es       -> l
        Paren l e       -> l
        RecConstr l qn fups     -> l
        RecUpdate l e  fups     -> l
        EnumFrom l e            -> l
        EnumFromTo l ef et      -> l
        EnumFromThen l ef et    -> l
        EnumFromThenTo l ef eth eto -> l
        ParComp  l e qsss       -> l
        ExpTypeSig l e t        -> l
        AsPat l n e             -> l
        WildCard l              -> l
        IrrPat l e              -> l
        PostOp l e op           -> l
        PreOp l op e            -> l
        ViewPat l e1 e2         -> l
        SeqRP l es              -> l
        GuardRP l e ss          -> l
        EitherRP l e1 e2        -> l
        CAsRP l n e             -> l

        VarQuote l qn           -> l
        TypQuote l qn           -> l
        BracketExp l br         -> l
        SpliceExp l sp          -> l
        QuasiQuote l sn se      -> l

        XTag  l xn xas me es    -> l
        XETag l xn xas me       -> l
        XPcdata l s             -> l
        XExpTag l e             -> l
        XRPats l es             -> l

        CorePragma l s e   -> l
        SCCPragma  l s e   -> l
        GenPragma  l s n12 n34 e -> l

        ExplTypeArg l qn t      -> l
        BangPat l e             -> l

        Proc            l p e   -> l
        LeftArrApp      l e1 e2 -> l
        RightArrApp     l e1 e2 -> l
        LeftArrHighApp  l e1 e2 -> l
        RightArrHighApp l e1 e2 -> l

    amap f e = case e of
        Var l qn                -> Var   (f l) qn
        IPVar l ipn             -> IPVar (f l) ipn
        Con l qn                -> Con   (f l) qn
        Lit l lit               -> Lit   (f l) lit
        InfixApp l e1 qop e2    -> InfixApp (f l) e1 qop e2
        App l e1 e2             -> App (f l) e1 e2
        NegApp l e              -> NegApp (f l) e
        Lambda l ps e           -> Lambda (f l) ps e
        Let l bs e              -> Let (f l) bs e
        If l ec et ee           -> If (f l) ec et ee
        Case l e alts           -> Case (f l) e alts
        Do l ss                 -> Do (f l) ss
        MDo l ss                -> MDo (f l) ss
        TupleSection l mes      -> TupleSection (f l) mes
        List l es               -> List (f l) es
        Paren l e               -> Paren (f l) e
        RecConstr l qn fups     -> RecConstr (f l) qn fups
        RecUpdate l e  fups     -> RecUpdate (f l) e  fups
        EnumFrom l e            -> EnumFrom (f l) e
        EnumFromTo l ef et      -> EnumFromTo (f l) ef et
        EnumFromThen l ef et    -> EnumFromThen (f l) ef et
        EnumFromThenTo l ef eth eto -> EnumFromThenTo (f l) ef eth eto
        ParComp  l e qsss       -> ParComp  (f l) e qsss
        ExpTypeSig l e t        -> ExpTypeSig (f l) e t

        AsPat l n e             -> AsPat (f l) n e
        WildCard l              -> WildCard (f l)
        IrrPat l e              -> IrrPat (f l) e
        PostOp l e op           -> PostOp (f l) e op
        PreOp l op e            -> PreOp (f l) op e
        ViewPat l e1 e2         -> ViewPat (f l) e1 e2
        SeqRP l es              -> SeqRP (f l) es
        GuardRP l e ss          -> GuardRP (f l) e ss
        EitherRP l e1 e2        -> EitherRP (f l) e1 e2
        CAsRP l n e             -> CAsRP (f l) n e
        ExplTypeArg l n t       -> ExplTypeArg (f l) n t
        BangPat l e             -> BangPat (f l) e

        VarQuote l qn           -> VarQuote (f l) qn
        TypQuote l qn           -> TypQuote (f l) qn
        BracketExp l br         -> BracketExp (f l) br
        SpliceExp l sp          -> SpliceExp (f l) sp
        QuasiQuote l sn se      -> QuasiQuote (f l) sn se

        XTag  l xn xas me es    -> XTag  (f l) xn xas me es
        XETag l xn xas me       -> XETag (f l) xn xas me
        XPcdata l s             -> XPcdata (f l) s
        XExpTag l e             -> XExpTag (f l) e

        CorePragma l s e        -> CorePragma (f l) s e
        SCCPragma  l s e        -> SCCPragma  (f l) s e
        GenPragma  l s n12 n34 e -> GenPragma  (f l) s n12 n34 e

        Proc            l p e   -> Proc            (f l) p e
        LeftArrApp      l e1 e2 -> LeftArrApp      (f l) e1 e2
        RightArrApp     l e1 e2 -> RightArrApp     (f l) e1 e2
        LeftArrHighApp  l e1 e2 -> LeftArrHighApp  (f l) e1 e2
        RightArrHighApp l e1 e2 -> RightArrHighApp (f l) e1 e2

instance Functor PExp where
      fmap f e = case e of
          Var l qn                -> Var   (f l) (fmap f qn)
          IPVar l ipn             -> IPVar (f l) (fmap f ipn)
          Con l qn                -> Con   (f l) (fmap f qn)
          Lit l lit               -> Lit   (f l) (fmap f lit)
          InfixApp l e1 qop e2    -> InfixApp (f l) (fmap f e1) (fmap f qop) (fmap f e2)
          App l e1 e2             -> App (f l) (fmap f e1) (fmap f e2)
          NegApp l e              -> NegApp (f l) (fmap f e)
          Lambda l ps e           -> Lambda (f l) (map (fmap f) ps) (fmap f e)
          Let l bs e              -> Let (f l) (fmap f bs) (fmap f e)
          If l ec et ee           -> If (f l) (fmap f ec) (fmap f et) (fmap f ee)
          Case l e alts           -> Case (f l) (fmap f e) (map (fmap f) alts)
          Do l ss                 -> Do (f l) (map (fmap f) ss)
          MDo l ss                -> MDo (f l) (map (fmap f) ss)
          TupleSection l mes      -> TupleSection (f l) (map (fmap (fmap f)) mes)
          List l es               -> List (f l) (map (fmap f) es)
          Paren l e               -> Paren (f l) (fmap f e)
          RecConstr l qn fups     -> RecConstr (f l) (fmap f qn) (map (fmap f) fups)
          RecUpdate l e  fups     -> RecUpdate (f l) (fmap f e)  (map (fmap f) fups)
          EnumFrom l e            -> EnumFrom (f l) (fmap f e)
          EnumFromTo l ef et      -> EnumFromTo (f l) (fmap f ef) (fmap f et)
          EnumFromThen l ef et    -> EnumFromThen (f l) (fmap f ef) (fmap f et)
          EnumFromThenTo l ef eth eto -> EnumFromThenTo (f l) (fmap f ef) (fmap f eth) (fmap f eto)
          ParComp  l e qsss       -> ParComp  (f l) (fmap f e) (map (map (fmap f)) qsss)
          ExpTypeSig l e t        -> ExpTypeSig (f l) (fmap f e) (fmap f t)

          AsPat l n e             -> AsPat (f l) (fmap f n) (fmap f e)
          WildCard l              -> WildCard (f l)
          IrrPat l e              -> IrrPat (f l) (fmap f e)
          PostOp l e op           -> PostOp (f l) (fmap f e) (fmap f op)
          PreOp l op e            -> PreOp (f l) (fmap f op) (fmap f e)
          ViewPat l e1 e2         -> ViewPat (f l) (fmap f e1) (fmap f e2)
          SeqRP l es              -> SeqRP (f l) (map (fmap f) es)
          GuardRP l e ss          -> GuardRP (f l) (fmap f e) (map (fmap f) ss)
          EitherRP l e1 e2        -> EitherRP (f l) (fmap f e1) (fmap f e2)
          CAsRP l n e             -> CAsRP (f l) (fmap f n) (fmap f e)
          ExplTypeArg l n t       -> ExplTypeArg (f l) (fmap f n) (fmap f t)
          BangPat l e             -> BangPat (f l) (fmap f e)

          VarQuote l qn           -> VarQuote (f l) (fmap f qn)
          TypQuote l qn           -> TypQuote (f l) (fmap f qn)
          BracketExp l br         -> BracketExp (f l) (fmap f br)
          SpliceExp l sp          -> SpliceExp (f l) (fmap f sp)
          QuasiQuote l sn se      -> QuasiQuote (f l) sn se

          XTag  l xn xas me es    -> XTag  (f l) (fmap f xn) (map (fmap f) xas) (fmap (fmap f) me) (map (fmap f) es)
          XETag l xn xas me       -> XETag (f l) (fmap f xn) (map (fmap f) xas) (fmap (fmap f) me)
          XPcdata l s             -> XPcdata (f l) s
          XExpTag l e             -> XExpTag (f l) (fmap f e)

          CorePragma l s e        -> CorePragma (f l) s (fmap f e)
          SCCPragma  l s e        -> SCCPragma  (f l) s (fmap f e)
          GenPragma  l s n12 n34 e -> GenPragma  (f l) s n12 n34 (fmap f e)

          Proc            l p e   -> Proc            (f l) (fmap f p) (fmap f e)
          LeftArrApp      l e1 e2 -> LeftArrApp      (f l) (fmap f e1) (fmap f e2)
          RightArrApp     l e1 e2 -> RightArrApp     (f l) (fmap f e1) (fmap f e2)
          LeftArrHighApp  l e1 e2 -> LeftArrHighApp  (f l) (fmap f e1) (fmap f e2)
          RightArrHighApp l e1 e2 -> RightArrHighApp (f l) (fmap f e1) (fmap f e2)



instance Functor PFieldUpdate where
    fmap f (FieldUpdate l qn e) = FieldUpdate (f l) (fmap f qn) (fmap f e)
    fmap f (FieldPun l n)       = FieldPun (f l) (fmap f n)
    fmap f (FieldWildcard l)    = FieldWildcard (f l)

instance Annotated PFieldUpdate where
    ann (FieldUpdate l qn e) = l
    ann (FieldPun l n)       = l
    ann (FieldWildcard l)    = l
    amap f (FieldUpdate l qn e) = FieldUpdate (f l) qn e
    amap f (FieldPun l n)       = FieldPun (f l) n
    amap f (FieldWildcard l)    = FieldWildcard (f l)

instance Functor ParseXAttr where
    fmap f (XAttr l xn e) = XAttr (f l) (fmap f xn) (fmap f e)

instance Annotated ParseXAttr where
    ann (XAttr l _ _) = l
    amap f (XAttr l xn e) = XAttr (f l) xn e

p_unit_con :: l -> PExp l
p_unit_con l         = Con l (unit_con_name l)

p_tuple_con :: l -> Boxed -> Int -> PExp l
p_tuple_con l b i       = Con l (tuple_con_name l b i)

p_unboxed_singleton_con :: l -> PExp l
p_unboxed_singleton_con l = Con l (unboxed_singleton_con_name l)

data PContext l
    = CxSingle l (PAsst l)
    | CxTuple  l [PAsst l]
    | CxParen  l (PContext l)
    | CxEmpty  l
 deriving (Eq, Show)

instance Functor PContext where
  fmap f (CxSingle l asst) = CxSingle (f l) (fmap f asst)
  fmap f (CxTuple l assts) = CxTuple (f l) (map (fmap f) assts)
  fmap f (CxParen l ctxt)  = CxParen (f l) (fmap f ctxt)
  fmap f (CxEmpty l)       = CxEmpty (f l)

instance Annotated PContext where
  ann (CxSingle l asst ) = l
  ann (CxTuple  l assts) = l
  ann (CxParen  l ctxt ) = l
  ann (CxEmpty  l)       = l
  amap f (CxSingle l asst ) = CxSingle (f l) asst
  amap f (CxTuple  l assts) = CxTuple  (f l) assts
  amap f (CxParen  l ctxt ) = CxParen  (f l) ctxt
  amap f (CxEmpty l) = CxEmpty (f l)

data PType l
     = TyForall l
        (Maybe [TyVarBind l])
        (Maybe (PContext l))
        (PType l)
     | TyFun   l (PType l) (PType l)            -- ^ function type
     | TyTuple l Boxed     [PType l]            -- ^ tuple type, possibly boxed
     | TyList  l (PType l)                      -- ^ list syntax, e.g. [a], as opposed to [] a
     | TyApp   l (PType l) (PType l)            -- ^ application of a type constructor
     | TyVar   l (Name l)                       -- ^ type variable
     | TyCon   l (QName l)                      -- ^ named type or type constructor
     | TyParen l (PType l)                      -- ^ type surrounded by parentheses
     | TyPred  l (PAsst l)                      -- ^ assertion of an implicit parameter
     | TyInfix l (PType l) (QName l) (PType l)  -- ^ infix type constructor
     | TyKind  l (PType l) (Kind l)             -- ^ type with explicit kind signature
  deriving (Eq, Show)

instance Functor PType where
    fmap f t = case t of
      TyForall l mtvs mcx t         -> TyForall (f l) (fmap (map (fmap f)) mtvs) (fmap (fmap f) mcx) (fmap f t)
      TyFun   l t1 t2               -> TyFun (f l) (fmap f t1) (fmap f t2)
      TyTuple l b ts                -> TyTuple (f l) b (map (fmap f) ts)
      TyList  l t                   -> TyList (f l) (fmap f t)
      TyApp   l t1 t2               -> TyApp (f l) (fmap f t1) (fmap f t2)
      TyVar   l n                   -> TyVar (f l) (fmap f n)
      TyCon   l qn                  -> TyCon (f l) (fmap f qn)
      TyParen l t                   -> TyParen (f l) (fmap f t)
      TyPred  l asst                -> TyPred (f l) (fmap f asst)
      TyInfix l ta qn tb            -> TyInfix (f l) (fmap f ta) (fmap f qn) (fmap f tb)
      TyKind  l t k                 -> TyKind (f l) (fmap f t) (fmap f k)

instance Annotated PType where
    ann t = case t of
      TyForall l mtvs cx t          -> l
      TyFun   l t1 t2               -> l
      TyTuple l b ts                -> l
      TyList  l t                   -> l
      TyApp   l t1 t2               -> l
      TyVar   l n                   -> l
      TyCon   l qn                  -> l
      TyParen l t                   -> l
      TyInfix l ta qn tb            -> l
      TyKind  l t k                 -> l
    amap f t = case t of
      TyForall l mtvs mcx t         -> TyForall (f l) mtvs mcx t
      TyFun   l t1 t2               -> TyFun (f l) t1 t2
      TyTuple l b ts                -> TyTuple (f l) b ts
      TyList  l t                   -> TyList (f l) t
      TyApp   l t1 t2               -> TyApp (f l) t1 t2
      TyVar   l n                   -> TyVar (f l) n
      TyCon   l qn                  -> TyCon (f l) qn
      TyParen l t                   -> TyParen (f l) t
      TyInfix l ta qn tb            -> TyInfix (f l) ta qn tb
      TyKind  l t k                 -> TyKind (f l) t k

data PAsst l
    = ClassA l (QName l) [PType l]
    | InfixA l (PType l) (QName l) (PType l)
    | IParam l (IPName l) (PType l)
    | EqualP l (PType l)  (PType l)
  deriving (Eq, Show)

instance Functor PAsst where
    fmap f asst = case asst of
        ClassA l qn ts      -> ClassA (f l) (fmap f qn) (map (fmap f) ts)
        InfixA l ta qn tb   -> InfixA (f l) (fmap f ta) (fmap f qn) (fmap f tb)
        IParam l ipn t      -> IParam (f l) (fmap f ipn) (fmap f t)
        EqualP l t1 t2      -> EqualP (f l) (fmap f t1) (fmap f t2)

instance Annotated PAsst where
    ann asst = case asst of
        ClassA l qn ts      -> l
        InfixA l ta qn tb   -> l
        IParam l ipn t      -> l
        EqualP l t1 t2      -> l
    amap f asst = case asst of
        ClassA l qn ts      -> ClassA (f l) qn ts
        InfixA l ta qn tb   -> InfixA (f l) ta qn tb
        IParam l ipn t      -> IParam (f l) ipn t
        EqualP l t1 t2      -> EqualP (f l) t1 t2


unit_tycon, fun_tycon, list_tycon, unboxed_singleton_tycon :: l -> PType l
unit_tycon              l = TyCon l (unit_tycon_name l)
fun_tycon               l = TyCon l (fun_tycon_name l)
list_tycon              l = TyCon l (list_tycon_name l)
unboxed_singleton_tycon l = TyCon l (unboxed_singleton_tycon_name l)

tuple_tycon :: l -> Boxed -> Int -> PType l
tuple_tycon l b i         = TyCon l (tuple_tycon_name l b i)