-----------------------------------------------------------------------------
-- |
-- 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