module Language.Haskell.ParseUtils (
splitTyConApp
, mkRecConstrOrUpdate
, checkPrec
, checkContext
, checkAssertion
, checkDataHeader
, checkClassHeader
, checkInstHeader
, checkPattern
, checkExpr
, checkValDef
, checkClassBody
, checkUnQual
, checkRevDecls
) where
import Language.Haskell.ParseMonad
import Language.Haskell.Pretty
import Language.Haskell.Syntax
splitTyConApp :: HsType -> P (HsName,[HsType])
splitTyConApp :: HsType -> P (HsName, [HsType])
splitTyConApp t0 :: 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 t :: HsType
t u :: HsType
u) ts :: [HsType]
ts = HsType -> [HsType] -> P (HsName, [HsType])
split HsType
t (HsType
uHsType -> [HsType] -> [HsType]
forall a. a -> [a] -> [a]
:[HsType]
ts)
split (HsTyCon (UnQual t :: HsName
t)) ts :: [HsType]
ts = (HsName, [HsType]) -> P (HsName, [HsType])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsName
t,[HsType]
ts)
split _ _ = String -> P (HsName, [HsType])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal data/newtype declaration"
checkContext :: HsType -> P HsContext
checkContext :: HsType -> P HsContext
checkContext (HsTyTuple ts :: [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)
mapM HsType -> P HsAsst
checkAssertion [HsType]
ts
checkContext t :: HsType
t = do
HsAsst
c <- HsType -> P HsAsst
checkAssertion HsType
t
HsContext -> P HsContext
forall (m :: * -> *) a. Monad m => a -> m a
return [HsAsst
c]
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' ts :: [HsType]
ts (HsTyCon c :: HsQName
c) = HsAsst -> m HsAsst
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQName
c,[HsType]
ts)
checkAssertion' ts :: [HsType]
ts (HsTyApp a :: HsType
a t :: HsType
t) = [HsType] -> HsType -> m HsAsst
checkAssertion' (HsType
tHsType -> [HsType] -> [HsType]
forall a. a -> [a] -> [a]
:[HsType]
ts) HsType
a
checkAssertion' _ _ = String -> m HsAsst
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal class assertion"
checkDataHeader :: HsQualType -> P (HsContext,HsName,[HsName])
(HsQualType cs :: HsContext
cs t :: HsType
t) = do
(c :: HsName
c,ts :: [HsName]
ts) <- String -> HsType -> [HsName] -> P (HsName, [HsName])
checkSimple "data/newtype" HsType
t []
(HsContext, HsName, [HsName]) -> P (HsContext, HsName, [HsName])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsContext
cs,HsName
c,[HsName]
ts)
checkClassHeader :: HsQualType -> P (HsContext,HsName,[HsName])
(HsQualType cs :: HsContext
cs t :: HsType
t) = do
(c :: HsName
c,ts :: [HsName]
ts) <- String -> HsType -> [HsName] -> P (HsName, [HsName])
checkSimple "class" HsType
t []
(HsContext, HsName, [HsName]) -> P (HsContext, HsName, [HsName])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsContext
cs,HsName
c,[HsName]
ts)
checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName]))
checkSimple :: String -> HsType -> [HsName] -> P (HsName, [HsName])
checkSimple kw :: String
kw (HsTyApp l :: HsType
l (HsTyVar a :: HsName
a)) xs :: [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 _kw :: String
_kw (HsTyCon (UnQual t :: HsName
t)) xs :: [HsName]
xs = (HsName, [HsName]) -> P (HsName, [HsName])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsName
t,[HsName]
xs)
checkSimple kw :: String
kw _ _ = String -> P (HsName, [HsName])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Illegal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kw String -> String -> String
forall a. [a] -> [a] -> [a]
++ " declaration")
checkInstHeader :: HsQualType -> P (HsContext,HsQName,[HsType])
(HsQualType cs :: HsContext
cs t :: HsType
t) = do
(c :: HsQName
c,ts :: [HsType]
ts) <- HsType -> [HsType] -> P HsAsst
checkInsts HsType
t []
(HsContext, HsQName, [HsType]) -> P (HsContext, HsQName, [HsType])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsContext
cs,HsQName
c,[HsType]
ts)
checkInsts :: HsType -> [HsType] -> P ((HsQName,[HsType]))
checkInsts :: HsType -> [HsType] -> P HsAsst
checkInsts (HsTyApp l :: HsType
l t :: HsType
t) ts :: [HsType]
ts = HsType -> [HsType] -> P HsAsst
checkInsts HsType
l (HsType
tHsType -> [HsType] -> [HsType]
forall a. a -> [a] -> [a]
:[HsType]
ts)
checkInsts (HsTyCon c :: HsQName
c) ts :: [HsType]
ts = HsAsst -> P HsAsst
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQName
c,[HsType]
ts)
checkInsts _ _ = String -> P HsAsst
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal instance declaration"
checkPattern :: HsExp -> P HsPat
checkPattern :: HsExp -> P HsPat
checkPattern e :: HsExp
e = HsExp -> [HsPat] -> P HsPat
checkPat HsExp
e []
checkPat :: HsExp -> [HsPat] -> P HsPat
checkPat :: HsExp -> [HsPat] -> P HsPat
checkPat (HsCon c :: HsQName
c) args :: [HsPat]
args = HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQName -> [HsPat] -> HsPat
HsPApp HsQName
c [HsPat]
args)
checkPat (HsApp f :: HsExp
f x :: HsExp
x) args :: [HsPat]
args = do
HsPat
x' <- HsExp -> [HsPat] -> P HsPat
checkPat HsExp
x []
HsExp -> [HsPat] -> P HsPat
checkPat HsExp
f (HsPat
x'HsPat -> [HsPat] -> [HsPat]
forall a. a -> [a] -> [a]
:[HsPat]
args)
checkPat e :: HsExp
e [] = case HsExp
e of
HsVar (UnQual x :: HsName
x) -> HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsName -> HsPat
HsPVar HsName
x)
HsLit l :: HsLiteral
l -> HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLiteral -> HsPat
HsPLit HsLiteral
l)
HsInfixApp l :: HsExp
l op :: HsQOp
op r :: HsExp
r -> do
HsPat
l' <- HsExp -> [HsPat] -> P HsPat
checkPat HsExp
l []
HsPat
r' <- HsExp -> [HsPat] -> P HsPat
checkPat HsExp
r []
case HsQOp
op of
HsQConOp c :: HsQName
c -> HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsPat -> HsQName -> HsPat -> HsPat
HsPInfixApp HsPat
l' HsQName
c HsPat
r')
_ -> P HsPat
forall a. P a
patFail
HsTuple es :: [HsExp]
es -> do
[HsPat]
ps <- (HsExp -> P HsPat) -> [HsExp] -> P [HsPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\e' :: HsExp
e' -> HsExp -> [HsPat] -> P HsPat
checkPat HsExp
e' []) [HsExp]
es
HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsPat] -> HsPat
HsPTuple [HsPat]
ps)
HsList es :: [HsExp]
es -> do
[HsPat]
ps <- (HsExp -> P HsPat) -> [HsExp] -> P [HsPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\e' :: HsExp
e' -> HsExp -> [HsPat] -> P HsPat
checkPat HsExp
e' []) [HsExp]
es
HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsPat] -> HsPat
HsPList [HsPat]
ps)
HsParen e' :: HsExp
e' -> do
HsPat
p <- HsExp -> [HsPat] -> P HsPat
checkPat HsExp
e' []
HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsPat -> HsPat
HsPParen HsPat
p)
HsAsPat n :: HsName
n e' :: HsExp
e' -> do
HsPat
p <- HsExp -> [HsPat] -> P HsPat
checkPat HsExp
e' []
HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsName -> HsPat -> HsPat
HsPAsPat HsName
n HsPat
p)
HsWildCard -> HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return HsPat
HsPWildCard
HsIrrPat e' :: HsExp
e' -> do
HsPat
p <- HsExp -> [HsPat] -> P HsPat
checkPat HsExp
e' []
HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsPat -> HsPat
HsPIrrPat HsPat
p)
HsRecConstr c :: HsQName
c fs :: [HsFieldUpdate]
fs -> do
[HsPatField]
fs' <- (HsFieldUpdate -> P HsPatField)
-> [HsFieldUpdate] -> P [HsPatField]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsFieldUpdate -> P HsPatField
checkPatField [HsFieldUpdate]
fs
HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQName -> [HsPatField] -> HsPat
HsPRec HsQName
c [HsPatField]
fs')
HsNegApp (HsLit l :: HsLiteral
l) -> HsPat -> P HsPat
forall (m :: * -> *) a. Monad m => a -> m a
return (HsPat -> HsPat
HsPNeg (HsLiteral -> HsPat
HsPLit HsLiteral
l))
_ -> P HsPat
forall a. P a
patFail
checkPat _ _ = P HsPat
forall a. P a
patFail
checkPatField :: HsFieldUpdate -> P HsPatField
checkPatField :: HsFieldUpdate -> P HsPatField
checkPatField (HsFieldUpdate n :: HsQName
n e :: HsExp
e) = do
HsPat
p <- HsExp -> [HsPat] -> P HsPat
checkPat HsExp
e []
HsPatField -> P HsPatField
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQName -> HsPat -> HsPatField
HsPFieldPat HsQName
n HsPat
p)
patFail :: P a
patFail :: P a
patFail = String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Parse error in pattern"
checkExpr :: HsExp -> P HsExp
checkExpr :: HsExp -> P HsExp
checkExpr e :: HsExp
e = case HsExp
e of
HsVar _ -> HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return HsExp
e
HsCon _ -> HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return HsExp
e
HsLit _ -> HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return HsExp
e
HsInfixApp e1 :: HsExp
e1 op :: HsQOp
op e2 :: 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 e1 :: HsExp
e1 e2 :: 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 e1 :: HsExp
e1 -> HsExp -> (HsExp -> HsExp) -> P HsExp
forall a. HsExp -> (HsExp -> a) -> P a
check1Expr HsExp
e1 HsExp -> HsExp
HsNegApp
HsLambda loc :: SrcLoc
loc ps :: [HsPat]
ps e1 :: 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 bs :: [HsDecl]
bs e1 :: HsExp
e1 -> HsExp -> (HsExp -> HsExp) -> P HsExp
forall a. HsExp -> (HsExp -> a) -> P a
check1Expr HsExp
e1 ([HsDecl] -> HsExp -> HsExp
HsLet [HsDecl]
bs)
HsIf e1 :: HsExp
e1 e2 :: HsExp
e2 e3 :: 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 e1 :: HsExp
e1 alts :: [HsAlt]
alts -> do
[HsAlt]
alts' <- (HsAlt -> P HsAlt) -> [HsAlt] -> P [HsAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsAlt -> P HsAlt
checkAlt [HsAlt]
alts
HsExp
e1' <- HsExp -> P HsExp
checkExpr HsExp
e1
HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExp -> [HsAlt] -> HsExp
HsCase HsExp
e1' [HsAlt]
alts')
HsDo stmts :: [HsStmt]
stmts -> do
[HsStmt]
stmts' <- (HsStmt -> P HsStmt) -> [HsStmt] -> P [HsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsStmt -> P HsStmt
checkStmt [HsStmt]
stmts
HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsStmt] -> HsExp
HsDo [HsStmt]
stmts')
HsTuple es :: [HsExp]
es -> [HsExp] -> ([HsExp] -> HsExp) -> P HsExp
forall a. [HsExp] -> ([HsExp] -> a) -> P a
checkManyExprs [HsExp]
es [HsExp] -> HsExp
HsTuple
HsList es :: [HsExp]
es -> [HsExp] -> ([HsExp] -> HsExp) -> P HsExp
forall a. [HsExp] -> ([HsExp] -> a) -> P a
checkManyExprs [HsExp]
es [HsExp] -> HsExp
HsList
HsParen e1 :: HsExp
e1 -> HsExp -> (HsExp -> HsExp) -> P HsExp
forall a. HsExp -> (HsExp -> a) -> P a
check1Expr HsExp
e1 HsExp -> HsExp
HsParen
HsLeftSection e1 :: HsExp
e1 op :: 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 op :: HsQOp
op e1 :: HsExp
e1 -> HsExp -> (HsExp -> HsExp) -> P HsExp
forall a. HsExp -> (HsExp -> a) -> P a
check1Expr HsExp
e1 (HsQOp -> HsExp -> HsExp
HsRightSection HsQOp
op)
HsRecConstr c :: HsQName
c fields :: [HsFieldUpdate]
fields -> do
[HsFieldUpdate]
fields' <- (HsFieldUpdate -> P HsFieldUpdate)
-> [HsFieldUpdate] -> P [HsFieldUpdate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsFieldUpdate -> P HsFieldUpdate
checkField [HsFieldUpdate]
fields
HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQName -> [HsFieldUpdate] -> HsExp
HsRecConstr HsQName
c [HsFieldUpdate]
fields')
HsRecUpdate e1 :: HsExp
e1 fields :: [HsFieldUpdate]
fields -> do
[HsFieldUpdate]
fields' <- (HsFieldUpdate -> P HsFieldUpdate)
-> [HsFieldUpdate] -> P [HsFieldUpdate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsFieldUpdate -> P HsFieldUpdate
checkField [HsFieldUpdate]
fields
HsExp
e1' <- HsExp -> P HsExp
checkExpr HsExp
e1
HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExp -> [HsFieldUpdate] -> HsExp
HsRecUpdate HsExp
e1' [HsFieldUpdate]
fields')
HsEnumFrom e1 :: HsExp
e1 -> HsExp -> (HsExp -> HsExp) -> P HsExp
forall a. HsExp -> (HsExp -> a) -> P a
check1Expr HsExp
e1 HsExp -> HsExp
HsEnumFrom
HsEnumFromTo e1 :: HsExp
e1 e2 :: 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 e1 :: HsExp
e1 e2 :: 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 e1 :: HsExp
e1 e2 :: HsExp
e2 e3 :: 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 e1 :: HsExp
e1 stmts :: [HsStmt]
stmts -> do
[HsStmt]
stmts' <- (HsStmt -> P HsStmt) -> [HsStmt] -> P [HsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsStmt -> P HsStmt
checkStmt [HsStmt]
stmts
HsExp
e1' <- HsExp -> P HsExp
checkExpr HsExp
e1
HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExp -> [HsStmt] -> HsExp
HsListComp HsExp
e1' [HsStmt]
stmts')
HsExpTypeSig loc :: SrcLoc
loc e1 :: HsExp
e1 ty :: HsQualType
ty -> do
HsExp
e1' <- HsExp -> P HsExp
checkExpr HsExp
e1
HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcLoc -> HsExp -> HsQualType -> HsExp
HsExpTypeSig SrcLoc
loc HsExp
e1' HsQualType
ty)
_ -> String -> P HsExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Parse error in expression"
check1Expr :: HsExp -> (HsExp -> a) -> P a
check1Expr :: HsExp -> (HsExp -> a) -> P a
check1Expr e1 :: HsExp
e1 f :: HsExp -> a
f = do
HsExp
e1' <- HsExp -> P HsExp
checkExpr HsExp
e1
a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExp -> a
f HsExp
e1')
check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
check2Exprs e1 :: HsExp
e1 e2 :: HsExp
e2 f :: HsExp -> HsExp -> a
f = do
HsExp
e1' <- HsExp -> P HsExp
checkExpr HsExp
e1
HsExp
e2' <- HsExp -> P HsExp
checkExpr HsExp
e2
a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExp -> HsExp -> a
f HsExp
e1' HsExp
e2')
check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
check3Exprs e1 :: HsExp
e1 e2 :: HsExp
e2 e3 :: HsExp
e3 f :: HsExp -> HsExp -> HsExp -> a
f = do
HsExp
e1' <- HsExp -> P HsExp
checkExpr HsExp
e1
HsExp
e2' <- HsExp -> P HsExp
checkExpr HsExp
e2
HsExp
e3' <- HsExp -> P HsExp
checkExpr HsExp
e3
a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExp -> HsExp -> HsExp -> a
f HsExp
e1' HsExp
e2' HsExp
e3')
checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a
checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a
checkManyExprs es :: [HsExp]
es f :: [HsExp] -> a
f = do
[HsExp]
es' <- (HsExp -> P HsExp) -> [HsExp] -> P [HsExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsExp -> P HsExp
checkExpr [HsExp]
es
a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsExp] -> a
f [HsExp]
es')
checkAlt :: HsAlt -> P HsAlt
checkAlt :: HsAlt -> P HsAlt
checkAlt (HsAlt loc :: SrcLoc
loc p :: HsPat
p galts :: HsGuardedAlts
galts bs :: [HsDecl]
bs) = do
HsGuardedAlts
galts' <- HsGuardedAlts -> P HsGuardedAlts
checkGAlts HsGuardedAlts
galts
HsAlt -> P HsAlt
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcLoc -> HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
HsAlt SrcLoc
loc HsPat
p HsGuardedAlts
galts' [HsDecl]
bs)
checkGAlts :: HsGuardedAlts -> P HsGuardedAlts
checkGAlts :: HsGuardedAlts -> P HsGuardedAlts
checkGAlts (HsUnGuardedAlt e :: HsExp
e) = HsExp -> (HsExp -> HsGuardedAlts) -> P HsGuardedAlts
forall a. HsExp -> (HsExp -> a) -> P a
check1Expr HsExp
e HsExp -> HsGuardedAlts
HsUnGuardedAlt
checkGAlts (HsGuardedAlts galts :: [HsGuardedAlt]
galts) = do
[HsGuardedAlt]
galts' <- (HsGuardedAlt -> P HsGuardedAlt)
-> [HsGuardedAlt] -> P [HsGuardedAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsGuardedAlt -> P HsGuardedAlt
checkGAlt [HsGuardedAlt]
galts
HsGuardedAlts -> P HsGuardedAlts
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsGuardedAlt] -> HsGuardedAlts
HsGuardedAlts [HsGuardedAlt]
galts')
checkGAlt :: HsGuardedAlt -> P HsGuardedAlt
checkGAlt :: HsGuardedAlt -> P HsGuardedAlt
checkGAlt (HsGuardedAlt loc :: SrcLoc
loc e1 :: HsExp
e1 e2 :: 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 loc :: SrcLoc
loc p :: HsPat
p e :: 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 e :: 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 _) = HsStmt -> P HsStmt
forall (m :: * -> *) a. Monad m => a -> m a
return HsStmt
s
checkField :: HsFieldUpdate -> P HsFieldUpdate
checkField :: HsFieldUpdate -> P HsFieldUpdate
checkField (HsFieldUpdate n :: HsQName
n e :: HsExp
e) = HsExp -> (HsExp -> HsFieldUpdate) -> P HsFieldUpdate
forall a. HsExp -> (HsExp -> a) -> P a
check1Expr HsExp
e (HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
n)
checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
checkValDef srcloc :: SrcLoc
srcloc lhs :: HsExp
lhs rhs :: HsRhs
rhs whereBinds :: [HsDecl]
whereBinds =
case HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
isFunLhs HsExp
lhs [] of
Just (f :: HsName
f,es :: [HsExp]
es) -> do
[HsPat]
ps <- (HsExp -> P HsPat) -> [HsExp] -> P [HsPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsExp -> P HsPat
checkPattern [HsExp]
es
HsDecl -> P HsDecl
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsMatch] -> HsDecl
HsFunBind [SrcLoc -> HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
HsMatch SrcLoc
srcloc HsName
f [HsPat]
ps HsRhs
rhs [HsDecl]
whereBinds])
Nothing -> do
HsPat
lhs' <- HsExp -> P HsPat
checkPattern HsExp
lhs
HsDecl -> P HsDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcLoc -> HsPat -> HsRhs -> [HsDecl] -> HsDecl
HsPatBind SrcLoc
srcloc HsPat
lhs' HsRhs
rhs [HsDecl]
whereBinds)
isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
isFunLhs (HsInfixApp l :: HsExp
l (HsQVarOp (UnQual op :: HsName
op)) r :: HsExp
r) es :: [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 f :: HsName
f)) e :: HsExp
e) es :: [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 f :: HsExp
f) e :: HsExp
e) es :: [HsExp]
es = HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
isFunLhs HsExp
f (HsExp
eHsExp -> [HsExp] -> [HsExp]
forall a. a -> [a] -> [a]
:[HsExp]
es)
isFunLhs (HsApp f :: HsExp
f e :: HsExp
e) es :: [HsExp]
es = HsExp -> [HsExp] -> Maybe (HsName, [HsExp])
isFunLhs HsExp
f (HsExp
eHsExp -> [HsExp] -> [HsExp]
forall a. a -> [a] -> [a]
:[HsExp]
es)
isFunLhs _ _ = Maybe (HsName, [HsExp])
forall a. Maybe a
Nothing
checkClassBody :: [HsDecl] -> P [HsDecl]
checkClassBody :: [HsDecl] -> P [HsDecl]
checkClassBody decls :: [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 (m :: * -> *) a. Monad m => a -> m a
return [HsDecl]
decls
checkMethodDef :: HsDecl -> P ()
checkMethodDef :: HsDecl -> P ()
checkMethodDef (HsPatBind _ (HsPVar _) _ _) = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMethodDef (HsPatBind loc :: SrcLoc
loc _ _ _) =
String -> P ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "illegal method definition" P () -> SrcLoc -> P ()
forall a. P a -> SrcLoc -> P a
`atSrcLoc` SrcLoc
loc
checkMethodDef _ = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnQual :: HsQName -> P HsName
checkUnQual :: HsQName -> P HsName
checkUnQual (Qual _ _) = String -> P HsName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal qualified name"
checkUnQual (UnQual n :: HsName
n) = HsName -> P HsName
forall (m :: * -> *) a. Monad m => a -> m a
return HsName
n
checkUnQual (Special _) = String -> P HsName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal special name"
checkPrec :: Integer -> P Int
checkPrec :: Integer -> P Int
checkPrec i :: Integer
i | 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
<= 9 = Int -> P Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
checkPrec i :: Integer
i | Bool
otherwise = String -> P Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("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 c :: HsQName
c) fs :: [HsFieldUpdate]
fs = HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQName -> [HsFieldUpdate] -> HsExp
HsRecConstr HsQName
c [HsFieldUpdate]
fs)
mkRecConstrOrUpdate e :: HsExp
e fs :: [HsFieldUpdate]
fs@(_:_) = HsExp -> P HsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExp -> [HsFieldUpdate] -> HsExp
HsRecUpdate HsExp
e [HsFieldUpdate]
fs)
mkRecConstrOrUpdate _ _ = String -> P HsExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Empty record update"
checkRevDecls :: [HsDecl] -> P [HsDecl]
checkRevDecls :: [HsDecl] -> P [HsDecl]
checkRevDecls = [HsDecl] -> [HsDecl] -> P [HsDecl]
mergeFunBinds []
where
mergeFunBinds :: [HsDecl] -> [HsDecl] -> P [HsDecl]
mergeFunBinds revDs :: [HsDecl]
revDs [] = [HsDecl] -> P [HsDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [HsDecl]
revDs
mergeFunBinds revDs :: [HsDecl]
revDs (HsFunBind ms1 :: [HsMatch]
ms1@(HsMatch _ name :: HsName
name ps :: [HsPat]
ps _ _:_):ds1 :: [HsDecl]
ds1) =
[HsMatch] -> [HsDecl] -> P [HsDecl]
mergeMatches [HsMatch]
ms1 [HsDecl]
ds1
where
arity :: Int
arity = [HsPat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsPat]
ps
mergeMatches :: [HsMatch] -> [HsDecl] -> P [HsDecl]
mergeMatches ms' :: [HsMatch]
ms' (HsFunBind ms :: [HsMatch]
ms@(HsMatch loc :: SrcLoc
loc name' :: HsName
name' ps' :: [HsPat]
ps' _ _:_):ds :: [HsDecl]
ds)
| HsName
name' HsName -> HsName -> Bool
forall a. Eq a => a -> a -> Bool
== HsName
name =
if [HsPat] -> 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 (m :: * -> *) a. MonadFail m => String -> m a
fail ("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]
++ "'")
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 ms' :: [HsMatch]
ms' ds :: [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 revDs :: [HsDecl]
revDs (d :: HsDecl
d:ds :: [HsDecl]
ds) = [HsDecl] -> [HsDecl] -> P [HsDecl]
mergeFunBinds (HsDecl
dHsDecl -> [HsDecl] -> [HsDecl]
forall a. a -> [a] -> [a]
:[HsDecl]
revDs) [HsDecl]
ds