Add byte offset

Author: sol

solid-pp/src/Solid/PP/NewLexer.hs

@@ -2,61 +2,78 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE RecordWildCards #-}
 
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE BlockArguments #-}
 
 module Solid.PP.NewLexer where
 
-import Prelude hiding (mod, takeWhile)
+import Prelude hiding (span, mod, takeWhile)
 
 import Data.Char
 import Data.Functor
 import Data.Text (Text)
 import Data.Text.Internal (Text(..))
 import Data.Text.Unsafe (Iter(..))
+import Data.Text.Internal.Encoding.Utf8
 import qualified Data.Text.Unsafe as Unsafe
 import qualified Data.Text as T
 
-data SrcLoc = SrcLoc
-  { offset :: !Int
-  , line   :: !Int
-  , column :: !Int
-  } deriving (Show, Eq)
+data Location = Location {
+  offset :: !Int
+, charOffset :: !Int
+, line :: !Int
+, column :: !Int
+} deriving (Show, Eq) -- FIXME: Eq should not be used in production code; only compare offset instead
+
+data SrcSpan = SrcSpan {
+  start :: Location
+, end   :: Location
+} deriving (Show, Eq) -- FIXME: Eq should not be used in production code; only compare offset instead
+
+data Tok = Tok {
+  tokenType :: TokenType
+, span :: SrcSpan
+} deriving (Show, Eq)
+
+textSpan :: Text -> Tok -> Text
+textSpan input token = textSpan__ input token.span
 
-data SrcSpan = SrcSpan
-  { start :: SrcLoc
-  , end   :: SrcLoc
-  } deriving (Show, Eq)
+textSpan__ :: Text -> SrcSpan -> Text
+textSpan__ input span = textSpan_ input start end
+  where
+    start = span.start.offset
+    end = span.end.offset
 
-data Token = Token
-  { tokType :: TokenType
-  , tokSpan :: SrcSpan
-  } deriving (Show, Eq)
+textSpan_ :: Text -> Int -> Int -> Text
+textSpan_ (Text arr _ _) start end = Text arr start (end - start)
 
 data TokenType =
-    TokKeyword Text
-  | Identifier Text
+    Keyword
+  | Identifier
   | QualifiedIdentifier Text Text
-  | Constructor Text
+  | Constructor
   | QualifiedConstructor Text Text
   | IncompleteQualifiedName Text
-  | TokOperator Text
-  | Integer Text
-  | TokSymbol Char
-  | TokComment Text
+  | Operator Text
+  | Integer
+  | String
+  | Symbol Char
+  | Comment
   | EndOfFile
   deriving (Show, Eq)
 
 data Lexer = Lexer {
-  current :: SrcLoc
+  current :: Location
 , input   :: Text
 } deriving (Show, Eq)
 
-data WithSrcSpan a = WithSrcSpan
-  { span  :: SrcSpan
-  , value :: a
-  } deriving (Show, Eq)
+data WithSrcSpan a = WithSrcSpan {
+  span  :: SrcSpan
+, value :: a
+} deriving (Show, Eq)
 
 newtype LexerM a = LexerM { unLexerM :: Lexer -> (Lexer, a) }
 
@@ -76,10 +93,6 @@ instance Monad LexerM where
         LexerM mb = f a
     in mb s'
 
--- running
-runLexer :: LexerM a -> Text -> a
-runLexer (LexerM m) txt = snd (m (Lexer (SrcLoc 0 1 1) txt))
-
 -- primitives
 get :: LexerM Lexer
 get = LexerM \s -> (s, s)
@@ -120,20 +133,21 @@ peekChar = do
   return $ if T.null lexer.input then '\0' else T.head lexer.input
 
 -- Lexer driver
-tokenize :: Text -> [Token]
-tokenize input = loop (Lexer (SrcLoc 0 1 1) input)
+tokenize :: Text -> [Tok]
+tokenize input@(Text _ off _) = loop (Lexer (Location off 0 1 1) input)
   where
-    loop lexer = case unLexerM lexOne lexer of
-      (_, Token EndOfFile _) -> []
+    loop :: Lexer -> [Tok]
+    loop lexer = case lexOne.unLexerM lexer of
+      (_, Tok EndOfFile _) -> []
       (new, token) -> token : loop new
 
-lexOne :: LexerM Token
+lexOne :: LexerM Tok
 lexOne = do
   lexer <- get
   mc <- peekChar
   case mc of
     c
-      | c == '\0' -> return (Token EndOfFile $ SrcSpan lexer.current lexer.current)
+      | c == '\0' -> return (Tok EndOfFile $ SrcSpan lexer.current lexer.current)
     {-
       | T.isPrefixOf "--" <$> (input <$> get) -> do
           comment <- takeUntil (== '\n')
@@ -145,45 +159,69 @@ lexOne = do
 
       | isLower c || c == '_' -> do
           word <- takeWhile isIdChar
+          {-
           let typ = if word.value `elem` keywords
                       then TokKeyword word.value
                       else Identifier word.value
           pure $ Token typ word.span
+          -}
+          pure $ Tok Identifier word.span
 
-      | isUpper c -> LexerM qualifiedName
+      | isUpper c -> do
+          word <- takeWhile isIdChar
+          pure $ Tok Constructor word.span
+          -- LexerM qualifiedName
 
       | isDigit c -> do
           num <- takeWhile isDigit
-          pure $ Token (Integer num.value) num.span
+          pure $ Tok Integer num.span
+
+      | c == '"' -> do
+          string
+          new <- get
+          pure $ Tok String (SrcSpan lexer.current new.current)
+
       | c `elem` operators -> do
           op <- takeWhile (`elem` operators)
-          pure $ Token (TokOperator op.value) op.span
+          pure $ Tok (Operator op.value) op.span
       | c `elem` symbols -> do
           sym <- consumeChar
-          pure $ Token (TokSymbol sym.value) sym.span
+          pure $ Tok (Symbol sym.value) sym.span
       | otherwise -> do
           ch <- consumeChar
-          pure $ Token (TokComment $ T.pack [ch.value]) ch.span -- FIXME
+          pure $ Tok Comment ch.span -- FIXME
 
-qualifiedName :: Lexer -> (Lexer, Token)
+string :: LexerM (WithSrcSpan Char)
+string = loop
+  where
+    loop = do
+      _ <- consumeChar
+      _ <- takeUntil (\ c -> c == '"' || c == '\\')
+      c <- peekChar
+      if
+        | c == '"' -> consumeChar
+        | c == '\\' -> consumeChar >> loop
+        | otherwise -> undefined -- partial string - eof
+
+qualifiedName :: Lexer -> (Lexer, Tok)
 qualifiedName Lexer{..} = scanConstructor -1 0
   where
-    scanConstructor :: Int -> Int -> (Lexer, Token)
+    scanConstructor :: Int -> Int -> (Lexer, Tok)
     scanConstructor lastDot !i
       | c == '.' = scanIdentifier (i + d)
       | isIdChar c = scanConstructor lastDot (i + d)
       | otherwise = done
       where
-        done :: (Lexer, Token)
+        done :: (Lexer, Tok)
         done = accept i \ match ->
           if lastDot < 0 then
-            Constructor match
+            Constructor
           else
             QualifiedConstructor (Unsafe.takeWord8 (lastDot - 1) match) (Unsafe.dropWord8 lastDot match)
 
         Iter c d = safeIter input i
 
-    scanIdentifier :: Int -> (Lexer, Token)
+    scanIdentifier :: Int -> (Lexer, Tok)
     scanIdentifier !i
       | isLower c = accept (findEndOfId i) \ match ->
           let
@@ -203,7 +241,7 @@ qualifiedName Lexer{..} = scanConstructor -1 0
       where
         Iter c d = safeIter input i
 
-    accept :: Int -> (Text -> TokenType) -> (Lexer, Token)
+    accept :: Int -> (Text -> TokenType) -> (Lexer, Tok)
     accept n f =
       let
         match = Unsafe.takeWord8 n input
@@ -212,7 +250,7 @@ qualifiedName Lexer{..} = scanConstructor -1 0
           current = advanceText current match
         , input = rest
         }
-      in (new, Token (f match) (SrcSpan current new.current))
+      in (new, Tok (f match) (SrcSpan current new.current))
 
 
 isIdChar :: Char -> Bool
@@ -233,12 +271,12 @@ operators = ":!#$%&*+./<=>?@\\^|-~"
 symbols :: [Char]
 symbols = "(),;[]{}"
 
-advanceChar :: SrcLoc -> Char -> SrcLoc
-advanceChar (SrcLoc o l c) ch
-  | ch == '\n' = SrcLoc (o + 1) (l + 1) 1
-  | otherwise  = SrcLoc (o + 1) l (c + 1)
+advanceChar :: Location -> Char -> Location
+advanceChar (Location offset o l c) ch
+  | ch == '\n' = Location (offset + utf8Length ch) (o + 1) (l + 1) 1
+  | otherwise  = Location (offset + utf8Length ch) (o + 1) l (c + 1)
 
-advanceText :: SrcLoc -> Text -> SrcLoc
+advanceText :: Location -> Text -> Location
 advanceText = T.foldl' advanceChar
 
 safeIter :: Text -> Int -> Iter