    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Language.Haskell.ParseUtils
    -- Copyright   :  (c) The GHC Team, 1997-2000
    -- License     :  BSD-3-Clause
    --
    -- Maintainer  :  Andreas Abel
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- Utilities for the Haskell parser.
    --
    -----------------------------------------------------------------------------

    module Language.Haskell.ParseUtils (
              splitTyConApp         -- HsType -> P (HsName,[HsType])
            , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
            , checkPrec             -- Integer -> P Int
            , checkContext          -- HsType -> P HsContext
            , checkAssertion        -- HsType -> P HsAsst
            , checkDataHeader       -- HsQualType -> P (HsContext,HsName,[HsName])
            , checkClassHeader      -- HsQualType -> P (HsContext,HsName,[HsName])
            , checkInstHeader       -- HsQualType -> P (HsContext,HsQName,[HsType])
            , checkPattern          -- HsExp -> P HsPat
            , checkExpr             -- HsExp -> P HsExp
            , checkValDef           -- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
            , checkClassBody        -- [HsDecl] -> P [HsDecl]
            , checkUnQual           -- HsQName -> P HsName
            , checkRevDecls         -- [HsDecl] -> P [HsDecl]
     ) where

    import           Language.Haskell.ParseMonad
    import           Language.Haskell.Pretty
    import           Language.Haskell.Syntax

    splitTyConApp :: HsType -> P (HsName,[HsType])
    splitTyConApp :: HsType -> P (HsName, [HsType])
    splitTyConApp HsType
    t0 = HsType -> [HsType] -> P (HsName, [HsType])
    split HsType
    t0 []
     where
            split :: HsType -> [HsType] -> P (HsName,[HsType])
            split :: HsType -> [HsType] -> P (HsName, [HsType])
    split (HsTyApp HsType
    t HsType
    u) [HsType]
    ts = HsType -> [HsType] -> P (HsName, [HsType])
    split HsType
    t (HsType
    uHsType -> [HsType] -> [HsType]
    forall a. a -> [a] -> [a]
    :[HsType]
    ts)
            split (HsTyCon (UnQual HsName
    t)) [HsType]
    ts = (HsName, [HsType]) -> P (HsName, [HsType])
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsName
    t,[HsType]
    ts)
            split HsType
    _ [HsType]
    _ = String -> P (HsName, [HsType])
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Illegal data/newtype declaration"

    -----------------------------------------------------------------------------
    -- Various Syntactic Checks

    checkContext :: HsType -> P HsContext
    checkContext :: HsType -> P HsContext
    checkContext (HsTyTuple [HsType]
    ts) =
            (HsType -> P HsAsst) -> [HsType] -> P HsContext
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsType -> P HsAsst
    checkAssertion [HsType]
    ts
    checkContext HsType
    t = do
            c <- HsType -> P HsAsst
    checkAssertion HsType
    t
            return [c]

    -- Changed for multi-parameter type classes

    checkAssertion :: HsType -> P HsAsst
    checkAssertion :: HsType -> P HsAsst
    checkAssertion = [HsType] -> HsType -> P HsAsst
    forall {m :: * -> *}. MonadFail m => [HsType] -> HsType -> m HsAsst
    checkAssertion' []
            where   checkAssertion' :: [HsType] -> HsType -> m HsAsst
    checkAssertion' [HsType]
    ts (HsTyCon HsQName
    c) = HsAsst -> m HsAsst
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsQName
    c,[HsType]
    ts)
                    checkAssertion' [HsType]
    ts (HsTyApp HsType
    a HsType
    t) = [HsType] -> HsType -> m HsAsst
    checkAssertion' (HsType
    tHsType -> [HsType] -> [HsType]
    forall a. a -> [a] -> [a]
    :[HsType]
    ts) HsType
    a
                    checkAssertion' [HsType]
    _ HsType
    _ = String -> m HsAsst
    forall a. String -> m a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Illegal class assertion"

    checkDataHeader :: HsQualType -> P (HsContext,HsName,[HsName])
    checkDataHeader :: HsQualType -> P (HsContext, HsName, [HsName])
    checkDataHeader (HsQualType HsContext
    cs HsType
    t) = do
            (c,ts) <- String -> HsType -> [HsName] -> P (HsName, [HsName])
    checkSimple String
    "data/newtype" HsType
    t []
            return (cs,c,ts)

    checkClassHeader :: HsQualType -> P (HsContext,HsName,[HsName])
    checkClassHeader :: HsQualType -> P (HsContext, HsName, [HsName])
    checkClassHeader (HsQualType HsContext
    cs HsType
    t) = do
            (c,ts) <- String -> HsType -> [HsName] -> P (HsName, [HsName])
    checkSimple String
    "class" HsType
    t []
            return (cs,c,ts)

    checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName]))
    checkSimple :: String -> HsType -> [HsName] -> P (HsName, [HsName])
    checkSimple String
    kw (HsTyApp HsType
    l (HsTyVar HsName
    a)) [HsName]
    xs = String -> HsType -> [HsName] -> P (HsName, [HsName])
    checkSimple String
    kw HsType
    l (HsName
    aHsName -> [HsName] -> [HsName]
    forall a. a -> [a] -> [a]
    :[HsName]
    xs)
    checkSimple String
    _kw (HsTyCon (UnQual HsName
    t))   [HsName]
    xs = (HsName, [HsName]) -> P (HsName, [HsName])
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsName
    t,[HsName]
    xs)
    checkSimple String
    kw HsType
    _ [HsName]
    _ = String -> P (HsName, [HsName])
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Illegal " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    kw String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " declaration")

    checkInstHeader :: HsQualType -> P (HsContext,HsQName,[HsType])
    checkInstHeader :: HsQualType -> P (HsContext, HsQName, [HsType])
    checkInstHeader (HsQualType HsContext
    cs HsType
    t) = do
            (c,ts) <- HsType -> [HsType] -> P HsAsst
    checkInsts HsType
    t []
            return (cs,c,ts)

    checkInsts :: HsType -> [HsType] -> P ((HsQName,[HsType]))
    checkInsts :: HsType -> [HsType] -> P HsAsst
    checkInsts (HsTyApp HsType
    l HsType
    t) [HsType]
    ts = HsType -> [HsType] -> P HsAsst
    checkInsts HsType
    l (HsType
    tHsType -> [HsType] -> [HsType]
    forall a. a -> [a] -> [a]
    :[HsType]
    ts)
    checkInsts (HsTyCon HsQName
    c)   [HsType]
    ts = HsAsst -> P HsAsst
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsQName
    c,[HsType]
    ts)
    checkInsts HsType
    _ [HsType]
    _              = String -> P HsAsst
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Illegal instance declaration"

    -----------------------------------------------------------------------------
    -- Checking Patterns.

    -- We parse patterns as expressions and check for valid patterns below,
    -- converting the expression into a pattern at the same time.

    checkPattern :: HsExp -> P HsPat
    checkPattern :: HsExp -> P HsPat
    checkPattern HsExp
    e = HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    e []

    checkPat :: HsExp -> [HsPat] -> P HsPat
    checkPat :: HsExp -> [HsPat] -> P HsPat
    checkPat (HsCon HsQName
    c) [HsPat]
    args = HsPat -> P HsPat
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsQName -> [HsPat] -> HsPat
    HsPApp HsQName
    c [HsPat]
    args)
    checkPat (HsApp HsExp
    f HsExp
    x) [HsPat]
    args = do
            x' <- HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    x []
            checkPat f (x':args)
    checkPat HsExp
    e [] = case HsExp
    e of
            HsVar (UnQual HsName
    x)   -> HsPat -> P HsPat
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsName -> HsPat
    HsPVar HsName
    x)
            HsLit HsLiteral
    l            -> HsPat -> P HsPat
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsLiteral -> HsPat
    HsPLit HsLiteral
    l)
            HsInfixApp HsExp
    l HsQOp
    op HsExp
    r  -> do
                                  l' <- HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    l []
                                  r' <- checkPat r []
                                  case op of
                                     HsQConOp HsQName
    c -> HsPat -> P HsPat
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsPat -> HsQName -> HsPat -> HsPat
    HsPInfixApp HsPat
    l' HsQName
    c HsPat
    r')
                                     HsQOp
    _          -> P HsPat
    forall a. P a
    patFail
            HsTuple [HsExp]
    es         -> do
                                  ps <- (HsExp -> P HsPat) -> [HsExp] -> P [HsPat]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (\HsExp
    e' -> HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    e' []) [HsExp]
    es
                                  return (HsPTuple ps)
            HsList [HsExp]
    es          -> do
                                  ps <- (HsExp -> P HsPat) -> [HsExp] -> P [HsPat]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (\HsExp
    e' -> HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    e' []) [HsExp]
    es
                                  return (HsPList ps)
            HsParen HsExp
    e'         -> do
                                  p <- HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    e' []
                                  return (HsPParen p)
            HsAsPat HsName
    n HsExp
    e'       -> do
                                  p <- HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    e' []
                                  return (HsPAsPat n p)
            HsExp
    HsWildCard         -> HsPat -> P HsPat
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsPat
    HsPWildCard
            HsIrrPat HsExp
    e'        -> do
                                  p <- HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    e' []
                                  return (HsPIrrPat p)
            HsRecConstr HsQName
    c [HsFieldUpdate]
    fs   -> do
                                  fs' <- (HsFieldUpdate -> P HsPatField)
    -> [HsFieldUpdate] -> P [HsPatField]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsFieldUpdate -> P HsPatField
    checkPatField [HsFieldUpdate]
    fs
                                  return (HsPRec c fs')
            HsNegApp (HsLit HsLiteral
    l) -> HsPat -> P HsPat
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsPat -> HsPat
    HsPNeg (HsLiteral -> HsPat
    HsPLit HsLiteral
    l))
            HsExp
    _ -> P HsPat
    forall a. P a
    patFail

    checkPat HsExp
    _ [HsPat]
    _ = P HsPat
    forall a. P a
    patFail

    checkPatField :: HsFieldUpdate -> P HsPatField
    checkPatField :: HsFieldUpdate -> P HsPatField
    checkPatField (HsFieldUpdate HsQName
    n HsExp
    e) = do
            p <- HsExp -> [HsPat] -> P HsPat
    checkPat HsExp
    e []
            return (HsPFieldPat n p)

    patFail :: P a
    patFail :: forall a. P a
    patFail = String -> P a
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Parse error in pattern"

    -----------------------------------------------------------------------------
    -- Check Expression Syntax

    checkExpr :: HsExp -> P HsExp
    checkExpr :: HsExp -> P HsExp
    checkExpr HsExp
    e = case HsExp
    e of
            HsVar HsQName
    _                   -> HsExp -> P HsExp
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsExp
    e
            HsCon HsQName
    _                   -> HsExp -> P HsExp
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsExp
    e
            HsLit HsLiteral
    _                   -> HsExp -> P HsExp
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsExp
    e
            HsInfixApp HsExp
    e1 HsQOp
    op HsExp
    e2       -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
    check2Exprs HsExp
    e1 HsExp
    e2 ((HsExp -> HsQOp -> HsExp -> HsExp)
    -> HsQOp -> HsExp -> HsExp -> HsExp
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip HsExp -> HsQOp -> HsExp -> HsExp
    HsInfixApp HsQOp
    op)
            HsApp HsExp
    e1 HsExp
    e2               -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
    check2Exprs HsExp
    e1 HsExp
    e2 HsExp -> HsExp -> HsExp
    HsApp
            HsNegApp HsExp
    e1               -> HsExp -> (HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 HsExp -> HsExp
    HsNegApp
            HsLambda SrcLoc
    loc [HsPat]
    ps HsExp
    e1        -> HsExp -> (HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 (SrcLoc -> [HsPat] -> HsExp -> HsExp
    HsLambda SrcLoc
    loc [HsPat]
    ps)
            HsLet [HsDecl]
    bs HsExp
    e1               -> HsExp -> (HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 ([HsDecl] -> HsExp -> HsExp
    HsLet [HsDecl]
    bs)
            HsIf HsExp
    e1 HsExp
    e2 HsExp
    e3             -> HsExp
    -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> HsExp) -> P HsExp
    forall a.
    HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
    check3Exprs HsExp
    e1 HsExp
    e2 HsExp
    e3 HsExp -> HsExp -> HsExp -> HsExp
    HsIf
            HsCase HsExp
    e1 [HsAlt]
    alts            -> do
                                         alts' <- (HsAlt -> P HsAlt) -> [HsAlt] -> P [HsAlt]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsAlt -> P HsAlt
    checkAlt [HsAlt]
    alts
                                         e1' <- checkExpr e1
                                         return (HsCase e1' alts')
            HsDo [HsStmt]
    stmts                -> do
                                         stmts' <- (HsStmt -> P HsStmt) -> [HsStmt] -> P [HsStmt]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsStmt -> P HsStmt
    checkStmt [HsStmt]
    stmts
                                         return (HsDo stmts')
            HsTuple [HsExp]
    es                -> [HsExp] -> ([HsExp] -> HsExp) -> P HsExp
    forall a. [HsExp] -> ([HsExp] -> a) -> P a
    checkManyExprs [HsExp]
    es [HsExp] -> HsExp
    HsTuple
            HsList [HsExp]
    es                 -> [HsExp] -> ([HsExp] -> HsExp) -> P HsExp
    forall a. [HsExp] -> ([HsExp] -> a) -> P a
    checkManyExprs [HsExp]
    es [HsExp] -> HsExp
    HsList
            HsParen HsExp
    e1                -> HsExp -> (HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 HsExp -> HsExp
    HsParen
            HsLeftSection HsExp
    e1 HsQOp
    op       -> HsExp -> (HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 ((HsExp -> HsQOp -> HsExp) -> HsQOp -> HsExp -> HsExp
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip HsExp -> HsQOp -> HsExp
    HsLeftSection HsQOp
    op)
            HsRightSection HsQOp
    op HsExp
    e1      -> HsExp -> (HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 (HsQOp -> HsExp -> HsExp
    HsRightSection HsQOp
    op)
            HsRecConstr HsQName
    c [HsFieldUpdate]
    fields      -> do
                                         fields' <- (HsFieldUpdate -> P HsFieldUpdate)
    -> [HsFieldUpdate] -> P [HsFieldUpdate]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsFieldUpdate -> P HsFieldUpdate
    checkField [HsFieldUpdate]
    fields
                                         return (HsRecConstr c fields')
            HsRecUpdate HsExp
    e1 [HsFieldUpdate]
    fields     -> do
                                         fields' <- (HsFieldUpdate -> P HsFieldUpdate)
    -> [HsFieldUpdate] -> P [HsFieldUpdate]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsFieldUpdate -> P HsFieldUpdate
    checkField [HsFieldUpdate]
    fields
                                         e1' <- checkExpr e1
                                         return (HsRecUpdate e1' fields')
            HsEnumFrom HsExp
    e1             -> HsExp -> (HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 HsExp -> HsExp
    HsEnumFrom
            HsEnumFromTo HsExp
    e1 HsExp
    e2        -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
    check2Exprs HsExp
    e1 HsExp
    e2 HsExp -> HsExp -> HsExp
    HsEnumFromTo
            HsEnumFromThen HsExp
    e1 HsExp
    e2      -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp) -> P HsExp
    forall a. HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
    check2Exprs HsExp
    e1 HsExp
    e2 HsExp -> HsExp -> HsExp
    HsEnumFromThen
            HsEnumFromThenTo HsExp
    e1 HsExp
    e2 HsExp
    e3 -> HsExp
    -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> HsExp) -> P HsExp
    forall a.
    HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
    check3Exprs HsExp
    e1 HsExp
    e2 HsExp
    e3 HsExp -> HsExp -> HsExp -> HsExp
    HsEnumFromThenTo
            HsListComp HsExp
    e1 [HsStmt]
    stmts       -> do
                                         stmts' <- (HsStmt -> P HsStmt) -> [HsStmt] -> P [HsStmt]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsStmt -> P HsStmt
    checkStmt [HsStmt]
    stmts
                                         e1' <- checkExpr e1
                                         return (HsListComp e1' stmts')
            HsExpTypeSig SrcLoc
    loc HsExp
    e1 HsQualType
    ty    -> do
                                         e1' <- HsExp -> P HsExp
    checkExpr HsExp
    e1
                                         return (HsExpTypeSig loc e1' ty)
            HsExp
    _                         -> String -> P HsExp
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Parse error in expression"

    -- type signature for polymorphic recursion!!
    check1Expr :: HsExp -> (HsExp -> a) -> P a
    check1Expr :: forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e1 HsExp -> a
    f = do
            e1' <- HsExp -> P HsExp
    checkExpr HsExp
    e1
            return (f e1')

    check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
    check2Exprs :: forall a. HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
    check2Exprs HsExp
    e1 HsExp
    e2 HsExp -> HsExp -> a
    f = do
            e1' <- HsExp -> P HsExp
    checkExpr HsExp
    e1
            e2' <- checkExpr e2
            return (f e1' e2')

    check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
    check3Exprs :: forall a.
    HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
    check3Exprs HsExp
    e1 HsExp
    e2 HsExp
    e3 HsExp -> HsExp -> HsExp -> a
    f = do
            e1' <- HsExp -> P HsExp
    checkExpr HsExp
    e1
            e2' <- checkExpr e2
            e3' <- checkExpr e3
            return (f e1' e2' e3')

    checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a
    checkManyExprs :: forall a. [HsExp] -> ([HsExp] -> a) -> P a
    checkManyExprs [HsExp]
    es [HsExp] -> a
    f = do
            es' <- (HsExp -> P HsExp) -> [HsExp] -> P [HsExp]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsExp -> P HsExp
    checkExpr [HsExp]
    es
            return (f es')

    checkAlt :: HsAlt -> P HsAlt
    checkAlt :: HsAlt -> P HsAlt
    checkAlt (HsAlt SrcLoc
    loc HsPat
    p HsGuardedAlts
    galts [HsDecl]
    bs) = do
            galts' <- HsGuardedAlts -> P HsGuardedAlts
    checkGAlts HsGuardedAlts
    galts
            return (HsAlt loc p galts' bs)

    checkGAlts :: HsGuardedAlts -> P HsGuardedAlts
    checkGAlts :: HsGuardedAlts -> P HsGuardedAlts
    checkGAlts (HsUnGuardedAlt HsExp
    e) = HsExp -> (HsExp -> HsGuardedAlts) -> P HsGuardedAlts
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e HsExp -> HsGuardedAlts
    HsUnGuardedAlt
    checkGAlts (HsGuardedAlts [HsGuardedAlt]
    galts) = do
            galts' <- (HsGuardedAlt -> P HsGuardedAlt)
    -> [HsGuardedAlt] -> P [HsGuardedAlt]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsGuardedAlt -> P HsGuardedAlt
    checkGAlt [HsGuardedAlt]
    galts
            return (HsGuardedAlts galts')

    checkGAlt :: HsGuardedAlt -> P HsGuardedAlt
    checkGAlt :: HsGuardedAlt -> P HsGuardedAlt
    checkGAlt (HsGuardedAlt SrcLoc
    loc HsExp
    e1 HsExp
    e2) = HsExp
    -> HsExp -> (HsExp -> HsExp -> HsGuardedAlt) -> P HsGuardedAlt
    forall a. HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
    check2Exprs HsExp
    e1 HsExp
    e2 (SrcLoc -> HsExp -> HsExp -> HsGuardedAlt
    HsGuardedAlt SrcLoc
    loc)

    checkStmt :: HsStmt -> P HsStmt
    checkStmt :: HsStmt -> P HsStmt
    checkStmt (HsGenerator SrcLoc
    loc HsPat
    p HsExp
    e) = HsExp -> (HsExp -> HsStmt) -> P HsStmt
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e (SrcLoc -> HsPat -> HsExp -> HsStmt
    HsGenerator SrcLoc
    loc HsPat
    p)
    checkStmt (HsQualifier HsExp
    e)       = HsExp -> (HsExp -> HsStmt) -> P HsStmt
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e HsExp -> HsStmt
    HsQualifier
    checkStmt s :: HsStmt
    s@(HsLetStmt [HsDecl]
    _)       = HsStmt -> P HsStmt
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsStmt
    s

    checkField :: HsFieldUpdate -> P HsFieldUpdate
    checkField :: HsFieldUpdate -> P HsFieldUpdate
    checkField (HsFieldUpdate HsQName
    n HsExp
    e) = HsExp -> (HsExp -> HsFieldUpdate) -> P HsFieldUpdate
    forall a. HsExp -> (HsExp -> a) -> P a
    check1Expr HsExp
    e (HsQName -> HsExp -> HsFieldUpdate
    HsFieldUpdate HsQName
    n)

    -----------------------------------------------------------------------------
    -- Check Equation Syntax

    checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
    checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
    checkValDef SrcLoc
    srcloc HsExp
    lhs HsRhs
    rhs [HsDecl]
    whereBinds =
        case HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
    isFunLhs HsExp
    lhs [] of
             Just (HsName
    f,[HsExp]
    es) -> do
                            ps <- (HsExp -> P HsPat) -> [HsExp] -> P [HsPat]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsExp -> P HsPat
    checkPattern [HsExp]
    es
                            return (HsFunBind [HsMatch srcloc f ps rhs whereBinds])
             Maybe (HsName, [HsExp])
    Nothing     -> do
                            lhs' <- HsExp -> P HsPat
    checkPattern HsExp
    lhs
                            return (HsPatBind srcloc lhs' rhs whereBinds)

    -- A variable binding is parsed as an HsPatBind.

    isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
    isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
    isFunLhs (HsInfixApp HsExp
    l (HsQVarOp (UnQual HsName
    op)) HsExp
    r) [HsExp]
    es = (HsName, [HsExp]) -> Maybe (HsName, [HsExp])
    forall a. a -> Maybe a
    Just (HsName
    op, HsExp
    lHsExp -> [HsExp] -> [HsExp]
    forall a. a -> [a] -> [a]
    :HsExp
    rHsExp -> [HsExp] -> [HsExp]
    forall a. a -> [a] -> [a]
    :[HsExp]
    es)
    isFunLhs (HsApp (HsVar (UnQual HsName
    f)) HsExp
    e) [HsExp]
    es            = (HsName, [HsExp]) -> Maybe (HsName, [HsExp])
    forall a. a -> Maybe a
    Just (HsName
    f, HsExp
    eHsExp -> [HsExp] -> [HsExp]
    forall a. a -> [a] -> [a]
    :[HsExp]
    es)
    isFunLhs (HsApp (HsParen HsExp
    f) HsExp
    e) [HsExp]
    es                   = HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
    isFunLhs HsExp
    f (HsExp
    eHsExp -> [HsExp] -> [HsExp]
    forall a. a -> [a] -> [a]
    :[HsExp]
    es)
    isFunLhs (HsApp HsExp
    f HsExp
    e) [HsExp]
    es                             = HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
    isFunLhs HsExp
    f (HsExp
    eHsExp -> [HsExp] -> [HsExp]
    forall a. a -> [a] -> [a]
    :[HsExp]
    es)
    isFunLhs HsExp
    _ [HsExp]
    _                                        = Maybe (HsName, [HsExp])
    forall a. Maybe a
    Nothing

    -----------------------------------------------------------------------------
    -- In a class or instance body, a pattern binding must be of a variable.

    checkClassBody :: [HsDecl] -> P [HsDecl]
    checkClassBody :: [HsDecl] -> P [HsDecl]
    checkClassBody [HsDecl]
    decls = do
            (HsDecl -> P ()) -> [HsDecl] -> P ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ HsDecl -> P ()
    checkMethodDef [HsDecl]
    decls
            [HsDecl] -> P [HsDecl]
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [HsDecl]
    decls

    checkMethodDef :: HsDecl -> P ()
    checkMethodDef :: HsDecl -> P ()
    checkMethodDef (HsPatBind SrcLoc
    _ (HsPVar HsName
    _) HsRhs
    _ [HsDecl]
    _) = () -> P ()
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    checkMethodDef (HsPatBind SrcLoc
    loc HsPat
    _ HsRhs
    _ [HsDecl]
    _) =
            String -> P ()
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "illegal method definition" P () -> SrcLoc -> P ()
    forall a. P a -> SrcLoc -> P a
    `atSrcLoc` SrcLoc
    loc
    checkMethodDef HsDecl
    _ = () -> P ()
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    -----------------------------------------------------------------------------
    -- Check that an identifier or symbol is unqualified.
    -- For occasions when doing this in the grammar would cause conflicts.

    checkUnQual :: HsQName -> P HsName
    checkUnQual :: HsQName -> P HsName
    checkUnQual (Qual Module
    _ HsName
    _)  = String -> P HsName
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Illegal qualified name"
    checkUnQual (UnQual HsName
    n)  = HsName -> P HsName
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsName
    n
    checkUnQual (Special HsSpecialCon
    _) = String -> P HsName
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Illegal special name"

    -----------------------------------------------------------------------------
    -- Miscellaneous utilities

    checkPrec :: Integer -> P Int
    checkPrec :: Integer -> P Int
    checkPrec Integer
    i | Integer
    0 Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Integer
    i Bool -> Bool -> Bool
    && Integer
    i Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Integer
    9 = Int -> P Int
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Integer -> Int
    forall a. Num a => Integer -> a
    fromInteger Integer
    i)
    checkPrec Integer
    i | Bool
    otherwise        = String -> P Int
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Illegal precedence " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Integer -> String
    forall a. Show a => a -> String
    show Integer
    i)

    mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp
    mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp
    mkRecConstrOrUpdate (HsCon HsQName
    c) [HsFieldUpdate]
    fs       = HsExp -> P HsExp
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsQName -> [HsFieldUpdate] -> HsExp
    HsRecConstr HsQName
    c [HsFieldUpdate]
    fs)
    mkRecConstrOrUpdate HsExp
    e         fs :: [HsFieldUpdate]
    fs@(HsFieldUpdate
    _:[HsFieldUpdate]
    _) = HsExp -> P HsExp
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (HsExp -> [HsFieldUpdate] -> HsExp
    HsRecUpdate HsExp
    e [HsFieldUpdate]
    fs)
    mkRecConstrOrUpdate HsExp
    _         [HsFieldUpdate]
    _        = String -> P HsExp
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Empty record update"

    -----------------------------------------------------------------------------
    -- Reverse a list of declarations, merging adjacent HsFunBinds of the
    -- same name and checking that their arities match.

    checkRevDecls :: [HsDecl] -> P [HsDecl]
    checkRevDecls :: [HsDecl] -> P [HsDecl]
    checkRevDecls = [HsDecl] -> [HsDecl] -> P [HsDecl]
    mergeFunBinds []
        where
            mergeFunBinds :: [HsDecl] -> [HsDecl] -> P [HsDecl]
    mergeFunBinds [HsDecl]
    revDs [] = [HsDecl] -> P [HsDecl]
    forall a. a -> P a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [HsDecl]
    revDs
            mergeFunBinds [HsDecl]
    revDs (HsFunBind ms1 :: [HsMatch]
    ms1@(HsMatch SrcLoc
    _ HsName
    name [HsPat]
    ps HsRhs
    _ [HsDecl]
    _:[HsMatch]
    _):[HsDecl]
    ds1) =
                    [HsMatch] -> [HsDecl] -> P [HsDecl]
    mergeMatches [HsMatch]
    ms1 [HsDecl]
    ds1
                where
                    arity :: Int
    arity = [HsPat] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [HsPat]
    ps
                    mergeMatches :: [HsMatch] -> [HsDecl] -> P [HsDecl]
    mergeMatches [HsMatch]
    ms' (HsFunBind ms :: [HsMatch]
    ms@(HsMatch SrcLoc
    loc HsName
    name' [HsPat]
    ps' HsRhs
    _ [HsDecl]
    _:[HsMatch]
    _):[HsDecl]
    ds)
                        | HsName
    name' HsName -> HsName -> Bool
    forall a. Eq a => a -> a -> Bool
    == HsName
    name =
                            if [HsPat] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [HsPat]
    ps' Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Int
    arity
                            then String -> P [HsDecl]
    forall a. String -> P a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "arity mismatch for '" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ HsName -> String
    forall a. Pretty a => a -> String
    prettyPrint HsName
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'")
                                 P [HsDecl] -> SrcLoc -> P [HsDecl]
    forall a. P a -> SrcLoc -> P a
    `atSrcLoc` SrcLoc
    loc
                            else [HsMatch] -> [HsDecl] -> P [HsDecl]
    mergeMatches ([HsMatch]
    ms[HsMatch] -> [HsMatch] -> [HsMatch]
    forall a. [a] -> [a] -> [a]
    ++[HsMatch]
    ms') [HsDecl]
    ds
                    mergeMatches [HsMatch]
    ms' [HsDecl]
    ds = [HsDecl] -> [HsDecl] -> P [HsDecl]
    mergeFunBinds ([HsMatch] -> HsDecl
    HsFunBind [HsMatch]
    ms'HsDecl -> [HsDecl] -> [HsDecl]
    forall a. a -> [a] -> [a]
    :[HsDecl]
    revDs) [HsDecl]
    ds
            mergeFunBinds [HsDecl]
    revDs (HsDecl
    d:[HsDecl]
    ds) = [HsDecl] -> [HsDecl] -> P [HsDecl]
    mergeFunBinds (HsDecl
    dHsDecl -> [HsDecl] -> [HsDecl]
    forall a. a -> [a] -> [a]
    :[HsDecl]
    revDs) [HsDecl]
    ds