{-# LANGUAGE CPP #-}
module CParserMonad (
P,
execParser,
failP,
getNewName,
addTypedef,
shadowTypedef,
isTypeIdent,
enterScope,
leaveScope,
setPos,
getPos,
getInput,
setInput,
getLastToken,
setLastToken,
) where
import Position (Position(..), Pos(posOf))
import Errors (interr)
import UNames (Name)
import Idents (Ident, lexemeToIdent, identToLexeme)
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
import Control.Monad.Fail (MonadFail (..))
import Data.Set (Set)
import qualified Data.Set as Set (fromList, insert, member, delete)
import CTokens (CToken)
data ParseResult a
= POk !PState a
| PFailed [String] Position
data PState = PState {
PState -> Position
curPos :: !Position,
PState -> String
curInput :: !String,
PState -> CToken
prevToken :: CToken,
PState -> [Name]
namesupply :: ![Name],
PState -> Set Ident
tyidents :: !(Set Ident),
PState -> [Set Ident]
scopes :: ![Set Ident]
}
newtype P a = P { forall a. P a -> PState -> ParseResult a
unP :: PState -> ParseResult a }
instance MonadFail P where
fail :: forall a. String -> P a
fail String
m = P Position
getPos forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Position
pos -> forall a. Position -> [String] -> P a
failP Position
pos [String
m]
instance Functor P where
fmap :: forall a b. (a -> b) -> P a -> P b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative P where
pure :: forall a. a -> P a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b. P (a -> b) -> P a -> P b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad P where
return :: forall a. a -> P a
return = forall a. a -> P a
returnP
>>= :: forall a b. P a -> (a -> P b) -> P b
(>>=) = forall a b. P a -> (a -> P b) -> P b
thenP
#if !MIN_VERSION_base(4,13,0)
fail m = getPos >>= \pos -> failP pos [m]
#endif
execParser :: P a -> String -> Position -> [Ident] -> [Name]
-> Either a ([String], Position)
execParser :: forall a.
P a
-> String
-> Position
-> [Ident]
-> [Name]
-> Either a ([String], Position)
execParser (P PState -> ParseResult a
parser) String
input Position
pos [Ident]
builtins [Name]
names =
case PState -> ParseResult a
parser PState
initialState of
POk PState
_ a
result -> forall a b. a -> Either a b
Left a
result
PFailed [String]
message Position
pos -> forall a b. b -> Either a b
Right ([String]
message, Position
pos)
where initialState :: PState
initialState = PState {
curPos :: Position
curPos = Position
pos,
curInput :: String
curInput = String
input,
prevToken :: CToken
prevToken = forall a. String -> a
interr String
"CLexer.execParser: Touched undefined token!",
namesupply :: [Name]
namesupply = [Name]
names,
tyidents :: Set Ident
tyidents = forall a. Ord a => [a] -> Set a
Set.fromList [Ident]
builtins,
scopes :: [Set Ident]
scopes = []
}
{-# INLINE returnP #-}
returnP :: a -> P a
returnP :: forall a. a -> P a
returnP a
a = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \PState
s -> forall a. PState -> a -> ParseResult a
POk PState
s a
a
{-# INLINE thenP #-}
thenP :: P a -> (a -> P b) -> P b
(P PState -> ParseResult a
m) thenP :: forall a b. P a -> (a -> P b) -> P b
`thenP` a -> P b
k = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \PState
s ->
case PState -> ParseResult a
m PState
s of
POk PState
s' a
a -> (forall a. P a -> PState -> ParseResult a
unP (a -> P b
k a
a)) PState
s'
PFailed [String]
err Position
pos -> forall a. [String] -> Position -> ParseResult a
PFailed [String]
err Position
pos
failP :: Position -> [String] -> P a
failP :: forall a. Position -> [String] -> P a
failP Position
pos [String]
msg = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \PState
_ -> forall a. [String] -> Position -> ParseResult a
PFailed [String]
msg Position
pos
getNewName :: P Name
getNewName :: P Name
getNewName = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{namesupply :: PState -> [Name]
namesupply=(Name
n:[Name]
ns)} -> forall a. PState -> a -> ParseResult a
POk PState
s{namesupply :: [Name]
namesupply=[Name]
ns} Name
n
setPos :: Position -> P ()
setPos :: Position -> P ()
setPos Position
pos = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \PState
s -> forall a. PState -> a -> ParseResult a
POk PState
s{curPos :: Position
curPos=Position
pos} ()
getPos :: P Position
getPos :: P Position
getPos = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{curPos :: PState -> Position
curPos=Position
pos} -> forall a. PState -> a -> ParseResult a
POk PState
s Position
pos
addTypedef :: Ident -> P ()
addTypedef :: Ident -> P ()
addTypedef Ident
ident = (forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyidents} ->
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents :: Set Ident
tyidents = Ident
ident forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set Ident
tyidents} ())
shadowTypedef :: Ident -> P ()
shadowTypedef :: Ident -> P ()
shadowTypedef Ident
ident = (forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyidents} ->
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents :: Set Ident
tyidents = if Ident
ident forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Ident
tyidents
then Ident
ident forall a. Ord a => a -> Set a -> Set a
`Set.delete` Set Ident
tyidents
else Set Ident
tyidents } ())
isTypeIdent :: Ident -> P Bool
isTypeIdent :: Ident -> P Bool
isTypeIdent Ident
ident = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyidents} ->
forall a. PState -> a -> ParseResult a
POk PState
s forall a b. (a -> b) -> a -> b
$! forall a. Ord a => a -> Set a -> Bool
Set.member Ident
ident Set Ident
tyidents
enterScope :: P ()
enterScope :: P ()
enterScope = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyidents,scopes :: PState -> [Set Ident]
scopes=[Set Ident]
ss} ->
forall a. PState -> a -> ParseResult a
POk PState
s{scopes :: [Set Ident]
scopes=Set Ident
tyidentsforall a. a -> [a] -> [a]
:[Set Ident]
ss} ()
leaveScope :: P ()
leaveScope :: P ()
leaveScope = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{scopes :: PState -> [Set Ident]
scopes=[Set Ident]
ss} ->
case [Set Ident]
ss of
[] -> forall a. String -> a
interr String
"leaveScope: already in global scope"
(Set Ident
tyidents:[Set Ident]
ss') -> forall a. PState -> a -> ParseResult a
POk PState
s{tyidents :: Set Ident
tyidents=Set Ident
tyidents, scopes :: [Set Ident]
scopes=[Set Ident]
ss'} ()
getInput :: P String
getInput :: P String
getInput = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{curInput :: PState -> String
curInput=String
i} -> forall a. PState -> a -> ParseResult a
POk PState
s String
i
setInput :: String -> P ()
setInput :: String -> P ()
setInput String
i = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \PState
s -> forall a. PState -> a -> ParseResult a
POk PState
s{curInput :: String
curInput=String
i} ()
getLastToken :: P CToken
getLastToken :: P CToken
getLastToken = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{prevToken :: PState -> CToken
prevToken=CToken
tok} -> forall a. PState -> a -> ParseResult a
POk PState
s CToken
tok
setLastToken :: CToken -> P ()
setLastToken :: CToken -> P ()
setLastToken CToken
tok = forall a. (PState -> ParseResult a) -> P a
P forall a b. (a -> b) -> a -> b
$ \PState
s -> forall a. PState -> a -> ParseResult a
POk PState
s{prevToken :: CToken
prevToken=CToken
tok} ()