haskell: merge lookup of symbols and identifier prefixes

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

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