haskell: merge lookup of symbols and identifier prefixes
This commit is contained in:
parent
31c6f1a717
commit
9b6229f9fd
|
@ -38,14 +38,10 @@ data TokenKind = TIdent Ident
|
|||
|
||||
data IdentPrefix = IpDot | IpPatOut
|
||||
|
||||
lexeIdentPrefixTree :: HandleTree IdentPrefix
|
||||
lexeIdentPrefixTree = HandleTree (H.fromList l1) Nothing
|
||||
where
|
||||
l1 = [('.', Htleaf IpDot), ('$', Htleaf IpPatOut)]
|
||||
data TokiOrIdepfx = Toki TokenKind | Idepfx IdentPrefix
|
||||
|
||||
handleIdentsI :: Parser' Error (Maybe TokenKind)
|
||||
handleIdentsI = do
|
||||
pfx <- eats lexeIdentPrefixTree
|
||||
handleIdentsI :: Maybe IdentPrefix -> Parser' Error (Maybe TokenKind)
|
||||
handleIdentsI pfx = do
|
||||
marker <- gets peOffset
|
||||
ident' <- takeIdent
|
||||
ident <- case ident' of
|
||||
|
@ -73,13 +69,20 @@ lexe = do
|
|||
lexeComments 0
|
||||
|
||||
-- handle symbols
|
||||
symb <- lexeSymbols
|
||||
(sp, symb) <- lexeSymbols
|
||||
case symb of
|
||||
Just tok -> fmap (tok:) lexe
|
||||
Nothing -> recordSpan handleIdentsI >>= \(sp, mtk) ->
|
||||
Just (Toki toki) -> fmap ((Token sp toki):) lexe
|
||||
Just (Idepfx pfx) -> handleIdentsI' $ Just ((start sp), pfx)
|
||||
Nothing -> handleIdentsI' Nothing
|
||||
|
||||
where
|
||||
fixSpan Nothing sp = sp
|
||||
fixSpan (Just (x, _)) sp = sp { start = x }
|
||||
|
||||
handleIdentsI' pfx = recordSpan (handleIdentsI (fmap (\(_, x) -> x) pfx)) >>= \(sp, mtk) ->
|
||||
case mtk of
|
||||
Nothing -> pure []
|
||||
Just tk -> fmap ((Token sp tk):) lexe
|
||||
Just tk -> fmap ((Token (fixSpan pfx sp) tk):) lexe
|
||||
|
||||
data LevelDelta = LevelIncr | LevelDecr deriving (Show)
|
||||
|
||||
|
@ -114,19 +117,18 @@ lexeComments lvl = do
|
|||
-- or we skip over a single character and continue
|
||||
Nothing -> if lvl <= 0 then pure () else tryOne (\_ -> Just ()) >> lexeComments lvl
|
||||
|
||||
lexeSymbolsTree :: HandleTree TokenKind
|
||||
lexeSymbolsTree = HandleTree (H.fromList l1) Nothing
|
||||
where
|
||||
-- NOTE: we can't handle '.' and '$' here (they might be followed by identifiers)
|
||||
l1 = [('^', Htleaf TCaret ), ('(', Htleaf TLParen), (')', Htleaf TRParen)
|
||||
,('{', Htleaf TLBrace ), ('}', Htleaf TRBrace), (':', Htleaf TDubColon)
|
||||
,(';', Htleaf TSemiColon), ('=', Htleaf TAssign)
|
||||
,('←', Htleaf TLArr ), ('→', Htleaf TRArr )
|
||||
]
|
||||
|
||||
recordToken :: Functor f => Parser' e (f TokenKind) -> Parser' e (f Token)
|
||||
recordToken tkp = recordSpan tkp >>=
|
||||
\(sp, tk) -> pure $ fmap (\y -> Token sp y) tk
|
||||
|
||||
lexeSymbols :: Parser' e (Maybe Token)
|
||||
lexeSymbols = recordToken (eats lexeSymbolsTree)
|
||||
lexeSymbols :: Parser' e (Span, Maybe TokiOrIdepfx)
|
||||
lexeSymbols = recordSpan . tryOne $ \c -> case c of
|
||||
'^' -> Just $ Toki TCaret
|
||||
'(' -> Just $ Toki TLParen
|
||||
')' -> Just $ Toki TRParen
|
||||
'{' -> Just $ Toki TLBrace
|
||||
'}' -> Just $ Toki TRBrace
|
||||
':' -> Just $ Toki TDubColon
|
||||
';' -> Just $ Toki TSemiColon
|
||||
'=' -> Just $ Toki TAssign
|
||||
'←' -> Just $ Toki TLArr
|
||||
'→' -> Just $ Toki TRArr
|
||||
'.' -> Just $ Idepfx IpDot
|
||||
'$' -> Just $ Idepfx IpPatOut
|
||||
_ -> Nothing
|
||||
|
|
|
@ -17,6 +17,7 @@ module Language.Yanais.Parser (
|
|||
-- creating and running parsers
|
||||
makeParseEnv,
|
||||
runParser,
|
||||
makeParser,
|
||||
parseFile,
|
||||
|
||||
-- parser combinators
|
||||
|
@ -28,6 +29,7 @@ module Language.Yanais.Parser (
|
|||
tryOne,
|
||||
eats,
|
||||
recordSpan,
|
||||
flatEither,
|
||||
) where
|
||||
|
||||
import Prelude hiding (takeWhile, span, splitAt)
|
||||
|
@ -36,6 +38,7 @@ import Control.DeepSeq (NFData)
|
|||
import Control.Monad.Error.Class (MonadError(..))
|
||||
import Control.Monad.State.Strict
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Kind (Type)
|
||||
import qualified Data.ByteString as Bb
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.UTF8 as B
|
||||
|
@ -63,7 +66,7 @@ instance Semigroup Span where
|
|||
|
||||
-- misc failure conditions
|
||||
class ParserError e where
|
||||
type PErrEnv e :: *
|
||||
type PErrEnv e :: Type
|
||||
|
||||
-- | an unknown error (the state might indicate where the error happened)
|
||||
perrUnknown :: PErrEnv e -> e
|
||||
|
@ -75,6 +78,10 @@ class ParserError e where
|
|||
-- a generic parser monad
|
||||
newtype Parser s e a = Parser { runP :: StateT s (Either e) a }
|
||||
|
||||
-- | lift an unwrapped parser into our structures
|
||||
makeParser :: ((s1 -> Either e1 (a, s1)) -> (s2 -> Either e2 (b, s2))) -> Parser s1 e1 a -> Parser s2 e2 b
|
||||
makeParser f (Parser (StateT origp)) = Parser . StateT $ f origp
|
||||
|
||||
instance Functor (Parser s e) where
|
||||
fmap f = Parser . (fmap f) . runP
|
||||
{-# INLINE fmap #-}
|
||||
|
@ -138,6 +145,13 @@ parseFile f p = do
|
|||
|
||||
-- some simple parser combinators
|
||||
|
||||
-- | shave an either from the parser result and possibly throw errors into the parser itself
|
||||
flatEither :: Parser s e (Either e a) -> Parser s e a
|
||||
flatEither = makeParser $ \inner st -> case inner st of
|
||||
Left x -> Left x
|
||||
Right (Left x, _) -> Left x
|
||||
Right (Right y, st2) -> Right (y, st2)
|
||||
|
||||
shiftEnv :: (Int, Text) -> Parser' e ()
|
||||
shiftEnv (ll, r) = Parser $ modify go
|
||||
where
|
||||
|
|
Loading…
Reference in a new issue