{-# 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 { P a -> PState -> ParseResult a
unP :: PState -> ParseResult a }
instance MonadFail P where
fail :: String -> P a
fail String
m = P Position
getPos P Position -> (Position -> P a) -> P a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Position
pos -> Position -> [String] -> P a
forall a. Position -> [String] -> P a
failP Position
pos [String
m]
instance Functor P where
fmap :: (a -> b) -> P a -> P b
fmap = (a -> b) -> P a -> P b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative P where
pure :: a -> P a
pure = a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: P (a -> b) -> P a -> P 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 :: a -> P a
return = a -> P a
forall a. a -> P a
returnP
>>= :: P a -> (a -> P b) -> P 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 :: 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 -> a -> Either a ([String], Position)
forall a b. a -> Either a b
Left a
result
PFailed [String]
message Position
pos -> ([String], Position) -> Either a ([String], Position)
forall a b. b -> Either a b
Right ([String]
message, Position
pos)
where initialState :: PState
initialState = PState :: Position
-> String -> CToken -> [Name] -> Set Ident -> [Set Ident] -> PState
PState {
curPos :: Position
curPos = Position
pos,
curInput :: String
curInput = String
input,
prevToken :: CToken
prevToken = String -> CToken
forall a. String -> a
interr String
"CLexer.execParser: Touched undefined token!",
namesupply :: [Name]
namesupply = [Name]
names,
tyidents :: Set Ident
tyidents = [Ident] -> Set Ident
forall a. Ord a => [a] -> Set a
Set.fromList [Ident]
builtins,
scopes :: [Set Ident]
scopes = []
}
{-# INLINE returnP #-}
returnP :: a -> P a
returnP :: a -> P a
returnP a
a = (PState -> ParseResult a) -> P a
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult a) -> P a)
-> (PState -> ParseResult a) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> a -> ParseResult a
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 :: P a -> (a -> P b) -> P b
`thenP` a -> P b
k = (PState -> ParseResult b) -> P b
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult b) -> P b)
-> (PState -> ParseResult b) -> P b
forall a b. (a -> b) -> a -> b
$ \PState
s ->
case PState -> ParseResult a
m PState
s of
POk PState
s' a
a -> (P b -> PState -> ParseResult b
forall a. P a -> PState -> ParseResult a
unP (a -> P b
k a
a)) PState
s'
PFailed [String]
err Position
pos -> [String] -> Position -> ParseResult b
forall a. [String] -> Position -> ParseResult a
PFailed [String]
err Position
pos
failP :: Position -> [String] -> P a
failP :: Position -> [String] -> P a
failP Position
pos [String]
msg = (PState -> ParseResult a) -> P a
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult a) -> P a)
-> (PState -> ParseResult a) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
_ -> [String] -> Position -> ParseResult a
forall a. [String] -> Position -> ParseResult a
PFailed [String]
msg Position
pos
getNewName :: P Name
getNewName :: P Name
getNewName = (PState -> ParseResult Name) -> P Name
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult Name) -> P Name)
-> (PState -> ParseResult Name) -> P Name
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{namesupply :: PState -> [Name]
namesupply=(Name
n:[Name]
ns)} -> PState -> Name -> ParseResult Name
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 = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{curPos :: Position
curPos=Position
pos} ()
getPos :: P Position
getPos :: P Position
getPos = (PState -> ParseResult Position) -> P Position
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult Position) -> P Position)
-> (PState -> ParseResult Position) -> P Position
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{curPos :: PState -> Position
curPos=Position
pos} -> PState -> Position -> ParseResult Position
forall a. PState -> a -> ParseResult a
POk PState
s Position
pos
addTypedef :: Ident -> P ()
addTypedef :: Ident -> P ()
addTypedef Ident
ident = ((PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyidents} ->
PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents :: Set Ident
tyidents = Ident
ident Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set Ident
tyidents} ())
shadowTypedef :: Ident -> P ()
shadowTypedef :: Ident -> P ()
shadowTypedef Ident
ident = ((PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyidents} ->
PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents :: Set Ident
tyidents = if Ident
ident Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Ident
tyidents
then Ident
ident Ident -> Set Ident -> Set 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 = (PState -> ParseResult Bool) -> P Bool
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult Bool) -> P Bool)
-> (PState -> ParseResult Bool) -> P Bool
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyidents} ->
PState -> Bool -> ParseResult Bool
forall a. PState -> a -> ParseResult a
POk PState
s (Bool -> ParseResult Bool) -> Bool -> ParseResult Bool
forall a b. (a -> b) -> a -> b
$! Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Ident
ident Set Ident
tyidents
enterScope :: P ()
enterScope :: P ()
enterScope = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> 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} ->
PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{scopes :: [Set Ident]
scopes=Set Ident
tyidentsSet Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
:[Set Ident]
ss} ()
leaveScope :: P ()
leaveScope :: P ()
leaveScope = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> 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
[] -> String -> ParseResult ()
forall a. String -> a
interr String
"leaveScope: already in global scope"
(Set Ident
tyidents:[Set Ident]
ss') -> PState -> () -> ParseResult ()
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 = (PState -> ParseResult String) -> P String
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult String) -> P String)
-> (PState -> ParseResult String) -> P String
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{curInput :: PState -> String
curInput=String
i} -> PState -> String -> ParseResult String
forall a. PState -> a -> ParseResult a
POk PState
s String
i
setInput :: String -> P ()
setInput :: String -> P ()
setInput String
i = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{curInput :: String
curInput=String
i} ()
getLastToken :: P CToken
getLastToken :: P CToken
getLastToken = (PState -> ParseResult CToken) -> P CToken
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult CToken) -> P CToken)
-> (PState -> ParseResult CToken) -> P CToken
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{prevToken :: PState -> CToken
prevToken=CToken
tok} -> PState -> CToken -> ParseResult CToken
forall a. PState -> a -> ParseResult a
POk PState
s CToken
tok
setLastToken :: CToken -> P ()
setLastToken :: CToken -> P ()
setLastToken CToken
tok = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{prevToken :: CToken
prevToken=CToken
tok} ()