{-|
Module      : Toml.Lexer.Utils
Description : Wrapper and actions for generated lexer
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

This module provides a custom engine for the Alex generated
lexer. This lexer drive provides nested states, unicode support,
and file location tracking.

-}
module Toml.Lexer.Utils (
    
    -- * Types
    M, Action,
    Context(..),

    -- * Actions
    value,
    value_,
    token,
    token_,
    enterList,
    exitList,
    enterTable,
    exitTable,
    equals,
    timeValue,

    -- * Alex extension points
    AlexInput,
    alexGetByte,

    ) where

import Control.Monad.Trans.State.Strict (State, modify, state)
import Data.Char (ord, isAscii)
import Data.Foldable (asum)
import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime)

import Toml.Located (Located(..))
import Toml.Position (move)
import Toml.Lexer.Token (Token(..))

type M a = State [Context] a

type Action = String -> M Token

data Context
  = ListContext  -- ^ processing an inline list, lex values
  | TableContext -- ^ processing an inline table, don't lex values
  | ValueContext -- ^ processing after an equals, lex one value
  deriving Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show

pushContext :: Context -> M ()
pushContext :: Context -> M ()
pushContext Context
cxt = forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify \[Context]
st ->
  case [Context]
st of
    Context
ValueContext : [Context]
st' -> Context
cxt forall a. a -> [a] -> [a]
: [Context]
st'
    [Context]
_                  -> Context
cxt forall a. a -> [a] -> [a]
: [Context]
st

equals :: Action
equals :: Action
equals String
_ = Token
TokEquals forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Context -> M ()
pushContext Context
ValueContext

enterList :: Action
enterList :: Action
enterList String
_ = Token
TokSquareO forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Context -> M ()
pushContext Context
ListContext

enterTable :: Action
enterTable :: Action
enterTable String
_ = Token
TokCurlyO forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Context -> M ()
pushContext Context
TableContext

exitTable :: Action
exitTable :: Action
exitTable String
_ = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state \case
  Context
TableContext : [Context]
st -> (Token
TokCurlyC             , [Context]
st)
  [Context]
st                -> (String -> Token
TokError String
"Unmatched }", [Context]
st)

exitList :: Action
exitList :: Action
exitList String
_ = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state \case
  Context
ListContext : [Context]
st -> (Token
TokSquareC            , [Context]
st)
  []               -> (Token
TokSquareC            , [])
  [Context]
st               -> (String -> Token
TokError String
"Unmatched ]", [Context]
st)

token_ :: Token -> Action
token_ :: Token -> Action
token_ Token
t String
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
t

token :: (String -> Token) -> Action
token :: (String -> Token) -> Action
token String -> Token
f String
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Token
f String
x)

value_ :: Token -> Action
value_ :: Token -> Action
value_ Token
t String
_ = forall a. a -> M a
emitValue Token
t

value :: (String -> Token) -> Action
value :: (String -> Token) -> Action
value String -> Token
f String
x = forall a. a -> M a
emitValue (String -> Token
f String
x)

emitValue :: a -> M a
emitValue :: forall a. a -> M a
emitValue a
v = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state \[Context]
st ->
  case [Context]
st of
    Context
ValueContext:[Context]
st' -> (a
v, [Context]
st')
    [Context]
_                -> (a
v, [Context]
st )

timeValue :: ParseTime a => String -> [String] -> (a -> Token) -> Action
timeValue :: forall a.
ParseTime a =>
String -> [String] -> (a -> Token) -> Action
timeValue String
description [String]
patterns a -> Token
constructor = (String -> Token) -> Action
value \String
str ->
  case forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale String
pattern String
str | String
pattern <- [String]
patterns] of
    Maybe a
Nothing -> String -> Token
TokError (String
"Malformed " forall a. [a] -> [a] -> [a]
++ String
description)
    Just a
t  -> a -> Token
constructor a
t

type AlexInput = Located String

alexGetByte :: AlexInput -> Maybe (Int, AlexInput)
alexGetByte :: AlexInput -> Maybe (Int, AlexInput)
alexGetByte Located { locPosition :: forall a. Located a -> Position
locPosition = Position
p, locThing :: forall a. Located a -> a
locThing = String
str } =
  case String
str of
    String
"" -> forall a. Maybe a
Nothing
    Char
x:String
xs
      | Char
x forall a. Eq a => a -> a -> Bool
== Char
'\1' -> forall a. a -> Maybe a
Just (Int
0,     AlexInput
rest)
      | Char -> Bool
isAscii Char
x -> forall a. a -> Maybe a
Just (Char -> Int
ord Char
x, AlexInput
rest)
      | Bool
otherwise -> forall a. a -> Maybe a
Just (Int
1,     AlexInput
rest)
      where
        rest :: AlexInput
rest = Located { locPosition :: Position
locPosition = Char -> Position -> Position
move Char
x Position
p, locThing :: String
locThing = String
xs }