diff --git a/haskell/nfker7h/lib/Language/Yanais/Nfker7h/Parser/Lex.hs b/haskell/nfker7h/lib/Language/Yanais/Nfker7h/Parser/Lex.hs index 0682562..aaf3368 100644 --- a/haskell/nfker7h/lib/Language/Yanais/Nfker7h/Parser/Lex.hs +++ b/haskell/nfker7h/lib/Language/Yanais/Nfker7h/Parser/Lex.hs @@ -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 diff --git a/haskell/nfker7h/lib/Language/Yanais/Parser.hs b/haskell/nfker7h/lib/Language/Yanais/Parser.hs index ca59a29..13a4c08 100644 --- a/haskell/nfker7h/lib/Language/Yanais/Parser.hs +++ b/haskell/nfker7h/lib/Language/Yanais/Parser.hs @@ -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