{- |
    Module      :  $Header$
    Description :  Checks precedences of infix operators
    Copyright   :  (c) 2001 - 2004 Wolfgang Lux
                                   Martin Engelke
                                   Björn Peemöller
                       2015        Jan Tikovsky
                       2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   The parser does not know the relative precedences of infix operators
   and therefore parses them as if they all associate to the right and
   have the same precedence. After performing the definition checks,
   the compiler is going to process the infix applications in the module
   and rearrange infix applications according to the relative precedences
   of the operators involved.
-}
{-# LANGUAGE CPP #-}
module Checks.PrecCheck (precCheck) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative      ((<$>), (<*>))
#endif
import           Control.Monad            (unless, when)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import           Data.List                (partition)

import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.SpanInfo
import Curry.Base.Span
import Curry.Base.Pretty
import Curry.Syntax

import Base.Expr
import Base.Messages (Message, posMessage, internalError)
import Base.Utils    (findMultiples)

import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
  , mkPrec, qualLookupP)

precCheck :: ModuleIdent -> OpPrecEnv -> [Decl a] -> ([Decl a], OpPrecEnv, [Message])
precCheck :: ModuleIdent
-> OpPrecEnv -> [Decl a] -> ([Decl a], OpPrecEnv, [Message])
precCheck m :: ModuleIdent
m pEnv :: OpPrecEnv
pEnv decls :: [Decl a]
decls = PCM [Decl a] -> PCState -> ([Decl a], OpPrecEnv, [Message])
forall a. PCM a -> PCState -> (a, OpPrecEnv, [Message])
runPCM ([Decl a] -> PCM [Decl a]
forall a. [Decl a] -> PCM [Decl a]
checkDecls [Decl a]
decls) PCState
initState
 where initState :: PCState
initState = ModuleIdent -> OpPrecEnv -> [Message] -> PCState
PCState ModuleIdent
m OpPrecEnv
pEnv []

data PCState = PCState
  { PCState -> ModuleIdent
moduleIdent :: ModuleIdent
  , PCState -> OpPrecEnv
precEnv     :: OpPrecEnv
  , PCState -> [Message]
errors      :: [Message]
  }

type PCM = S.State PCState -- the Prec Check Monad

runPCM :: PCM a -> PCState -> (a, OpPrecEnv, [Message])
runPCM :: PCM a -> PCState -> (a, OpPrecEnv, [Message])
runPCM kcm :: PCM a
kcm s :: PCState
s = let (a :: a
a, s' :: PCState
s') = PCM a -> PCState -> (a, PCState)
forall s a. State s a -> s -> (a, s)
S.runState PCM a
kcm PCState
s
               in  (a
a, PCState -> OpPrecEnv
precEnv PCState
s', [Message] -> [Message]
forall a. [a] -> [a]
reverse ([Message] -> [Message]) -> [Message] -> [Message]
forall a b. (a -> b) -> a -> b
$ PCState -> [Message]
errors PCState
s')

getModuleIdent :: PCM ModuleIdent
getModuleIdent :: PCM ModuleIdent
getModuleIdent = (PCState -> ModuleIdent) -> PCM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets PCState -> ModuleIdent
moduleIdent

getPrecEnv :: PCM OpPrecEnv
getPrecEnv :: PCM OpPrecEnv
getPrecEnv = (PCState -> OpPrecEnv) -> PCM OpPrecEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets PCState -> OpPrecEnv
precEnv

modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> PCM ()
modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> PCM ()
modifyPrecEnv f :: OpPrecEnv -> OpPrecEnv
f = (PCState -> PCState) -> PCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((PCState -> PCState) -> PCM ()) -> (PCState -> PCState) -> PCM ()
forall a b. (a -> b) -> a -> b
$ \ s :: PCState
s -> PCState
s { precEnv :: OpPrecEnv
precEnv = OpPrecEnv -> OpPrecEnv
f (OpPrecEnv -> OpPrecEnv) -> OpPrecEnv -> OpPrecEnv
forall a b. (a -> b) -> a -> b
$ PCState -> OpPrecEnv
precEnv PCState
s }

withLocalPrecEnv :: PCM a -> PCM a
withLocalPrecEnv :: PCM a -> PCM a
withLocalPrecEnv act :: PCM a
act = do
  OpPrecEnv
oldEnv <- PCM OpPrecEnv
getPrecEnv
  a
res <- PCM a
act
  (OpPrecEnv -> OpPrecEnv) -> PCM ()
modifyPrecEnv ((OpPrecEnv -> OpPrecEnv) -> PCM ())
-> (OpPrecEnv -> OpPrecEnv) -> PCM ()
forall a b. (a -> b) -> a -> b
$ OpPrecEnv -> OpPrecEnv -> OpPrecEnv
forall a b. a -> b -> a
const OpPrecEnv
oldEnv
  a -> PCM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

report :: Message -> PCM ()
report :: Message -> PCM ()
report err :: Message
err = (PCState -> PCState) -> PCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify (\ s :: PCState
s -> PCState
s { errors :: [Message]
errors = Message
err Message -> [Message] -> [Message]
forall a. a -> [a] -> [a]
: PCState -> [Message]
errors PCState
s })

-- For each declaration group, including the module-level, the compiler
-- first checks that its fixity declarations contain no duplicates and
-- that there is a corresponding value or constructor declaration in that
-- group. The fixity declarations are then used for extending the
-- imported precedence environment.

bindPrecs :: [Decl a] -> PCM ()
bindPrecs :: [Decl a] -> PCM ()
bindPrecs ds0 :: [Decl a]
ds0 = case [Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
opFixDecls of
  [] -> case (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
bvs) [Ident]
opFixDecls of
    []  -> do
      ModuleIdent
m <- PCM ModuleIdent
getModuleIdent
      (OpPrecEnv -> OpPrecEnv) -> PCM ()
modifyPrecEnv ((OpPrecEnv -> OpPrecEnv) -> PCM ())
-> (OpPrecEnv -> OpPrecEnv) -> PCM ()
forall a b. (a -> b) -> a -> b
$ \env :: OpPrecEnv
env -> (Decl a -> OpPrecEnv -> OpPrecEnv)
-> OpPrecEnv -> [Decl a] -> OpPrecEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Decl a -> OpPrecEnv -> OpPrecEnv
forall a. ModuleIdent -> Decl a -> OpPrecEnv -> OpPrecEnv
bindPrec ModuleIdent
m) OpPrecEnv
env [Decl a]
fixDs
    ops :: [Ident]
ops -> (Ident -> PCM ()) -> [Ident] -> PCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> PCM ()
report (Message -> PCM ()) -> (Ident -> Message) -> Ident -> PCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Message
errUndefinedOperator) [Ident]
ops
  opss :: [[Ident]]
opss -> ([Ident] -> PCM ()) -> [[Ident]] -> PCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> PCM ()
report (Message -> PCM ()) -> ([Ident] -> Message) -> [Ident] -> PCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Message
errMultiplePrecedence) [[Ident]]
opss
  where
    (fixDs :: [Decl a]
fixDs, nonFixDs :: [Decl a]
nonFixDs) = (Decl a -> Bool) -> [Decl a] -> ([Decl a], [Decl a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Decl a -> Bool
forall a. Decl a -> Bool
isInfixDecl [Decl a]
ds0
    innerDs :: [Decl a]
innerDs           = [ Decl a
d | ClassDecl _ _ _ _ ds :: [Decl a]
ds <- [Decl a]
ds0, Decl a
d <- [Decl a]
ds ]
    opFixDecls :: [Ident]
opFixDecls        = [ Ident
op | InfixDecl _ _ _ ops :: [Ident]
ops <- [Decl a]
fixDs, Ident
op <- [Ident]
ops ]
    -- Unrenaming is necessary for inner class declarations, because operators
    -- within class declarations have been renamed during syntax checking.
    bvs :: [Ident]
bvs               = (Decl a -> [Ident]) -> [Decl a] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl a -> [Ident]
forall a. Decl a -> [Ident]
boundValues [Decl a]
nonFixDs [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++
                          (Ident -> Ident) -> [Ident] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Ident
unRenameIdent ((Decl a -> [Ident]) -> [Decl a] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl a -> [Ident]
forall a. Decl a -> [Ident]
boundValues [Decl a]
innerDs)

bindPrec :: ModuleIdent -> Decl a -> OpPrecEnv -> OpPrecEnv
bindPrec :: ModuleIdent -> Decl a -> OpPrecEnv -> OpPrecEnv
bindPrec m :: ModuleIdent
m (InfixDecl _ fix :: Infix
fix mprec :: Maybe Precedence
mprec ops :: [Ident]
ops) pEnv :: OpPrecEnv
pEnv
  | OpPrec
p OpPrec -> OpPrec -> Bool
forall a. Eq a => a -> a -> Bool
== OpPrec
defaultP = OpPrecEnv
pEnv
  | Bool
otherwise     = (Ident -> OpPrecEnv -> OpPrecEnv)
-> OpPrecEnv -> [Ident] -> OpPrecEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Ident -> OpPrec -> OpPrecEnv -> OpPrecEnv)
-> OpPrec -> Ident -> OpPrecEnv -> OpPrecEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> Ident -> OpPrec -> OpPrecEnv -> OpPrecEnv
bindP ModuleIdent
m) OpPrec
p) OpPrecEnv
pEnv [Ident]
ops
  where p :: OpPrec
p = Infix -> Precedence -> OpPrec
OpPrec Infix
fix (Maybe Precedence -> Precedence
mkPrec Maybe Precedence
mprec)
bindPrec _ _                           pEnv :: OpPrecEnv
pEnv = OpPrecEnv
pEnv

boundValues :: Decl a -> [Ident]
boundValues :: Decl a -> [Ident]
boundValues (DataDecl     _ _ _ cs :: [ConstrDecl]
cs _) = [ Ident
v | ConstrDecl
c <- [ConstrDecl]
cs
                                            , Ident
v <- ConstrDecl -> Ident
constrId ConstrDecl
c Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: ConstrDecl -> [Ident]
recordLabels ConstrDecl
c]
boundValues (NewtypeDecl  _ _ _ nc :: NewConstrDecl
nc _) = NewConstrDecl -> Ident
nconstrId NewConstrDecl
nc Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: NewConstrDecl -> [Ident]
nrecordLabels NewConstrDecl
nc
boundValues (TypeSig          _ fs :: [Ident]
fs _) = [Ident]
fs
boundValues (FunctionDecl    _ _ f :: Ident
f _) = [Ident
f]
boundValues (ExternalDecl       _ vs :: [Var a]
vs) = [Var a] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Var a]
vs
boundValues (PatternDecl       _ t :: Pattern a
t _) = Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
t
boundValues (FreeDecl           _ vs :: [Var a]
vs) = [Var a] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Var a]
vs
boundValues _                         = []

-- With the help of the precedence environment, the compiler checks all
-- infix applications and sections in the program. This pass will modify
-- the parse tree such that for a nested infix application the operator
-- with the lowest precedence becomes the root and that two adjacent
-- operators with the same precedence will not have conflicting
-- associativities. Note that the top-level precedence environment has to
-- be returned because it is needed for constructing the module's
-- interface.

checkDecls :: [Decl a] -> PCM [Decl a]
checkDecls :: [Decl a] -> PCM [Decl a]
checkDecls decls :: [Decl a]
decls = [Decl a] -> PCM ()
forall a. [Decl a] -> PCM ()
bindPrecs [Decl a]
decls PCM () -> PCM [Decl a] -> PCM [Decl a]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Decl a -> StateT PCState Identity (Decl a))
-> [Decl a] -> PCM [Decl a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl a -> StateT PCState Identity (Decl a)
forall a. Decl a -> PCM (Decl a)
checkDecl [Decl a]
decls

checkDecl :: Decl a -> PCM (Decl a)
checkDecl :: Decl a -> PCM (Decl a)
checkDecl (FunctionDecl p :: SpanInfo
p a :: a
a f :: Ident
f           eqs :: [Equation a]
eqs) =
  SpanInfo -> a -> Ident -> [Equation a] -> Decl a
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p a
a Ident
f ([Equation a] -> Decl a)
-> StateT PCState Identity [Equation a] -> PCM (Decl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Equation a -> StateT PCState Identity (Equation a))
-> [Equation a] -> StateT PCState Identity [Equation a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation a -> StateT PCState Identity (Equation a)
forall a. Equation a -> PCM (Equation a)
checkEquation [Equation a]
eqs
checkDecl (PatternDecl  p :: SpanInfo
p t :: Pattern a
t             rhs :: Rhs a
rhs) =
  SpanInfo -> Pattern a -> Rhs a -> Decl a
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p (Pattern a -> Rhs a -> Decl a)
-> StateT PCState Identity (Pattern a)
-> StateT PCState Identity (Rhs a -> Decl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t StateT PCState Identity (Rhs a -> Decl a)
-> StateT PCState Identity (Rhs a) -> PCM (Decl a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs a -> StateT PCState Identity (Rhs a)
forall a. Rhs a -> PCM (Rhs a)
checkRhs Rhs a
rhs
checkDecl (ClassDecl    p :: SpanInfo
p cx :: Context
cx cls :: Ident
cls    tv :: Ident
tv   ds :: [Decl a]
ds) =
  SpanInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
forall a.
SpanInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p Context
cx Ident
cls Ident
tv ([Decl a] -> Decl a)
-> StateT PCState Identity [Decl a] -> PCM (Decl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl a -> PCM (Decl a))
-> [Decl a] -> StateT PCState Identity [Decl a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl a -> PCM (Decl a)
forall a. Decl a -> PCM (Decl a)
checkDecl [Decl a]
ds
checkDecl (InstanceDecl p :: SpanInfo
p cx :: Context
cx qcls :: QualIdent
qcls   inst :: InstanceType
inst ds :: [Decl a]
ds) =
  SpanInfo
-> Context -> QualIdent -> InstanceType -> [Decl a] -> Decl a
forall a.
SpanInfo
-> Context -> QualIdent -> InstanceType -> [Decl a] -> Decl a
InstanceDecl SpanInfo
p Context
cx QualIdent
qcls InstanceType
inst ([Decl a] -> Decl a)
-> StateT PCState Identity [Decl a] -> PCM (Decl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl a -> PCM (Decl a))
-> [Decl a] -> StateT PCState Identity [Decl a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl a -> PCM (Decl a)
forall a. Decl a -> PCM (Decl a)
checkDecl [Decl a]
ds
checkDecl d :: Decl a
d                                  = Decl a -> PCM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl a
d

checkEquation :: Equation a -> PCM (Equation a)
checkEquation :: Equation a -> PCM (Equation a)
checkEquation (Equation p :: SpanInfo
p lhs :: Lhs a
lhs rhs :: Rhs a
rhs) =
  SpanInfo -> Lhs a -> Rhs a -> Equation a
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p (Lhs a -> Rhs a -> Equation a)
-> StateT PCState Identity (Lhs a)
-> StateT PCState Identity (Rhs a -> Equation a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lhs a -> StateT PCState Identity (Lhs a)
forall a. Lhs a -> PCM (Lhs a)
checkLhs Lhs a
lhs StateT PCState Identity (Rhs a -> Equation a)
-> StateT PCState Identity (Rhs a) -> PCM (Equation a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs a -> StateT PCState Identity (Rhs a)
forall a. Rhs a -> PCM (Rhs a)
checkRhs Rhs a
rhs

checkLhs :: Lhs a -> PCM (Lhs a)
checkLhs :: Lhs a -> PCM (Lhs a)
checkLhs (FunLhs spi :: SpanInfo
spi     f :: Ident
f ts :: [Pattern a]
ts) = SpanInfo -> Ident -> [Pattern a] -> Lhs a
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f ([Pattern a] -> Lhs a)
-> StateT PCState Identity [Pattern a] -> PCM (Lhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> StateT PCState Identity (Pattern a))
-> [Pattern a] -> StateT PCState Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern [Pattern a]
ts
checkLhs (OpLhs  spi :: SpanInfo
spi t1 :: Pattern a
t1 op :: Ident
op t2 :: Pattern a
t2) =
  (Pattern a -> Ident -> Pattern a -> Lhs a)
-> Ident -> Pattern a -> Pattern a -> Lhs a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi) Ident
op (Pattern a -> Pattern a -> Lhs a)
-> StateT PCState Identity (Pattern a)
-> StateT PCState Identity (Pattern a -> Lhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t1 StateT PCState Identity (Pattern a)
-> (Pattern a -> StateT PCState Identity (Pattern a))
-> StateT PCState Identity (Pattern a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ident -> Pattern a -> StateT PCState Identity (Pattern a)
forall a. Ident -> Pattern a -> PCM (Pattern a)
checkOpL Ident
op)
                      StateT PCState Identity (Pattern a -> Lhs a)
-> StateT PCState Identity (Pattern a) -> PCM (Lhs a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t2 StateT PCState Identity (Pattern a)
-> (Pattern a -> StateT PCState Identity (Pattern a))
-> StateT PCState Identity (Pattern a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ident -> Pattern a -> StateT PCState Identity (Pattern a)
forall a. Ident -> Pattern a -> PCM (Pattern a)
checkOpR Ident
op)
checkLhs (ApLhs  spi :: SpanInfo
spi   lhs :: Lhs a
lhs ts :: [Pattern a]
ts) =
  SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi (Lhs a -> [Pattern a] -> Lhs a)
-> PCM (Lhs a) -> StateT PCState Identity ([Pattern a] -> Lhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lhs a -> PCM (Lhs a)
forall a. Lhs a -> PCM (Lhs a)
checkLhs Lhs a
lhs StateT PCState Identity ([Pattern a] -> Lhs a)
-> StateT PCState Identity [Pattern a] -> PCM (Lhs a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern a -> StateT PCState Identity (Pattern a))
-> [Pattern a] -> StateT PCState Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern [Pattern a]
ts

checkPattern :: Pattern a -> PCM (Pattern a)
checkPattern :: Pattern a -> PCM (Pattern a)
checkPattern l :: Pattern a
l@(LiteralPattern        _ _ _) = Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
l
checkPattern n :: Pattern a
n@(NegativePattern       _ _ _) = Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
n
checkPattern v :: Pattern a
v@(VariablePattern       _ _ _) = Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
v
checkPattern (ConstructorPattern spi :: SpanInfo
spi a :: a
a c :: QualIdent
c ts :: [Pattern a]
ts) =
  SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi a
a QualIdent
c ([Pattern a] -> Pattern a)
-> StateT PCState Identity [Pattern a] -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> PCM (Pattern a))
-> [Pattern a] -> StateT PCState Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern [Pattern a]
ts
checkPattern (InfixPattern   _ a :: a
a t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) = do
  Pattern a
t1' <- Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t1
  Pattern a
t2' <- Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t2
  (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
forall a.
(Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixPrecT Pattern a -> QualIdent -> Pattern a -> Pattern a
mkInfixPattern Pattern a
t1' QualIdent
op Pattern a
t2'
  where mkInfixPattern :: Pattern a -> QualIdent -> Pattern a -> Pattern a
mkInfixPattern t1'' :: Pattern a
t1'' op'' :: QualIdent
op'' t2'' :: Pattern a
t2'' =
          SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Pattern a
t1'' Pattern a -> Pattern a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Pattern a
t2'') a
a Pattern a
t1'' QualIdent
op'' Pattern a
t2''
checkPattern (ParenPattern              spi :: SpanInfo
spi t :: Pattern a
t) =
  SpanInfo -> Pattern a -> Pattern a
forall a. SpanInfo -> Pattern a -> Pattern a
ParenPattern SpanInfo
spi (Pattern a -> Pattern a) -> PCM (Pattern a) -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t
checkPattern (TuplePattern             spi :: SpanInfo
spi ts :: [Pattern a]
ts) =
  SpanInfo -> [Pattern a] -> Pattern a
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
spi ([Pattern a] -> Pattern a)
-> StateT PCState Identity [Pattern a] -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> PCM (Pattern a))
-> [Pattern a] -> StateT PCState Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern [Pattern a]
ts
checkPattern (ListPattern            spi :: SpanInfo
spi a :: a
a ts :: [Pattern a]
ts) =
  SpanInfo -> a -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
spi a
a ([Pattern a] -> Pattern a)
-> StateT PCState Identity [Pattern a] -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> PCM (Pattern a))
-> [Pattern a] -> StateT PCState Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern [Pattern a]
ts
checkPattern (AsPattern               spi :: SpanInfo
spi v :: Ident
v t :: Pattern a
t) =
  SpanInfo -> Ident -> Pattern a -> Pattern a
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
spi Ident
v (Pattern a -> Pattern a) -> PCM (Pattern a) -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t
checkPattern (LazyPattern               spi :: SpanInfo
spi t :: Pattern a
t) =
  SpanInfo -> Pattern a -> Pattern a
forall a. SpanInfo -> Pattern a -> Pattern a
LazyPattern SpanInfo
spi (Pattern a -> Pattern a) -> PCM (Pattern a) -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t
checkPattern (FunctionPattern      spi :: SpanInfo
spi a :: a
a f :: QualIdent
f ts :: [Pattern a]
ts) =
  SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
spi a
a QualIdent
f ([Pattern a] -> Pattern a)
-> StateT PCState Identity [Pattern a] -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> PCM (Pattern a))
-> [Pattern a] -> StateT PCState Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern [Pattern a]
ts
checkPattern (InfixFuncPattern _ a :: a
a t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) = do
  Pattern a
t1' <- Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t1
  Pattern a
t2' <- Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t2
  (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
forall a.
(Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixPrecT Pattern a -> QualIdent -> Pattern a -> Pattern a
mkInfixFuncPattern Pattern a
t1' QualIdent
op Pattern a
t2'
  where mkInfixFuncPattern :: Pattern a -> QualIdent -> Pattern a -> Pattern a
mkInfixFuncPattern t1'' :: Pattern a
t1'' op'' :: QualIdent
op'' t2'' :: Pattern a
t2'' =
          SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern (Pattern a
t1'' Pattern a -> Pattern a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Pattern a
t2'') a
a Pattern a
t1'' QualIdent
op'' Pattern a
t2''
checkPattern (RecordPattern       spi :: SpanInfo
spi a :: a
a c :: QualIdent
c fs :: [Field (Pattern a)]
fs) =
  SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
forall a.
SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
RecordPattern SpanInfo
spi a
a QualIdent
c ([Field (Pattern a)] -> Pattern a)
-> StateT PCState Identity [Field (Pattern a)] -> PCM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (Pattern a) -> StateT PCState Identity (Field (Pattern a)))
-> [Field (Pattern a)]
-> StateT PCState Identity [Field (Pattern a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Pattern a -> PCM (Pattern a))
-> Field (Pattern a) -> StateT PCState Identity (Field (Pattern a))
forall a. (a -> PCM a) -> Field a -> PCM (Field a)
checkField Pattern a -> PCM (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern) [Field (Pattern a)]
fs

checkRhs :: Rhs a -> PCM (Rhs a)
checkRhs :: Rhs a -> PCM (Rhs a)
checkRhs (SimpleRhs  spi :: SpanInfo
spi e :: Expression a
e  ds :: [Decl a]
ds) = PCM (Rhs a) -> PCM (Rhs a)
forall a. PCM a -> PCM a
withLocalPrecEnv (PCM (Rhs a) -> PCM (Rhs a)) -> PCM (Rhs a) -> PCM (Rhs a)
forall a b. (a -> b) -> a -> b
$
  (Expression a -> [Decl a] -> Rhs a)
-> [Decl a] -> Expression a -> Rhs a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression a -> [Decl a] -> Rhs a
forall a. SpanInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
spi) ([Decl a] -> Expression a -> Rhs a)
-> StateT PCState Identity [Decl a]
-> StateT PCState Identity (Expression a -> Rhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl a] -> StateT PCState Identity [Decl a]
forall a. [Decl a] -> PCM [Decl a]
checkDecls [Decl a]
ds StateT PCState Identity (Expression a -> Rhs a)
-> StateT PCState Identity (Expression a) -> PCM (Rhs a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> StateT PCState Identity (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkRhs (GuardedRhs spi :: SpanInfo
spi es :: [CondExpr a]
es ds :: [Decl a]
ds) = PCM (Rhs a) -> PCM (Rhs a)
forall a. PCM a -> PCM a
withLocalPrecEnv (PCM (Rhs a) -> PCM (Rhs a)) -> PCM (Rhs a) -> PCM (Rhs a)
forall a b. (a -> b) -> a -> b
$
  ([CondExpr a] -> [Decl a] -> Rhs a)
-> [Decl a] -> [CondExpr a] -> Rhs a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> [CondExpr a] -> [Decl a] -> Rhs a
forall a. SpanInfo -> [CondExpr a] -> [Decl a] -> Rhs a
GuardedRhs SpanInfo
spi) ([Decl a] -> [CondExpr a] -> Rhs a)
-> StateT PCState Identity [Decl a]
-> StateT PCState Identity ([CondExpr a] -> Rhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl a] -> StateT PCState Identity [Decl a]
forall a. [Decl a] -> PCM [Decl a]
checkDecls [Decl a]
ds StateT PCState Identity ([CondExpr a] -> Rhs a)
-> StateT PCState Identity [CondExpr a] -> PCM (Rhs a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CondExpr a -> StateT PCState Identity (CondExpr a))
-> [CondExpr a] -> StateT PCState Identity [CondExpr a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CondExpr a -> StateT PCState Identity (CondExpr a)
forall a. CondExpr a -> PCM (CondExpr a)
checkCondExpr [CondExpr a]
es

checkCondExpr :: CondExpr a -> PCM (CondExpr a)
checkCondExpr :: CondExpr a -> PCM (CondExpr a)
checkCondExpr (CondExpr p :: SpanInfo
p g :: Expression a
g e :: Expression a
e) = SpanInfo -> Expression a -> Expression a -> CondExpr a
forall a. SpanInfo -> Expression a -> Expression a -> CondExpr a
CondExpr SpanInfo
p (Expression a -> Expression a -> CondExpr a)
-> StateT PCState Identity (Expression a)
-> StateT PCState Identity (Expression a -> CondExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> StateT PCState Identity (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
g StateT PCState Identity (Expression a -> CondExpr a)
-> StateT PCState Identity (Expression a) -> PCM (CondExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> StateT PCState Identity (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e

checkExpr :: Expression a -> PCM (Expression a)
checkExpr :: Expression a -> PCM (Expression a)
checkExpr l :: Expression a
l@(Literal          _ _ _) = Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression a
l
checkExpr v :: Expression a
v@(Variable         _ _ _) = Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression a
v
checkExpr c :: Expression a
c@(Constructor      _ _ _) = Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression a
c
checkExpr (Paren              spi :: SpanInfo
spi e :: Expression a
e) = SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
Paren SpanInfo
spi (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (Typed           spi :: SpanInfo
spi e :: Expression a
e ty :: QualTypeExpr
ty) = (Expression a -> QualTypeExpr -> Expression a)
-> QualTypeExpr -> Expression a -> Expression a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression a -> QualTypeExpr -> Expression a
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
spi) QualTypeExpr
ty (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (Record        spi :: SpanInfo
spi a :: a
a c :: QualIdent
c fs :: [Field (Expression a)]
fs) = SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
spi a
a QualIdent
c ([Field (Expression a)] -> Expression a)
-> StateT PCState Identity [Field (Expression a)]
-> PCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (Expression a)
 -> StateT PCState Identity (Field (Expression a)))
-> [Field (Expression a)]
-> StateT PCState Identity [Field (Expression a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expression a -> PCM (Expression a))
-> Field (Expression a)
-> StateT PCState Identity (Field (Expression a))
forall a. (a -> PCM a) -> Field a -> PCM (Field a)
checkField Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr) [Field (Expression a)]
fs
checkExpr (RecordUpdate    spi :: SpanInfo
spi e :: Expression a
e fs :: [Field (Expression a)]
fs) = SpanInfo -> Expression a -> [Field (Expression a)] -> Expression a
forall a.
SpanInfo -> Expression a -> [Field (Expression a)] -> Expression a
RecordUpdate SpanInfo
spi (Expression a -> [Field (Expression a)] -> Expression a)
-> PCM (Expression a)
-> StateT PCState Identity ([Field (Expression a)] -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
                                                       StateT PCState Identity ([Field (Expression a)] -> Expression a)
-> StateT PCState Identity [Field (Expression a)]
-> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Field (Expression a)
 -> StateT PCState Identity (Field (Expression a)))
-> [Field (Expression a)]
-> StateT PCState Identity [Field (Expression a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expression a -> PCM (Expression a))
-> Field (Expression a)
-> StateT PCState Identity (Field (Expression a))
forall a. (a -> PCM a) -> Field a -> PCM (Field a)
checkField Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr) [Field (Expression a)]
fs
checkExpr (Tuple            spi :: SpanInfo
spi es :: [Expression a]
es) = SpanInfo -> [Expression a] -> Expression a
forall a. SpanInfo -> [Expression a] -> Expression a
Tuple SpanInfo
spi ([Expression a] -> Expression a)
-> StateT PCState Identity [Expression a] -> PCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression a -> PCM (Expression a))
-> [Expression a] -> StateT PCState Identity [Expression a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr [Expression a]
es
checkExpr (List           spi :: SpanInfo
spi a :: a
a es :: [Expression a]
es) = SpanInfo -> a -> [Expression a] -> Expression a
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
spi a
a ([Expression a] -> Expression a)
-> StateT PCState Identity [Expression a] -> PCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression a -> PCM (Expression a))
-> [Expression a] -> StateT PCState Identity [Expression a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr [Expression a]
es
checkExpr (ListCompr      spi :: SpanInfo
spi e :: Expression a
e qs :: [Statement a]
qs) = PCM (Expression a) -> PCM (Expression a)
forall a. PCM a -> PCM a
withLocalPrecEnv (PCM (Expression a) -> PCM (Expression a))
-> PCM (Expression a) -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$
  (Expression a -> [Statement a] -> Expression a)
-> [Statement a] -> Expression a -> Expression a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression a -> [Statement a] -> Expression a
forall a. SpanInfo -> Expression a -> [Statement a] -> Expression a
ListCompr SpanInfo
spi) ([Statement a] -> Expression a -> Expression a)
-> StateT PCState Identity [Statement a]
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement a -> StateT PCState Identity (Statement a))
-> [Statement a] -> StateT PCState Identity [Statement a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Statement a -> StateT PCState Identity (Statement a)
forall a. Statement a -> PCM (Statement a)
checkStmt [Statement a]
qs StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (EnumFrom              spi :: SpanInfo
spi e :: Expression a
e) = SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
EnumFrom SpanInfo
spi (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (EnumFromThen      spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2) =
  SpanInfo -> Expression a -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromThen SpanInfo
spi (Expression a -> Expression a -> Expression a)
-> PCM (Expression a)
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e1 StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e2
checkExpr (EnumFromTo        spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2) =
  SpanInfo -> Expression a -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromTo SpanInfo
spi (Expression a -> Expression a -> Expression a)
-> PCM (Expression a)
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e1 StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e2
checkExpr (EnumFromThenTo spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2 e3 :: Expression a
e3) =
  SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
EnumFromThenTo SpanInfo
spi (Expression a -> Expression a -> Expression a -> Expression a)
-> PCM (Expression a)
-> StateT
     PCState Identity (Expression a -> Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e1 StateT
  PCState Identity (Expression a -> Expression a -> Expression a)
-> PCM (Expression a)
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e2 StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e3
checkExpr (UnaryMinus            spi :: SpanInfo
spi e :: Expression a
e) = SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (Apply spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2) =
  SpanInfo -> Expression a -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
spi (Expression a -> Expression a -> Expression a)
-> PCM (Expression a)
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e1 StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e2
checkExpr (InfixApply spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op e2 :: Expression a
e2) = do
  Expression a
e1' <- Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e1
  Expression a
e2' <- Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e2
  SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixPrec SpanInfo
spi Expression a
e1' InfixOp a
op Expression a
e2'
checkExpr (LeftSection      spi :: SpanInfo
spi e :: Expression a
e op :: InfixOp a
op) = Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e PCM (Expression a)
-> (Expression a -> PCM (Expression a)) -> PCM (Expression a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
checkLSection SpanInfo
spi InfixOp a
op
checkExpr (RightSection     spi :: SpanInfo
spi op :: InfixOp a
op e :: Expression a
e) = Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e PCM (Expression a)
-> (Expression a -> PCM (Expression a)) -> PCM (Expression a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
checkRSection SpanInfo
spi InfixOp a
op
checkExpr (Lambda           spi :: SpanInfo
spi ts :: [Pattern a]
ts e :: Expression a
e) =
  SpanInfo -> [Pattern a] -> Expression a -> Expression a
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
spi ([Pattern a] -> Expression a -> Expression a)
-> StateT PCState Identity [Pattern a]
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> StateT PCState Identity (Pattern a))
-> [Pattern a] -> StateT PCState Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern [Pattern a]
ts StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (Let              spi :: SpanInfo
spi ds :: [Decl a]
ds e :: Expression a
e) = PCM (Expression a) -> PCM (Expression a)
forall a. PCM a -> PCM a
withLocalPrecEnv (PCM (Expression a) -> PCM (Expression a))
-> PCM (Expression a) -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> [Decl a] -> Expression a -> Expression a
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi ([Decl a] -> Expression a -> Expression a)
-> StateT PCState Identity [Decl a]
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl a] -> StateT PCState Identity [Decl a]
forall a. [Decl a] -> PCM [Decl a]
checkDecls [Decl a]
ds StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (Do              spi :: SpanInfo
spi sts :: [Statement a]
sts e :: Expression a
e) = PCM (Expression a) -> PCM (Expression a)
forall a. PCM a -> PCM a
withLocalPrecEnv (PCM (Expression a) -> PCM (Expression a))
-> PCM (Expression a) -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> [Statement a] -> Expression a -> Expression a
forall a. SpanInfo -> [Statement a] -> Expression a -> Expression a
Do SpanInfo
spi ([Statement a] -> Expression a -> Expression a)
-> StateT PCState Identity [Statement a]
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  (Statement a -> StateT PCState Identity (Statement a))
-> [Statement a] -> StateT PCState Identity [Statement a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Statement a -> StateT PCState Identity (Statement a)
forall a. Statement a -> PCM (Statement a)
checkStmt [Statement a]
sts StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkExpr (IfThenElse   spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2 e3 :: Expression a
e3) =
  SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
spi (Expression a -> Expression a -> Expression a -> Expression a)
-> PCM (Expression a)
-> StateT
     PCState Identity (Expression a -> Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e1 StateT
  PCState Identity (Expression a -> Expression a -> Expression a)
-> PCM (Expression a)
-> StateT PCState Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e2 StateT PCState Identity (Expression a -> Expression a)
-> PCM (Expression a) -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e3
checkExpr (Case        spi :: SpanInfo
spi ct :: CaseType
ct e :: Expression a
e alts :: [Alt a]
alts) =
  SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
spi CaseType
ct (Expression a -> [Alt a] -> Expression a)
-> PCM (Expression a)
-> StateT PCState Identity ([Alt a] -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> PCM (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e StateT PCState Identity ([Alt a] -> Expression a)
-> StateT PCState Identity [Alt a] -> PCM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt a -> StateT PCState Identity (Alt a))
-> [Alt a] -> StateT PCState Identity [Alt a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt a -> StateT PCState Identity (Alt a)
forall a. Alt a -> PCM (Alt a)
checkAlt [Alt a]
alts

checkStmt :: Statement a -> PCM (Statement a)
checkStmt :: Statement a -> PCM (Statement a)
checkStmt (StmtExpr spi :: SpanInfo
spi   e :: Expression a
e) = SpanInfo -> Expression a -> Statement a
forall a. SpanInfo -> Expression a -> Statement a
StmtExpr SpanInfo
spi (Expression a -> Statement a)
-> StateT PCState Identity (Expression a) -> PCM (Statement a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> StateT PCState Identity (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e
checkStmt (StmtDecl spi :: SpanInfo
spi  ds :: [Decl a]
ds) = SpanInfo -> [Decl a] -> Statement a
forall a. SpanInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi ([Decl a] -> Statement a)
-> StateT PCState Identity [Decl a] -> PCM (Statement a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl a] -> StateT PCState Identity [Decl a]
forall a. [Decl a] -> PCM [Decl a]
checkDecls [Decl a]
ds
checkStmt (StmtBind spi :: SpanInfo
spi t :: Pattern a
t e :: Expression a
e) = SpanInfo -> Pattern a -> Expression a -> Statement a
forall a. SpanInfo -> Pattern a -> Expression a -> Statement a
StmtBind SpanInfo
spi (Pattern a -> Expression a -> Statement a)
-> StateT PCState Identity (Pattern a)
-> StateT PCState Identity (Expression a -> Statement a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t StateT PCState Identity (Expression a -> Statement a)
-> StateT PCState Identity (Expression a) -> PCM (Statement a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> StateT PCState Identity (Expression a)
forall a. Expression a -> PCM (Expression a)
checkExpr Expression a
e

checkAlt :: Alt a -> PCM (Alt a)
checkAlt :: Alt a -> PCM (Alt a)
checkAlt (Alt p :: SpanInfo
p t :: Pattern a
t rhs :: Rhs a
rhs) = SpanInfo -> Pattern a -> Rhs a -> Alt a
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p (Pattern a -> Rhs a -> Alt a)
-> StateT PCState Identity (Pattern a)
-> StateT PCState Identity (Rhs a -> Alt a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> StateT PCState Identity (Pattern a)
forall a. Pattern a -> PCM (Pattern a)
checkPattern Pattern a
t StateT PCState Identity (Rhs a -> Alt a)
-> StateT PCState Identity (Rhs a) -> PCM (Alt a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs a -> StateT PCState Identity (Rhs a)
forall a. Rhs a -> PCM (Rhs a)
checkRhs Rhs a
rhs

checkField :: (a -> PCM a) -> Field a -> PCM (Field a)
checkField :: (a -> PCM a) -> Field a -> PCM (Field a)
checkField check :: a -> PCM a
check (Field p :: SpanInfo
p l :: QualIdent
l x :: a
x) = SpanInfo -> QualIdent -> a -> Field a
forall a. SpanInfo -> QualIdent -> a -> Field a
Field SpanInfo
p QualIdent
l (a -> Field a) -> PCM a -> PCM (Field a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> PCM a
check a
x

-- The functions 'fixPrec', 'fixUPrec', and 'fixRPrec' check the relative
-- precedences of adjacent infix operators in nested infix applications
-- and unary negations. The expressions will be reordered such that the
-- infix operator with the lowest precedence becomes the root of the
-- expression. The functions rely on the fact that the parser constructs
-- infix applications in a right-associative fashion, i.e., the left argument
-- of an infix application will never be an infix application. In addition,
-- a unary negation will never have an infix application as its argument.

-- The function 'fixPrec' checks whether the left argument of an
-- infix application is a unary negation and eventually reorders the
-- expression if the precedence of the infix operator is higher than that
-- of the negation. This will be done with the help of the function
-- 'fixUPrec'. In any case, the function 'fixRPrec' is used for fixing the
-- precedence of the infix operator and that of its right argument.
-- Note that both arguments already have been checked before 'fixPrec'
-- is called.

fixPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixPrec :: SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixPrec spi :: SpanInfo
spi (UnaryMinus spi' :: SpanInfo
spi' e1 :: Expression a
e1) op :: InfixOp a
op e2 :: Expression a
e2 = do
  OpPrec fix :: Infix
fix pr :: Precedence
pr <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op
  if Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6 Bool -> Bool -> Bool
|| Precedence
pr Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== 6 Bool -> Bool -> Bool
&& Infix
fix Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL
    then SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixRPrec SpanInfo
spi (SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi' Expression a
e1) InfixOp a
op Expression a
e2
    else if Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> 6
      then SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixUPrec SpanInfo
spi' Expression a
e1 InfixOp a
op Expression a
e2
      else do
        Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "unary" (Ident -> QualIdent
qualify Ident
minusId) (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op)
        Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi (SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi' Expression a
e1) InfixOp a
op Expression a
e2
fixPrec spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op e2 :: Expression a
e2 = SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixRPrec SpanInfo
spi Expression a
e1 InfixOp a
op Expression a
e2

fixUPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a
         -> PCM (Expression a)
fixUPrec :: SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixUPrec spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op e2 :: Expression a
e2@(UnaryMinus spi' :: SpanInfo
spi' _) = do
  Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "operator" (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op) (Ident -> QualIdent
qualify Ident
minusId)
  Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi' (SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi Expression a
e1 InfixOp a
op Expression a
e2)
fixUPrec spi :: SpanInfo
spi e1 :: Expression a
e1 op1 :: InfixOp a
op1 e' :: Expression a
e'@(InfixApply spi' :: SpanInfo
spi' e2 :: Expression a
e2 op2 :: InfixOp a
op2 e3 :: Expression a
e3) = do
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op2
  if Precedence
pr2 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6 Bool -> Bool -> Bool
|| Precedence
pr2 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== 6 Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL
    then do
      Expression a
left <- SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixUPrec SpanInfo
spi Expression a
e1 InfixOp a
op1 Expression a
e2
      Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply (Expression a
left Expression a -> Expression a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Expression a
e3) Expression a
left InfixOp a
op2 Expression a
e3
    else if Precedence
pr2 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> 6
      then do
        Expression a
op <- SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixRPrec SpanInfo
spi Expression a
e1 InfixOp a
op1 (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi' Expression a
e2 InfixOp a
op2 Expression a
e3
        Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ Expression a -> Expression a
forall a. HasSpanInfo a => a -> a
updateEndPos (Expression a -> Expression a) -> Expression a -> Expression a
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi' Expression a
op
      else do
        Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "unary" (Ident -> QualIdent
qualify Ident
minusId) (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op2)
        let left :: Expression a
left = Expression a -> Expression a
forall a. HasSpanInfo a => a -> a
updateEndPos (SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi' Expression a
e1)
        Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply (Expression a
left Expression a -> Expression a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Expression a
e') Expression a
left InfixOp a
op1 Expression a
e'
fixUPrec spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op e2 :: Expression a
e2 = Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ Expression a -> Expression a
forall a. HasSpanInfo a => a -> a
updateEndPos (Expression a -> Expression a) -> Expression a -> Expression a
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi
  (SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply (Expression a
e1 Expression a -> Expression a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Expression a
e2) Expression a
e1 InfixOp a
op Expression a
e2)

fixRPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a
         -> PCM (Expression a)
fixRPrec :: SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixRPrec spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op (UnaryMinus spi' :: SpanInfo
spi' e2 :: Expression a
e2) = do
  OpPrec _ pr :: Precedence
pr <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$ Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "operator" (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op) (Ident -> QualIdent
qualify Ident
minusId)
  Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi Expression a
e1 InfixOp a
op (Expression a -> Expression a) -> Expression a -> Expression a
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi' Expression a
e2
fixRPrec spi :: SpanInfo
spi e1 :: Expression a
e1 op1 :: InfixOp a
op1 (InfixApply spi' :: SpanInfo
spi' e2 :: Expression a
e2 op2 :: InfixOp a
op2 e3 :: Expression a
e3) = do
  OpPrec fix1 :: Infix
fix1 pr1 :: Precedence
pr1 <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op1
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op2
  if Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR
     then Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi Expression a
e1 InfixOp a
op1 (Expression a -> Expression a) -> Expression a -> Expression a
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi' Expression a
e2 InfixOp a
op2 Expression a
e3
     else if Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL
       then do
          Expression a
left <- SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixPrec (Expression a
e1 Expression a -> Expression a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Expression a
e2) Expression a
e1 InfixOp a
op1 Expression a
e2
          Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply (Expression a
left Expression a -> Expression a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Expression a
e3) Expression a
left InfixOp a
op2 Expression a
e3
       else do
         Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "operator" (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op1) (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op2)
         Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi Expression a
e1 InfixOp a
op1 (Expression a -> Expression a) -> Expression a -> Expression a
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi' Expression a
e2 InfixOp a
op2 Expression a
e3
fixRPrec spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op e2 :: Expression a
e2 = Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi Expression a
e1 InfixOp a
op Expression a
e2

-- The functions 'checkLSection' and 'checkRSection' are used for handling
-- the precedences inside left and right sections.
-- These functions only need to check that an infix operator occurring in
-- the section has either a higher precedence than the section operator
-- or both operators have the same precedence and are both left
-- associative for a left section and right associative for a right
-- section, respectively.

checkLSection :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
checkLSection :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
checkLSection spi :: SpanInfo
spi op :: InfixOp a
op e :: Expression a
e@(UnaryMinus _ _) = do
  OpPrec fix :: Infix
fix pr :: Precedence
pr <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6 Bool -> Bool -> Bool
|| Precedence
pr Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== 6 Bool -> Bool -> Bool
&& Infix
fix Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$
    Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "unary" (Ident -> QualIdent
qualify Ident
minusId) (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op)
  Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression a -> InfixOp a -> Expression a
forall a. SpanInfo -> Expression a -> InfixOp a -> Expression a
LeftSection SpanInfo
spi Expression a
e InfixOp a
op
checkLSection spi :: SpanInfo
spi op1 :: InfixOp a
op1 e :: Expression a
e@(InfixApply _ _ op2 :: InfixOp a
op2 _) = do
  OpPrec fix1 :: Infix
fix1 pr1 :: Precedence
pr1 <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op1
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op2
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$
    Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "operator" (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op1) (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op2)
  Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression a -> InfixOp a -> Expression a
forall a. SpanInfo -> Expression a -> InfixOp a -> Expression a
LeftSection SpanInfo
spi Expression a
e InfixOp a
op1
checkLSection spi :: SpanInfo
spi op :: InfixOp a
op e :: Expression a
e = Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression a -> InfixOp a -> Expression a
forall a. SpanInfo -> Expression a -> InfixOp a -> Expression a
LeftSection SpanInfo
spi Expression a
e InfixOp a
op

checkRSection :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
checkRSection :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)
checkRSection spi :: SpanInfo
spi op :: InfixOp a
op e :: Expression a
e@(UnaryMinus _ _) = do
  OpPrec _ pr :: Precedence
pr <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$ Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "unary" (Ident -> QualIdent
qualify Ident
minusId) (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op)
  Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> InfixOp a -> Expression a -> Expression a
forall a. SpanInfo -> InfixOp a -> Expression a -> Expression a
RightSection SpanInfo
spi InfixOp a
op Expression a
e
checkRSection spi :: SpanInfo
spi op1 :: InfixOp a
op1 e :: Expression a
e@(InfixApply _ _ op2 :: InfixOp a
op2 _) = do
  OpPrec fix1 :: Infix
fix1 pr1 :: Precedence
pr1 <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op1
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- InfixOp a -> PCM OpPrec
forall a. InfixOp a -> PCM OpPrec
getOpPrec InfixOp a
op2
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$
    Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "operator" (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op1) (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op2)
  Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> InfixOp a -> Expression a -> Expression a
forall a. SpanInfo -> InfixOp a -> Expression a -> Expression a
RightSection SpanInfo
spi InfixOp a
op1 Expression a
e
checkRSection spi :: SpanInfo
spi op :: InfixOp a
op e :: Expression a
e = Expression a -> PCM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> PCM (Expression a))
-> Expression a -> PCM (Expression a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> InfixOp a -> Expression a -> Expression a
forall a. SpanInfo -> InfixOp a -> Expression a -> Expression a
RightSection SpanInfo
spi InfixOp a
op Expression a
e

-- The functions 'fixPrecT' and 'fixRPrecT' check the relative precedences
-- of adjacent infix operators in patterns. The patterns will be reordered
-- such that the infix operator with the lowest precedence becomes the root
-- of the term. The functions rely on the fact that the parser constructs
-- infix patterns in a right-associative fashion, i.e., the left argument
-- of an infix pattern will never be an infix pattern. The functions also
-- check whether the left and right arguments of an infix pattern are negative
-- literals. In this case, the negation must bind more tightly than the
-- operator for the pattern to be accepted.

fixPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a)
         -> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixPrecT infixpatt :: Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt t1 :: Pattern a
t1@(NegativePattern _ _ _) op :: QualIdent
op t2 :: Pattern a
t2 = do
  OpPrec fix :: Infix
fix pr :: Precedence
pr <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6 Bool -> Bool -> Bool
|| Precedence
pr Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== 6 Bool -> Bool -> Bool
&& Infix
fix Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$
    Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> QualIdent -> Message
errInvalidParse "unary operator" Ident
minusId QualIdent
op
  (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
forall a.
(Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixRPrecT Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op Pattern a
t2
fixPrecT infixpatt :: Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2 = (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
forall a.
(Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixRPrecT Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op Pattern a
t2

fixRPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a)
          -> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixRPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixRPrecT infixpatt :: Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2@(NegativePattern _ _ _) = do
  OpPrec _ pr :: Precedence
pr <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$ Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> QualIdent -> Message
errInvalidParse "unary operator" Ident
minusId QualIdent
op
  Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op Pattern a
t2
fixRPrecT infixpatt :: Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt t1 :: Pattern a
t1 op1 :: QualIdent
op1 (InfixPattern spi :: SpanInfo
spi a :: a
a t2 :: Pattern a
t2 op2 :: QualIdent
op2 t3 :: Pattern a
t3) = do
  OpPrec fix1 :: Infix
fix1 pr1 :: Precedence
pr1 <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op1 (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op2 (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  if Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR
    then Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op1 (SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi a
a Pattern a
t2 QualIdent
op2 Pattern a
t3)
    else if Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL
      then do
        Pattern a
left <- (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
forall a.
(Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixPrecT Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op1 Pattern a
t2
        Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern (Pattern a
left Pattern a -> Pattern a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Pattern a
t3) a
a Pattern a
left QualIdent
op2 Pattern a
t3
      else do
        Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "operator" QualIdent
op1 QualIdent
op2
        Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op1 (SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi a
a Pattern a
t2 QualIdent
op2 Pattern a
t3)
fixRPrecT infixpatt :: Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt t1 :: Pattern a
t1 op1 :: QualIdent
op1 (InfixFuncPattern spi :: SpanInfo
spi a :: a
a t2 :: Pattern a
t2 op2 :: QualIdent
op2 t3 :: Pattern a
t3) = do
  OpPrec fix1 :: Infix
fix1 pr1 :: Precedence
pr1 <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op1 (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op2 (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  if Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR
    then Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op1 (SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern SpanInfo
spi a
a Pattern a
t2 QualIdent
op2 Pattern a
t3)
    else if Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL
      then do
        Pattern a
left <- (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
forall a.
(Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixPrecT Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op1 Pattern a
t2
        Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern (Pattern a
left Pattern a -> Pattern a -> SpanInfo
forall a b. (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
@+@ Pattern a
t3) a
a Pattern a
left QualIdent
op2 Pattern a
t3
      else do
        Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> QualIdent -> QualIdent -> Message
errAmbiguousParse "operator" QualIdent
op1 QualIdent
op2
        Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op1 (SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern SpanInfo
spi a
a Pattern a
t2 QualIdent
op2 Pattern a
t3)
fixRPrecT infixpatt :: Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2 = Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern a -> PCM (Pattern a)) -> Pattern a -> PCM (Pattern a)
forall a b. (a -> b) -> a -> b
$ Pattern a -> QualIdent -> Pattern a -> Pattern a
infixpatt Pattern a
t1 QualIdent
op Pattern a
t2

{-fixPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern
         -> Pattern
fixPrecT p pEnv t1@(NegativePattern uop l) op t2
  | pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2
  | otherwise = errorAt p $ errInvalidParse "unary" uop op
  where OpPrec fix pr = prec op pEnv
fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-}

{-fixRPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern
          -> Pattern
fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)
  | pr < 6 = InfixPattern t1 op t2
  | otherwise = errorAt p $ errInvalidParse "unary" uop op
  where OpPrec _ pr = prec op pEnv
fixRPrecT p pEnv t1 op1 (InfixPattern t2 op2 t3)
  | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =
      InfixPattern t1 op1 (InfixPattern t2 op2 t3)
  | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =
      InfixPattern (fixPrecT p pEnv t1 op1 t2) op2 t3
  | otherwise = errorAt p $ errAmbiguousParse "operator" op1 op2
  where OpPrec fix1 pr1 = prec op1 pEnv
        OpPrec fix2 pr2 = prec op2 pEnv
fixRPrecT _ _ t1 op t2 = InfixPattern t1 op t2-}

-- The functions 'checkOpL' and 'checkOpR' check the left and right arguments
-- of an operator declaration. If they are infix patterns they must bind
-- more tightly than the operator, otherwise the left-hand side of the
-- declaration is invalid.

checkOpL :: Ident -> Pattern a -> PCM (Pattern a)
checkOpL :: Ident -> Pattern a -> PCM (Pattern a)
checkOpL op :: Ident
op t :: Pattern a
t@(NegativePattern _ _ _) = do
  OpPrec fix :: Infix
fix pr :: Precedence
pr <- QualIdent -> OpPrecEnv -> OpPrec
prec (Ident -> QualIdent
qualify Ident
op) (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< 6 Bool -> Bool -> Bool
|| Precedence
pr Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== 6 Bool -> Bool -> Bool
&& Infix
fix Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$
    Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> QualIdent -> Message
errInvalidParse "unary operator" Ident
minusId (Ident -> QualIdent
qualify Ident
op)
  Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t
checkOpL op1 :: Ident
op1 t :: Pattern a
t@(InfixPattern _ _ _ op2 :: QualIdent
op2 _) = do
  OpPrec fix1 :: Infix
fix1 pr1 :: Precedence
pr1 <- QualIdent -> OpPrecEnv -> OpPrec
prec (Ident -> QualIdent
qualify Ident
op1) (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op2 (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixL) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$
    Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> QualIdent -> Message
errInvalidParse "operator" Ident
op1 QualIdent
op2
  Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t
checkOpL _ t :: Pattern a
t = Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t

checkOpR :: Ident -> Pattern a -> PCM (Pattern a)
checkOpR :: Ident -> Pattern a -> PCM (Pattern a)
checkOpR op :: Ident
op t :: Pattern a
t@(NegativePattern _ _ _) = do
  OpPrec _ pr :: Precedence
pr <- QualIdent -> OpPrecEnv -> OpPrec
prec (Ident -> QualIdent
qualify Ident
op)  (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Precedence
pr Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= 6) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$ Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> QualIdent -> Message
errInvalidParse "unary operator" Ident
minusId (Ident -> QualIdent
qualify Ident
op)
  Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t
checkOpR op1 :: Ident
op1 t :: Pattern a
t@(InfixPattern _ _ _ op2 :: QualIdent
op2 _) = do
  OpPrec fix1 :: Infix
fix1 pr1 :: Precedence
pr1 <- QualIdent -> OpPrecEnv -> OpPrec
prec (Ident -> QualIdent
qualify Ident
op1)  (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  OpPrec fix2 :: Infix
fix2 pr2 :: Precedence
pr2 <- QualIdent -> OpPrecEnv -> OpPrec
prec QualIdent
op2  (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv
  Bool -> PCM () -> PCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
pr2 Bool -> Bool -> Bool
|| Precedence
pr1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
pr2 Bool -> Bool -> Bool
&& Infix
fix1 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR Bool -> Bool -> Bool
&& Infix
fix2 Infix -> Infix -> Bool
forall a. Eq a => a -> a -> Bool
== Infix
InfixR) (PCM () -> PCM ()) -> PCM () -> PCM ()
forall a b. (a -> b) -> a -> b
$
    Message -> PCM ()
report (Message -> PCM ()) -> Message -> PCM ()
forall a b. (a -> b) -> a -> b
$ String -> Ident -> QualIdent -> Message
errInvalidParse "operator" Ident
op1 QualIdent
op2
  Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t
checkOpR _ t :: Pattern a
t = Pattern a -> PCM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t

-- The functions 'opPrec' and 'prec' return the fixity and operator precedence
-- of an entity. Even though precedence checking is performed after the
-- renaming phase, we have to be prepared to see ambiguoeus identifiers here.
-- This may happen while checking the root of an operator definition that
-- shadows an imported definition.

getOpPrec :: InfixOp a -> PCM OpPrec
getOpPrec :: InfixOp a -> PCM OpPrec
getOpPrec op :: InfixOp a
op = InfixOp a -> OpPrecEnv -> OpPrec
forall a. InfixOp a -> OpPrecEnv -> OpPrec
opPrec InfixOp a
op (OpPrecEnv -> OpPrec) -> PCM OpPrecEnv -> PCM OpPrec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCM OpPrecEnv
getPrecEnv

opPrec :: InfixOp a -> OpPrecEnv -> OpPrec
opPrec :: InfixOp a -> OpPrecEnv -> OpPrec
opPrec op :: InfixOp a
op = QualIdent -> OpPrecEnv -> OpPrec
prec (InfixOp a -> QualIdent
forall a. InfixOp a -> QualIdent
opName InfixOp a
op)

prec :: QualIdent -> OpPrecEnv -> OpPrec
prec :: QualIdent -> OpPrecEnv -> OpPrec
prec op :: QualIdent
op env :: OpPrecEnv
env = case QualIdent -> OpPrecEnv -> [PrecInfo]
qualLookupP QualIdent
op OpPrecEnv
env of
  [] -> OpPrec
defaultP
  PrecInfo _ p :: OpPrec
p : _ -> OpPrec
p


-- Combine two entities with SpanInfo to a new SpanInfo (discarding info points)
(@+@) :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
a :: a
a @+@ :: a -> b -> SpanInfo
@+@ b :: b
b = Span -> SpanInfo
fromSrcSpan (Span -> Span -> Span
combineSpans (a -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan a
a) (b -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan b
b))

-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------

errUndefinedOperator :: Ident -> Message
errUndefinedOperator :: Ident -> Message
errUndefinedOperator op :: Ident
op = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Ident
op (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["No definition for", Ident -> String
escName Ident
op, "in this scope"]

errMultiplePrecedence :: [Ident] -> Message
errMultiplePrecedence :: [Ident] -> Message
errMultiplePrecedence []       = String -> Message
forall a. String -> a
internalError
  "PrecCheck.errMultiplePrecedence: empty list"
errMultiplePrecedence (op :: Ident
op:ops :: [Ident]
ops) = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Ident
op (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ["More than one fixity declaration for", Ident -> String
escName Ident
op, "at"])
  Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> Doc
ppPosition (Position -> Doc) -> (Ident -> Position) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition) (Ident
opIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
ops)))

errInvalidParse :: String -> Ident -> QualIdent -> Message
errInvalidParse :: String -> Ident -> QualIdent -> Message
errInvalidParse what :: String
what op1 :: Ident
op1 op2 :: QualIdent
op2 = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Ident
op1 (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Invalid use of", String
what, Ident -> String
escName Ident
op1, "with", QualIdent -> String
escQualName QualIdent
op2, "in"
  , Position -> String
showLine (Position -> String) -> Position -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Position
forall a. HasPosition a => a -> Position
getPosition QualIdent
op2]

-- FIXME: Messages may have missing positions for minus operators
-- TODO: Is this still true after span update for parser?

errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message
errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message
errAmbiguousParse what :: String
what op1 :: QualIdent
op1 op2 :: QualIdent
op2 = QualIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage QualIdent
op1 (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Ambiguous use of", String
what, QualIdent -> String
escQualName QualIdent
op1, "with", QualIdent -> String
escQualName QualIdent
op2, "in"
  , Position -> String
showLine (Position -> String) -> Position -> String
forall a b. (a -> b) -> a -> b
$ QualIdent -> Position
forall a. HasPosition a => a -> Position
getPosition QualIdent
op2]