    {-# OPTIONS_HADDOCK hide #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Language.Haskell.Exts.ParseUtils
    -- Copyright   :  (c) Niklas Broberg 2004-2009,
    --                (c) The GHC Team, 1997-2000
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg, d00nibro@chalmers.se
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- Utilities for the Haskell-exts parser.
    --
    -----------------------------------------------------------------------------

    module Language.Haskell.Exts.ParseUtils (
          splitTyConApp         -- PType -> P (Name,[Type])
        , checkEnabled          -- (Show e, Enabled e) => e -> P ()
        , checkPatternGuards    -- [Stmt] -> P ()
        , mkRecConstrOrUpdate   -- PExp -> [PFieldUpdate] -> P Exp
        , checkPrec             -- Integer -> P Int
        , checkPContext         -- PType -> P PContext
        , checkContext          -- PContext -> P Context
        , checkAssertion        -- PType -> P PAsst
        , checkDataHeader       -- PType -> P (Context,Name,[TyVarBind])
        , checkClassHeader      -- PType -> P (Context,Name,[TyVarBind])
        , checkInstHeader       -- PType -> P (Context,QName,[Type])
        , checkDeriving         -- [PType] -> P [Deriving]
        , checkPattern          -- PExp -> P Pat
        , checkExpr             -- PExp -> P Exp
        , checkType             -- PType -> P Type
        , checkValDef           -- SrcLoc -> PExp -> Maybe Type -> Rhs -> Binds -> P Decl
        , checkClassBody        -- [ClassDecl] -> P [ClassDecl]
        , checkInstBody         -- [InstDecl] -> P [InstDecl]
        , checkUnQual           -- QName -> P Name
        , checkRevDecls         -- [Decl] -> P [Decl]
        , checkRevClsDecls      -- [ClassDecl] -> P [ClassDecl]
        , checkRevInstDecls     -- [InstDecl] -> P [InstDecl]
        , checkDataOrNew        -- DataOrNew -> [a] -> P ()
        , checkSimpleType       -- PType -> P (Name, [TyVarBind])
        , checkSigVar           -- PExp -> P Name
        , getGConName           -- S.Exp -> P QName
        , mkTyForall            -- Maybe [TyVarBind] -> PContext -> PType -> PType
        -- HaRP
        , checkRPattern         -- PExp -> P RPat
        -- Hsx
        , checkEqNames          -- XName -> XName -> P XName
        , checkPageModule
        , checkHybridModule
        , mkDVar                -- [String] -> String
        -- Pragmas
        , checkRuleExpr         -- PExp -> P Exp
        , readTool              -- Maybe String -> Maybe Tool

        -- Parsed expressions and types
        , PExp(..), PFieldUpdate(..), ParseXAttr(..), PType(..), PContext, PAsst(..)
        , p_unit_con            -- PExp
        , p_tuple_con           -- Boxed -> Int -> PExp
        , p_unboxed_singleton_con   -- PExp
        ) 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(..) )
    import Language.Haskell.Exts.Annotated.Build

    import Language.Haskell.Exts.ParseSyntax
    import Language.Haskell.Exts.ParseMonad
    import Language.Haskell.Exts.Pretty
    import Language.Haskell.Exts.SrcLoc
    import Language.Haskell.Exts.Extension
    import Language.Haskell.Exts.ExtScheme

    import Data.List (intersperse)
    import Data.Maybe (fromJust)
    import Control.Monad (when,liftM)

    --- import Debug.Trace (trace)

    type L = SrcSpanInfo
    type S = SrcSpan

    splitTyConApp :: PType L -> P (Name L, [S.Type L])
    splitTyConApp t0 = do
                (n, pts) <- split t0 []
                ts <- mapM checkType pts
                return (n,ts)
     where
        split :: PType L -> [PType L] -> P (Name L, [PType L])
        split (TyApp _ t u) ts = split t (u:ts)
        split (TyCon _ (UnQual _ t)) ts = return (t,ts)
        split (TyInfix l a op b) ts = split (TyCon l op) (a:b:ts)
        split _ _ = fail "Illegal data/newtype declaration"

    -----------------------------------------------------------------------------
    -- Checking for extensions

    checkEnabled :: (Show e, Enabled e) => e  -> P ()
    checkEnabled e = do
        exts <- getExtensions
        if isEnabled e exts
         then return ()
         else fail $ show e ++ " is not enabled"

    checkPatternGuards :: [Stmt L] -> P ()
    checkPatternGuards [Qualifier _ _] = return ()
    checkPatternGuards _ = checkEnabled PatternGuards

    -----------------------------------------------------------------------------
    -- Checking contexts

    -- Check that a context is syntactically correct. Takes care of
    -- checking for MPTCs, TypeOperators, TypeFamilies (for eq constraints)
    -- and ImplicitParameters, but leaves checking of the class assertion
    -- parameters for later.
    checkPContext :: PType L -> P (PContext L)
    checkPContext (TyTuple l Boxed ts) =
        mapM checkAssertion ts >>= return . CxTuple l
    checkPContext (TyCon l (Special _ (UnitCon _))) =
        return $ CxEmpty l
    checkPContext (TyParen l t) = do
        c <- checkPContext t
        return $ CxParen l c
    checkPContext t = do
        c <- checkAssertion t
        return $ CxSingle (ann c) c

    ------------------------------------------------------------------------------------------------------------------- WORKING HERE

    -- Check a single assertion according to the above, still leaving
    -- the class assertion parameters for later.
    checkAssertion :: PType L -> P (PAsst L)
    -- We cannot even get here unless ImplicitParameters is enabled.
    checkAssertion (TyPred _ p@(IParam _ _ _)) = return p
    -- We cannot even get here unless TypeFamilies is enabled.
    checkAssertion (TyPred _ p@(EqualP _ _ _)) = return p
    checkAssertion t = checkAssertion' id [] t
        where   -- class assertions must have at least one argument
                checkAssertion' fl ts@(_:xs) (TyCon l c) = do
                    when (not $ null xs) $ checkEnabled MultiParamTypeClasses
                    when (isSymbol c)    $ checkEnabled TypeOperators
                    return $ ClassA (fl l) c ts
                checkAssertion' fl ts (TyApp l a t) = do
                    -- no check on t at this stage
                    checkAssertion' (const (fl l)) (t:ts) a
                checkAssertion' fl ts (TyInfix l a op b) = do
                    -- infix operators require TypeOperators
                    checkEnabled TypeOperators
                    return $ InfixA (fl l) a op b
                checkAssertion' fl ts (TyParen l t) =
                    checkAssertion' (const (fl l)) ts t
                checkAssertion' _ _ _ = fail "Illegal class assertion"

    isSymbol :: QName L -> Bool
    isSymbol (UnQual _ (Symbol _ _)) = True
    isSymbol (Qual _ _ (Symbol _ _)) = True
    isSymbol _                       = False

    -- Checks simple contexts for class and instance
    -- headers. If FlexibleContexts is enabled then
    -- anything goes, otherwise only tyvars are allowed.
    checkSContext :: Maybe (PContext L) -> P (Maybe (S.Context L))
    checkSContext (Just ctxt) = case ctxt of
        CxEmpty l -> return $ Just $ S.CxEmpty l
        CxSingle l a -> checkAsst True a >>= return . Just . S.CxSingle l
        CxTuple l as -> mapM (checkAsst True) as >>= return . Just . S.CxTuple l
        CxParen l cx -> checkSContext (Just cx) >>= return . fmap (S.CxParen l)
    checkSContext _ = return Nothing

    -- Checks ordinary contexts for sigtypes and data type
    -- declarations. If FlexibleContexts is enabled then
    -- anything goes, otherwise only tyvars OR tyvars
    -- applied to types are allowed.
    checkContext :: Maybe (PContext L) -> P (Maybe (S.Context L))
    checkContext (Just ctxt) = case ctxt of
        CxEmpty l -> return $ Just $ S.CxEmpty l
        CxSingle l a -> checkAsst False a >>= return . Just . S.CxSingle l
        CxTuple l as -> mapM (checkAsst False) as >>= return . Just . S.CxTuple l
        CxParen l cx -> checkSContext (Just cx) >>= return . fmap (S.CxParen l)
    checkContext _ = return Nothing

    checkAsst :: Bool -> PAsst L -> P (S.Asst L)
    checkAsst isSimple asst =
        case asst of
          ClassA l qn pts -> do
                    ts <- mapM (checkAsstParam isSimple) pts
                    return $ S.ClassA l qn ts
          InfixA l a op b -> do
                    [a,b] <- mapM (checkAsstParam isSimple) [a,b]
                    return $ S.InfixA l a op b
          IParam l ipn pt -> do
                    t <- checkType pt
                    return $ S.IParam l ipn t
          EqualP l pa pb  -> do
                    a <- checkType pa
                    b <- checkType pb
                    return $ S.EqualP l a b

    checkAsstParam :: Bool -> PType L -> P (S.Type L)
    checkAsstParam isSimple t = do
            exts <- getExtensions
            if FlexibleContexts `elem` exts
             then checkType t
             else case t of
                    TyVar l n     -> return $ S.TyVar l n
                    TyApp l pf pt | not isSimple    -> do
                            f <- checkAsstParam isSimple pf
                            t <- checkType pt
                            return $ S.TyApp l f t
                    _       -> fail "Malformed context: FlexibleContexts not enabled"

    -----------------------------------------------------------------------------
    -- Checking Headers

    checkDataHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
    checkDataHeader (TyForall _ Nothing cs t) = do
        dh <- checkSimple "data/newtype" t []
        cs <- checkContext cs
        return (cs,dh)
    checkDataHeader t = do
        dh <- checkSimple "data/newtype" t []
        return (Nothing,dh)

    checkClassHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
    checkClassHeader (TyForall _ Nothing cs t) = do
        dh <- checkSimple "class" t []
        cs <- checkSContext cs
        return (cs,dh)
    checkClassHeader t = do
        dh <- checkSimple "class" t []
        return (Nothing,dh)

    checkSimple :: String -> PType L -> [TyVarBind L] -> P (DeclHead L)
    checkSimple kw (TyApp _ l t) xs | isTyVarBind t = checkSimple kw l (toTyVarBind t : xs)
    checkSimple _  (TyInfix l t1 (UnQual _ t) t2) []
        | isTyVarBind t1 && isTyVarBind t2 =
           checkEnabled TypeOperators >> return (DHInfix l (toTyVarBind t1) t (toTyVarBind t2))
    checkSimple _kw (TyCon l (UnQual _ t))   xs = do
        case t of
          Symbol _ _ -> checkEnabled TypeOperators
          _ -> return ()
        return (DHead l t xs)
    checkSimple kw (TyParen l t) xs = do
        dh <- checkSimple kw t xs
        return (DHParen l dh)
    checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration")

    isTyVarBind :: PType L -> Bool
    isTyVarBind (TyVar _ _) = True
    isTyVarBind (TyKind _ (TyVar _ _) _) = True
    isTyVarBind _ = False

    toTyVarBind :: PType L -> TyVarBind L
    toTyVarBind (TyVar l n) = UnkindedVar l n
    toTyVarBind (TyKind l (TyVar _ n) k) = KindedVar l n k

    checkInstHeader :: PType L -> P (Maybe (S.Context L), InstHead L)
    checkInstHeader (TyForall _ Nothing cs t) = do
        ih <- checkInsts t []
        cs <- checkSContext cs
        return (cs, ih)
    checkInstHeader t = do
        ih <- checkInsts t []
        return (Nothing, ih)

    checkInsts :: PType L -> [PType L] -> P (InstHead L)
    checkInsts (TyApp _ l t) ts = checkInsts l (t:ts)
    checkInsts (TyCon l c)   ts = do
        when (isSymbol c) $ checkEnabled TypeOperators
        ts <- checkTypes ts
        return $ IHead l c ts
    checkInsts (TyInfix l a op b) [] = do
        checkEnabled TypeOperators
        [ta,tb] <- checkTypes [a,b]
        return $ IHInfix l ta op tb
    checkInsts (TyParen l t) [] = checkInsts t [] >>= return . IHParen l
    checkInsts _ _ = fail "Illegal instance declaration"

    checkDeriving :: [PType L] -> P [InstHead L]
    checkDeriving = mapM (flip checkInsts [])

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

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

    checkPattern :: PExp L -> P (Pat L)
    checkPattern e = checkPat e []

    checkPat :: PExp L -> [Pat L] -> P (Pat L)
    checkPat (Con l c) args = return (PApp l c args)
    checkPat (App l f x) args = do
        x <- checkPat x []
        checkPat f (x:args)
    checkPat (InfixApp _ l op r) args
        | op =~= (QVarOp () (UnQual () (Symbol () "!"))) = do
            -- We must have BangPatterns on
            checkEnabled BangPatterns
            let (e,es) = splitBang r []
            ps <- mapM checkPattern (BangPat (ann op) e:es)
            checkPat l (ps++args)
    checkPat e [] = case e of
        Var l (UnQual _ x)   -> return (PVar l x)
        Lit l lit            -> return (PLit l lit)
        InfixApp loc l op r  ->
            case op of
                QConOp _ c -> do
                        l <- checkPat l []
                        r <- checkPat r []
                        return (PInfixApp loc l c r)
                QVarOp ppos (UnQual _ (Symbol _ "+")) -> do
                        case (l,r) of
                            (Var _ (UnQual _ n@(Ident _ _)), Lit _ (Int kpos k _)) -> do
                                let pp = srcInfoSpan ppos
                                    kp = srcInfoSpan kpos
                                return (PNPlusK (loc <** [pp,kp]) n k)
                            _ -> patFail ""
                _ -> patFail ""
        TupleSection l mes    ->
                if not (any ((==) Nothing) mes)
                 then do ps <- mapM (\e -> checkPat e []) (map fromJust mes)
                         return (PTuple l ps)
                 else fail "Illegal tuple section in pattern"

        List l es      -> do
                      ps <- mapM checkRPattern es
                      if all isStdPat ps
                        then return . PList l $ map stripRP ps
                        -- we don't allow truly regular patterns unless the extension is enabled
                        else checkEnabled RegularPatterns >> return (PRPat l $ map fixRPOpPrec ps)
                where isStdPat :: RPat L -> Bool
                      isStdPat (RPPat _ _) = True
                      isStdPat (RPAs _ _ p) = isStdPat p
                      isStdPat (RPParen _ p) = isStdPat p
                      isStdPat _           = False
                      stripRP :: RPat L -> Pat L
                      stripRP (RPPat  _ p) = p
                      stripRP (RPAs l n p) = PAsPat l n (stripRP p)
                      stripRP (RPParen l p) = PParen l (stripRP p)
                      stripRP _           = error "cannot strip RP wrapper if not all patterns are base"

        Paren l e      -> do
                      p <- checkPat e []
                      return (PParen l p)
        AsPat l n e    -> do
                      p <- checkPat e []
                      return (PAsPat l n p)
        WildCard l   -> return (PWildCard l)
        IrrPat l e   -> do
                      p <- checkPat e []
                      return (PIrrPat l p)
        ViewPat l e p  -> do
                      e <- checkExpr e
                      p <- checkPat p []
                      return (PViewPat l e p)
        RecConstr l c fs   -> do
                      fs <- mapM checkPatField fs
                      return (PRec l c fs)
        NegApp l1 (Lit l2 lit) -> return (PNeg l1 (PLit l2 lit))
        ExpTypeSig l e t -> do
                      -- patterns cannot have signatures unless ScopedTypeVariables is enabled.
                      checkEnabled ScopedTypeVariables
                      p <- checkPat e []
                      return (PatTypeSig l p t)

        -- Hsx
        XTag l n attrs mattr cs -> do
                      pattrs <- mapM checkPAttr attrs
                      pcs    <- mapM (\c -> checkPat c []) cs
                      mpattr <- maybe (return Nothing)
                                  (\e -> do p <- checkPat e []
                                            return $ Just p)
                                  mattr
                      let cps = mkChildrenPat pcs
                      return $ PXTag l n pattrs mpattr cps
        XETag l n attrs mattr -> do
                      pattrs <- mapM checkPAttr attrs
                      mpattr <- maybe (return Nothing)
                                  (\e -> do p <- checkPat e []
                                            return $ Just p)
                                  mattr
                      return $ PXETag l n pattrs mpattr
        XPcdata l pcdata   -> return $ PXPcdata l pcdata
        XExpTag l e -> do
                p <- checkPat e []
                return $ PXPatTag l p
        XRPats l es -> do
                rps <- mapM checkRPattern es
                return (PXRPats l $ map fixRPOpPrec rps)

        -- Generics
        ExplTypeArg l qn t -> return $ PExplTypeArg l qn t

        -- QuasiQuotation
        QuasiQuote l n q -> return $ PQuasiQuote l n q

        -- BangPatterns
        BangPat l e -> do
            p <- checkPat e []
            return $ PBangPat l p

        PreOp l (QVarOp _ (UnQual _ (Symbol _ "!"))) e -> do
            checkEnabled BangPatterns
            p <- checkPat e []
            return $ PBangPat l p

        e -> patFail $ prettyPrint e

    checkPat e _ = patFail $ prettyPrint e

    splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L])
    splitBang (App _ f x) es = splitBang f (x:es)
    splitBang e es = (e, es)

    checkPatField :: PFieldUpdate L -> P (PatField L)
    checkPatField (FieldUpdate l n e) = do
        p <- checkPat e []
        return (PFieldPat l n p)
    checkPatField (FieldPun l n) = return (PFieldPun l n)
    checkPatField (FieldWildcard l) = return (PFieldWildcard l)

    checkPAttr :: ParseXAttr L -> P (PXAttr L)
    checkPAttr (XAttr l n v) = do p <- checkPat v []
                                  return $ PXAttr l n p

    patFail :: String -> P a
    patFail s = fail $ "Parse error in pattern: " ++ s

    checkRPattern :: PExp L -> P (RPat L)
    checkRPattern e = case e of
        SeqRP l es -> do
            rps <- mapM checkRPattern es
            return $ RPSeq l rps
        PostOp l e op -> do
            rpop <- checkRPatOp op
            rp   <- checkRPattern e
            return $ RPOp l rp rpop
        GuardRP l e gs -> do
            rp <- checkPattern e
            return $ RPGuard l rp gs
        EitherRP l e1 e2 -> do
            rp1 <- checkRPattern e1
            rp2 <- checkRPattern e2
            return $ RPEither l rp1 rp2
        CAsRP l n e -> do
            rp <- checkRPattern e
            return $ RPCAs l n rp
        AsPat l n e  -> do
            rp <- checkRPattern e
            return $ RPAs l n rp
        Paren l e -> do
            rp <- checkRPattern e
            return $ RPParen l rp
        _          -> do
            p <- checkPattern e
            return $ RPPat (ann p) p

    checkRPatOp :: QOp L -> P (RPatOp L)
    checkRPatOp o@(QVarOp l (UnQual _ (Symbol _ sym))) =
        case sym of
         "*"  -> return $ RPStar l
         "*!" -> return $ RPStarG l
         "+"  -> return $ RPPlus l
         "+!" -> return $ RPPlusG l
         "?"  -> return $ RPOpt l
         "?!" -> return $ RPOptG l
         _    -> rpOpFail o
    checkRPatOp o = rpOpFail o

    rpOpFail sym = fail $ "Unrecognized regular pattern operator: " ++ prettyPrint sym

    fixRPOpPrec :: RPat L -> RPat L
    fixRPOpPrec rp = case rp of
        RPOp l rp rpop      -> fPrecOp rp (flip (RPOp l) rpop)
        RPEither l rp1 rp2  -> RPEither l (fixRPOpPrec rp1) (fixRPOpPrec rp2)
        RPSeq l rps         -> RPSeq l $ map fixRPOpPrec rps
        RPCAs l n rp        -> RPCAs l n $ fixRPOpPrec rp
        RPAs l n rp         -> RPAs l n $ fixRPOpPrec rp
        RPParen l rp        -> RPParen l $ fixRPOpPrec rp
        _                   -> rp

      where fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L
            fPrecOp (RPOp l rp rpop) f = fPrecOp rp (f . flip (RPOp l) rpop)
            fPrecOp (RPCAs l n rp) f = fPrecAs rp f (RPCAs l n)
            fPrecOp (RPAs  l n rp) f = fPrecAs rp f (RPAs  l n)
            fPrecOp rp f = f $ fixRPOpPrec rp
            fPrecAs :: RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
            fPrecAs (RPCAs l n rp) f g = fPrecAs rp f (g . RPCAs l n)
            fPrecAs (RPAs  l n rp) f g = fPrecAs rp f (g . RPAs  l n)
            fPrecAs rp f g = g . f $ fixRPOpPrec rp

    mkChildrenPat :: [Pat L] -> [Pat L]
    mkChildrenPat ps = mkCPAux ps []
      where mkCPAux :: [Pat L] -> [Pat L] -> [Pat L]
            mkCPAux [] qs = reverse qs
            mkCPAux (p:ps) qs = case p of
                (PRPat l rps) -> [mkCRP l ps (reverse rps ++ map (\q -> RPPat (ann q) q) qs)]
                _             -> mkCPAux ps (p:qs)

            mkCRP :: L -> [Pat L] -> [RPat L] -> Pat L
            mkCRP l [] rps = PXRPats l $ reverse rps
            mkCRP _ (p:ps) rps = case p of
                (PXRPats l rqs) -> mkCRP l ps (reverse rqs ++ rps)
                _               -> mkCRP (ann p) ps (RPPat (ann p) p : rps)

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

    checkExpr :: PExp L -> P (S.Exp L)
    checkExpr e = case e of
        Var l v               -> return $ S.Var l v
        IPVar l v             -> return $ S.IPVar l v
        Con l c               -> return $ S.Con l c
        Lit l lit             -> return $ S.Lit l lit
        InfixApp l e1 op e2   -> check2Exprs e1 e2 (flip (S.InfixApp l) op)
        App l e1 e2           -> check2Exprs e1 e2 (S.App l)
        NegApp l e            -> check1Expr e (S.NegApp l)
        Lambda loc ps e       -> check1Expr e (S.Lambda loc ps)
        Let l bs e            -> check1Expr e (S.Let l bs)
        If l e1 e2 e3         -> check3Exprs e1 e2 e3 (S.If l)
        Case l e alts         -> do
                         e <- checkExpr e
                         return (S.Case l e alts)
        Do l stmts            -> checkDo stmts >> return (S.Do l stmts)
        MDo l stmts           -> checkDo stmts >> return (S.MDo l stmts)
        TupleSection l mes -> if not (any ((==) Nothing) mes)
                               then checkManyExprs (map fromJust mes) (S.Tuple l)
                               else do checkEnabled TupleSections
                                       mes' <- mapM mCheckExpr mes
                                       return $ S.TupleSection l mes'

        List l es         -> checkManyExprs es (S.List l)
        -- Since we don't parse things as left or right sections, we need to mangle them into that.
        Paren l e         -> case e of
                              PostOp _ e1 op -> check1Expr e1 (flip (S.LeftSection l) op)
                              PreOp  _ op e2 -> check1Expr e2 (S.RightSection l op)
                              _            -> check1Expr e (S.Paren l)
        RecConstr l c fields      -> do
                         fields <- mapM checkField fields
                         return (S.RecConstr l c fields)
        RecUpdate l e fields      -> do
                         fields <- mapM checkField fields
                         e <- checkExpr e
                         return (S.RecUpdate l e fields)
        EnumFrom l e          -> check1Expr e (S.EnumFrom l)
        EnumFromTo l e1 e2    -> check2Exprs e1 e2 (S.EnumFromTo l)
        EnumFromThen l e1 e2      -> check2Exprs e1 e2 (S.EnumFromThen l)
        EnumFromThenTo l e1 e2 e3 -> check3Exprs e1 e2 e3 (S.EnumFromThenTo l)
        -- a parallel list comprehension, which could be just a simple one
        ParComp l e qualss        -> do
                         e <- checkExpr e
                         case qualss of
                          [quals] -> return (S.ListComp l e quals)
                          _       -> return (S.ParComp l e qualss)
        ExpTypeSig loc e ty     -> do
                         e <- checkExpr e
                         return (S.ExpTypeSig loc e ty)

        --Template Haskell
        BracketExp l e        -> return $ S.BracketExp l e
        SpliceExp l e         -> return $ S.SpliceExp l e
        TypQuote l q          -> return $ S.TypQuote l q
        VarQuote l q          -> return $ S.VarQuote l q
        QuasiQuote l n q      -> return $ S.QuasiQuote l n q

        -- Hsx
        XTag l n attrs mattr cs -> do attrs <- mapM checkAttr attrs
                                      cs <- mapM checkExpr cs
                                      mattr <- maybe (return Nothing)
                                                  (\e -> checkExpr e >>= return . Just)
                                                  mattr
                                      return $ S.XTag l n attrs mattr cs
        XETag l n attrs mattr   -> do attrs <- mapM checkAttr attrs
                                      mattr <- maybe (return Nothing)
                                                  (\e -> checkExpr e >>= return . Just)
                                                  mattr
                                      return $ S.XETag l n attrs mattr
        XPcdata l p       -> return $ S.XPcdata l p
        XExpTag l e       -> do e <- checkExpr e
                                return $ S.XExpTag l e
        -- Pragmas
        CorePragma l s e  -> check1Expr e (S.CorePragma l s)
        SCCPragma  l s e  -> check1Expr e (S.SCCPragma l s)
        GenPragma l s xx yy e -> check1Expr e (S.GenPragma l s xx yy)
    --    UnknownExpPragma n s -> return $ S.UnknownExpPragma n s

        -- Arrows
        Proc l p e        -> do e <- checkExpr e
                                return $ S.Proc l p e
        LeftArrApp l e1 e2      -> check2Exprs e1 e2 (S.LeftArrApp l)
        RightArrApp l e1 e2     -> check2Exprs e1 e2 (S.RightArrApp l)
        LeftArrHighApp l e1 e2  -> check2Exprs e1 e2 (S.LeftArrHighApp l)
        RightArrHighApp l e1 e2 -> check2Exprs e1 e2 (S.RightArrHighApp l)

        _             -> fail $ "Parse error in expression: " ++ prettyPrint e

    checkAttr :: ParseXAttr L -> P (S.XAttr L)
    checkAttr (XAttr l n v) = do v <- checkExpr v
                                 return $ S.XAttr l n v

    checkDo [] = fail "Parse error: Last statement in a do-block must be an expression"
    checkDo [Qualifier _ _] = return ()
    checkDo (_:xs) = checkDo xs

    -- type signature for polymorphic recursion!!
    check1Expr :: PExp L -> (S.Exp L -> a) -> P a
    check1Expr e1 f = do
        e1 <- checkExpr e1
        return (f e1)

    check2Exprs :: PExp L -> PExp L -> (S.Exp L -> S.Exp L -> a) -> P a
    check2Exprs e1 e2 f = do
        e1 <- checkExpr e1
        e2 <- checkExpr e2
        return (f e1 e2)

    check3Exprs :: PExp L -> PExp L -> PExp L -> (S.Exp L -> S.Exp L -> S.Exp L -> a) -> P a
    check3Exprs e1 e2 e3 f = do
        e1 <- checkExpr e1
        e2 <- checkExpr e2
        e3 <- checkExpr e3
        return (f e1 e2 e3)

    checkManyExprs :: [PExp L] -> ([S.Exp L] -> a) -> P a
    checkManyExprs es f = do
        es <- mapM checkExpr es
        return (f es)

    mCheckExpr :: Maybe (PExp L) -> P (Maybe (S.Exp L))
    mCheckExpr Nothing = return Nothing
    mCheckExpr (Just e) = checkExpr e >>= return . Just

    checkRuleExpr :: PExp L -> P (S.Exp L)
    checkRuleExpr = checkExpr

    readTool :: Maybe String -> Maybe Tool
    readTool = fmap readC
     where readC str = case str of
            "GHC" -> GHC
            "HUGS" -> HUGS
            "NHC98" -> NHC98
            "YHC" -> YHC
            "HADDOCK" -> HADDOCK
            _ -> UnknownTool str

    checkField :: PFieldUpdate L -> P (S.FieldUpdate L)
    checkField (FieldUpdate l n e) = check1Expr e (S.FieldUpdate l n)
    checkField (FieldPun l n) = return $ S.FieldPun l n
    checkField (FieldWildcard l) = return $ S.FieldWildcard l

    getGConName :: S.Exp L -> P (QName L)
    getGConName (S.Con _ n) = return n
    getGConName (S.List l []) = return (list_cons_name l)
    getGConName _ = fail "Expression in reification is not a name"

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

    checkValDef :: L -> PExp L -> Maybe (S.Type L) -> Rhs L -> Maybe (Binds L) -> P (Decl L)
    checkValDef l lhs optsig rhs whereBinds = do
        mlhs <- isFunLhs lhs []
        let whpt = srcInfoPoints l
        case mlhs of
         Just (f,es,b,pts) -> do
                ps <- mapM checkPattern es
                let l' = l { srcInfoPoints = pts ++ whpt }
                case optsig of -- only pattern bindings can have signatures
                    Nothing -> return (FunBind l $
                                if b then [Match l' f ps rhs whereBinds]
                                     else let (a:bs) = ps
                                           in [InfixMatch l' a f bs rhs whereBinds])
                    Just _  -> fail "Cannot give an explicit type signature to a function binding"
         Nothing     -> do
                lhs <- checkPattern lhs
                return (PatBind l lhs optsig rhs whereBinds)

    -- A variable binding is parsed as a PatBind.

    isFunLhs :: PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [S]))
    isFunLhs (InfixApp ll l (QVarOp loc (UnQual _ op)) r) es
        | op =~= (Symbol () "!") = do
            exts <- getExtensions
            if BangPatterns `elem` exts
             then let (b,bs) = splitBang r []
                   in isFunLhs l (BangPat loc b : bs ++ es)
             else return $ Just (op, l:r:es, False, []) -- It's actually a definition of the operator !
        | otherwise = return $ Just (op, l:r:es, False, [])
    isFunLhs (App _ (Var _ (UnQual _ f)) e) es = return $ Just (f, e:es, True, [])
    isFunLhs (App _ f e) es = isFunLhs f (e:es)
    isFunLhs (Var _ (UnQual _ f)) es@(_:_) = return $ Just (f, es, True, [])
    isFunLhs (Paren l f) es@(_:_) = do mlhs <- isFunLhs f es
                                       case mlhs of
                                        Just (f,es,b,pts) ->
                                           let [x,y] = srcInfoPoints l
                                            in return $ Just (f,es,b,x:pts++[y])
                                        _ -> return Nothing
    isFunLhs _ _ = return Nothing

    -- Separating between signature declarations and value definitions in
    -- a post-processing step

    checkSigVar :: PExp L -> P (Name L)
    checkSigVar (Var _ (UnQual _ n)) = return n
    checkSigVar e = fail $ "Left-hand side of type signature is not a variable: " ++ prettyPrint e

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

    checkClassBody :: [ClassDecl L] -> P [ClassDecl L]
    checkClassBody decls = do
        mapM_ checkClassMethodDef decls
        return decls
      where checkClassMethodDef (ClsDecl _ decl) = checkMethodDef decl
            checkClassMethodDef _ = return ()

    checkInstBody :: [InstDecl L] -> P [InstDecl L]
    checkInstBody decls = do
        mapM_ checkInstMethodDef decls
        return decls
      where checkInstMethodDef (InsDecl _ decl) = checkMethodDef decl
            checkInstMethodDef _ = return ()

    checkMethodDef :: Decl L -> P ()
    checkMethodDef (PatBind _ (PVar _ _) _ _ _) = return ()
    checkMethodDef (PatBind loc _ _ _ _) =
        fail "illegal method definition" -- `atSrcLoc` loc
    checkMethodDef _ = return ()

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

    checkUnQual :: QName L -> P (Name L)
    checkUnQual (Qual  _ _ _) = fail "Illegal qualified name"
    checkUnQual (UnQual  _ n) = return n
    checkUnQual (Special _ _) = fail "Illegal special name"

    -----------------------------------------------------------------------------
    -- Check that two xml tag names are equal
    checkEqNames :: XName L -> XName L -> P (XName L)
    checkEqNames n@(XName _ n1) (XName _ n2)
        | n1 == n2  = return n
    checkEqNames n@(XDomName _ d1 n1) (XDomName _ d2 n2)
        | n1 == n2 && d1 == d2 = return n
    checkEqNames n m = fail $ "opening tag '" ++ showTag n ++
                       "' does not match closing tag '" ++ showTag m ++ "'"
        where
            showTag (XName _ n) = n
            showTag (XDomName _ d n) = d ++ ":" ++ n

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

    checkPrec :: Integer -> P Int
    checkPrec i | 0 <= i && i <= 9 = return (fromInteger i)
    checkPrec i | otherwise        = fail ("Illegal precedence " ++ show i)

    mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L)
    mkRecConstrOrUpdate (Con l c) fs       = return (RecConstr l c fs)
    mkRecConstrOrUpdate e         fs@(_:_) = return (RecUpdate (ann e) e fs)
    mkRecConstrOrUpdate _         _        = fail "Empty record update"

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

    checkRevDecls :: [Decl L] -> P [Decl L]
    checkRevDecls = mergeFunBinds []
        where
        mergeFunBinds revDs [] = return revDs
        mergeFunBinds revDs (FunBind l ms1@(Match _ name ps _ _:_):ds1) =
            mergeMatches ms1 ds1 l
            where
            arity = length ps
            mergeMatches ms' (FunBind _ ms@(Match loc name' ps' _ _:_):ds) l
                | name' =~= name =
                if length ps' /= arity
                then fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
                        -- `atSrcLoc` loc
                else mergeMatches (ms++ms') ds (loc <++> l)
            mergeMatches ms' ds l = mergeFunBinds (FunBind l ms':revDs) ds
        mergeFunBinds revDs (FunBind l ims1@(InfixMatch _ _ name _ _ _:_):ds1) =
            mergeInfix ims1 ds1 l
            where
            mergeInfix ims' (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_):ds) l
                | name' =~= name =
                mergeInfix (ims++ims') ds (loc <++> l)
            mergeInfix ms' ds l = mergeFunBinds (FunBind l ms':revDs) ds
        mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds

    checkRevClsDecls :: [ClassDecl L] -> P [ClassDecl L]
    checkRevClsDecls = mergeClsFunBinds []
        where
        mergeClsFunBinds revDs [] = return revDs
        mergeClsFunBinds revDs (ClsDecl l (FunBind _ ms1@(Match _ name ps _ _:_)):ds1) =
            mergeMatches ms1 ds1 l
            where
            arity = length ps
            mergeMatches ms' (ClsDecl _ (FunBind _ ms@(Match loc name' ps' _ _:_)):ds) l
                | name' =~= name =
                if length ps' /= arity
                then fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
                        -- `atSrcLoc` loc
                else mergeMatches (ms++ms') ds (loc <++> l)
            mergeMatches ms' ds l = mergeClsFunBinds (ClsDecl l (FunBind l ms'):revDs) ds
        mergeClsFunBinds revDs (ClsDecl l (FunBind _ ims1@(InfixMatch _ _ name _ _ _:_)):ds1) =
            mergeInfix ims1 ds1 l
            where
            mergeInfix ims' (ClsDecl _ (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_)):ds) l
                | name' =~= name =
                mergeInfix (ims++ims') ds (loc <++> l)
            mergeInfix ms' ds l = mergeClsFunBinds (ClsDecl l (FunBind l ms'):revDs) ds
        mergeClsFunBinds revDs (d:ds) = mergeClsFunBinds (d:revDs) ds

    checkRevInstDecls :: [InstDecl L] -> P [InstDecl L]
    checkRevInstDecls = mergeInstFunBinds []
        where
        mergeInstFunBinds :: [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
        mergeInstFunBinds revDs [] = return revDs
        mergeInstFunBinds revDs (InsDecl l (FunBind _ ms1@(Match _ name ps _ _:_)):ds1) =
            mergeMatches ms1 ds1 l
            where
            arity = length ps
            mergeMatches ms' (InsDecl _ (FunBind _ ms@(Match loc name' ps' _ _:_)):ds) l
                | name' =~= name =
                if length ps' /= arity
                then fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
                        -- `atSrcLoc` loc
                else mergeMatches (ms++ms') ds (loc <++> l)
            mergeMatches ms' ds l = mergeInstFunBinds (InsDecl l (FunBind l ms'):revDs) ds
        mergeInstFunBinds revDs (InsDecl l (FunBind _ ims1@(InfixMatch _ _ name _ _ _:_)):ds1) =
            mergeInfix ims1 ds1 l
            where
            mergeInfix ims' (InsDecl _ (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_)):ds) l
                | name' =~= name =
                mergeInfix (ims++ims') ds (loc <++> l)
            mergeInfix ms' ds l = mergeInstFunBinds (InsDecl l (FunBind l ms'):revDs) ds
        mergeInstFunBinds revDs (d:ds) = mergeInstFunBinds (d:revDs) ds

    ----------------------------------------------------------------
    -- Check that newtype declarations have
    -- the right number (1) of constructors

    checkDataOrNew :: DataOrNew L -> [a] -> P ()
    checkDataOrNew (NewType _) [x] = return ()
    checkDataOrNew (DataType _) _  = return ()
    checkDataOrNew _        _  = fail "newtype declaration must have exactly one constructor."

    checkSimpleType :: PType L -> P (DeclHead L)
    checkSimpleType t = checkSimple "test" t []

    ---------------------------------------
    -- Check actual types

    checkType :: PType L -> P (S.Type L)
    checkType t = checkT t False

    checkT :: PType L -> Bool -> P (S.Type L)
    checkT t simple = case t of
        TyForall l tvs@Nothing cs pt    -> do
                when (simple) $ checkEnabled ExplicitForall
                ctxt <- checkContext cs
                check1Type pt (S.TyForall l Nothing ctxt)
        TyForall l tvs cs pt -> do
                checkEnabled ExplicitForall
                ctxt <- checkContext cs
                check1Type pt (S.TyForall l tvs ctxt)
        TyFun   l at rt   -> check2Types at rt (S.TyFun l)
        TyTuple l b pts   -> checkTypes pts >>= return . S.TyTuple l b
        TyList  l pt      -> check1Type pt (S.TyList l)
        TyApp   l ft at   -> check2Types ft at (S.TyApp l)
        TyVar   l n       -> return $ S.TyVar l n
        TyCon   l n       -> do
                when (isSymbol n) $ checkEnabled TypeOperators
                return $ S.TyCon l n
        TyParen l pt      -> check1Type pt (S.TyParen l)
        -- Here we know that t will be used as an actual type (and not a data constructor)
        -- so we can check that TypeOperators are enabled.
        TyInfix l at op bt -> checkEnabled TypeOperators >> check2Types at bt (flip (S.TyInfix l) op)
        TyKind  l pt k    -> check1Type pt (flip (S.TyKind l) k)

        -- TyPred  cannot be a valid type
        _   -> fail $ "Parse error in type: " ++ prettyPrint t

    check1Type :: PType L -> (S.Type L -> S.Type L) -> P (S.Type L)
    check1Type pt f = checkT pt True >>= return . f

    check2Types :: PType L -> PType L -> (S.Type L -> S.Type L -> S.Type L) -> P (S.Type L)
    check2Types at bt f = checkT at True >>= \a -> checkT bt True >>= \b -> return (f a b)

    checkTypes :: [PType L] -> P [S.Type L]
    checkTypes = mapM (flip checkT True)

    ---------------------------------------
    -- Converting a complete page

    checkPageModule :: PExp L -> ([ModulePragma L],[S],L) -> P (Module L)
    checkPageModule xml (os,ss,inf) = do
        mod <- getModuleName
        xml <- checkExpr xml
        case xml of
            S.XTag  l xn ats mattr cs -> return $ XmlPage (inf<++>l<**(srcInfoPoints l ++ ss)) (ModuleName l mod) os xn ats mattr cs
            S.XETag l xn ats mattr    -> return $ XmlPage (inf<++>l<**(srcInfoPoints l ++ ss)) (ModuleName l mod) os xn ats mattr []

    checkHybridModule :: PExp L -> Module L -> S -> S -> P (Module L)
    checkHybridModule xml (Module inf mh os is ds) s1 s2 = do
        xml <- checkExpr xml
        case xml of
            S.XTag  l xn ats mattr cs -> return $ XmlHybrid (inf<++>l<**(s1 : srcInfoPoints inf ++ s2 : srcInfoPoints l))
                                                    mh os is ds xn ats mattr cs
            S.XETag l xn ats mattr    -> return $ XmlHybrid (inf<++>l<**(s1 : srcInfoPoints inf ++ s2 : srcInfoPoints l))
                                                    mh os is ds xn ats mattr []

    ---------------------------------------
    -- Handle dash-identifiers

    mkDVar :: [String] -> String
    mkDVar = concat . intersperse "-"

    ---------------------------------------
    -- Combine adjacent for-alls. NO!
    --
    -- A valid type must have one for-all at the top of the type, or of the fn arg types

    mkTyForall :: L -> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
    mkTyForall l mtvs ctxt ty = TyForall l mtvs ctxt ty