module Toml.Lexer.Utils (
Action,
Context(..),
Outcome(..),
locatedUncons,
token,
token_,
timeValue,
eofToken,
failure,
strFrag,
startMlBstr,
startBstr,
startMlLstr,
startLstr,
endStr,
unicodeEscape,
mkError,
) where
import Data.Char (ord, chr, isAscii)
import Data.Foldable (asum)
import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime)
import Numeric (readHex)
import Toml.Located (Located(..))
import Toml.Position (move, Position)
import Toml.Lexer.Token (Token(..))
type Action = Located String -> Context -> Outcome
data Outcome
= Resume Context
| LexerError (Located String)
| EmitToken (Located Token)
data Context
= TopContext
| TableContext
| ValueContext
| MlBstrContext Position [String]
| BstrContext Position [String]
| MlLstrContext Position [String]
| LstrContext Position [String]
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
strFrag :: Action
strFrag :: Action
strFrag (Located Position
_ String
s) = \case
BstrContext Position
p [String]
acc -> Context -> Outcome
Resume (Position -> [String] -> Context
BstrContext Position
p (String
s forall a. a -> [a] -> [a]
: [String]
acc))
MlBstrContext Position
p [String]
acc -> Context -> Outcome
Resume (Position -> [String] -> Context
MlBstrContext Position
p (String
s forall a. a -> [a] -> [a]
: [String]
acc))
LstrContext Position
p [String]
acc -> Context -> Outcome
Resume (Position -> [String] -> Context
LstrContext Position
p (String
s forall a. a -> [a] -> [a]
: [String]
acc))
MlLstrContext Position
p [String]
acc -> Context -> Outcome
Resume (Position -> [String] -> Context
MlLstrContext Position
p (String
s forall a. a -> [a] -> [a]
: [String]
acc))
Context
_ -> forall a. HasCallStack => String -> a
error String
"strFrag: panic"
endStr :: Action
endStr :: Action
endStr (Located Position
_ String
x) = \case
BstrContext Position
p [String]
acc -> Located Token -> Outcome
EmitToken (forall a. Position -> a -> Located a
Located Position
p (String -> Token
TokString (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse (String
x forall a. a -> [a] -> [a]
: [String]
acc)))))
MlBstrContext Position
p [String]
acc -> Located Token -> Outcome
EmitToken (forall a. Position -> a -> Located a
Located Position
p (String -> Token
TokMlString (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse (String
x forall a. a -> [a] -> [a]
: [String]
acc)))))
LstrContext Position
p [String]
acc -> Located Token -> Outcome
EmitToken (forall a. Position -> a -> Located a
Located Position
p (String -> Token
TokString (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse (String
x forall a. a -> [a] -> [a]
: [String]
acc)))))
MlLstrContext Position
p [String]
acc -> Located Token -> Outcome
EmitToken (forall a. Position -> a -> Located a
Located Position
p (String -> Token
TokMlString (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse (String
x forall a. a -> [a] -> [a]
: [String]
acc)))))
Context
_ -> forall a. HasCallStack => String -> a
error String
"endStr: panic"
startBstr :: Action
startBstr :: Action
startBstr (Located Position
p String
_) Context
_ = Context -> Outcome
Resume (Position -> [String] -> Context
BstrContext Position
p [])
startLstr :: Action
startLstr :: Action
startLstr (Located Position
p String
_) Context
_ = Context -> Outcome
Resume (Position -> [String] -> Context
LstrContext Position
p [])
startMlBstr :: Action
startMlBstr :: Action
startMlBstr (Located Position
p String
_) Context
_ = Context -> Outcome
Resume (Position -> [String] -> Context
MlBstrContext Position
p [])
startMlLstr :: Action
startMlLstr :: Action
startMlLstr (Located Position
p String
_) Context
_ = Context -> Outcome
Resume (Position -> [String] -> Context
MlLstrContext Position
p [])
unicodeEscape :: Action
unicodeEscape :: Action
unicodeEscape (Located Position
p String
lexeme) Context
ctx =
case forall a. (Eq a, Num a) => ReadS a
readHex (forall a. Int -> [a] -> [a]
drop Int
2 String
lexeme) of
[(Int
n,String
_)] | Int
0xd800 forall a. Ord a => a -> a -> Bool
<= Int
n, Int
n forall a. Ord a => a -> a -> Bool
< Int
0xe000 -> Located String -> Outcome
LexerError (forall a. Position -> a -> Located a
Located Position
p String
"non-scalar unicode escape")
| Int
n forall a. Ord a => a -> a -> Bool
>= Int
0x110000 -> Located String -> Outcome
LexerError (forall a. Position -> a -> Located a
Located Position
p String
"unicode escape too large")
| Bool
otherwise -> Action
strFrag (forall a. Position -> a -> Located a
Located Position
p [Int -> Char
chr Int
n]) Context
ctx
[(Int, String)]
_ -> forall a. HasCallStack => String -> a
error String
"unicodeEscape: panic"
token_ :: Token -> Action
token_ :: Token -> Action
token_ Token
t Located String
x Context
_ = Located Token -> Outcome
EmitToken (Token
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Located String
x)
token :: (String -> Token) -> Action
token :: (String -> Token) -> Action
token String -> Token
f Located String
x Context
_ = Located Token -> Outcome
EmitToken (String -> Token
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located String
x)
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 (Located Position
p String
str) Context
_ =
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
pat String
str | String
pat <- [String]
patterns] of
Maybe a
Nothing -> Located String -> Outcome
LexerError (forall a. Position -> a -> Located a
Located Position
p (String
"malformed " forall a. [a] -> [a] -> [a]
++ String
description))
Just a
t -> Located Token -> Outcome
EmitToken (forall a. Position -> a -> Located a
Located Position
p (a -> Token
constructor a
t))
locatedUncons :: Located String -> Maybe (Int, Located String)
locatedUncons :: Located String -> Maybe (Int, Located String)
locatedUncons 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
| Located String
rest seq :: forall a b. a -> b -> b
`seq` Bool
False -> forall a. HasCallStack => a
undefined
| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\1' -> forall a. a -> Maybe a
Just (Int
0, Located String
rest)
| Char -> Bool
isAscii Char
x -> forall a. a -> Maybe a
Just (Char -> Int
ord Char
x, Located String
rest)
| Bool
otherwise -> forall a. a -> Maybe a
Just (Int
1, Located String
rest)
where
rest :: Located String
rest = Located { locPosition :: Position
locPosition = Char -> Position -> Position
move Char
x Position
p, locThing :: String
locThing = String
xs }
eofToken :: Context -> Located String -> Either (Located String) (Located Token, Located String)
eofToken :: Context
-> Located String
-> Either (Located String) (Located Token, Located String)
eofToken (MlBstrContext Position
p [String]
_) Located String
_ = forall a b. a -> Either a b
Left (forall a. Position -> a -> Located a
Located Position
p String
"unterminated multi-line basic string")
eofToken (BstrContext Position
p [String]
_) Located String
_ = forall a b. a -> Either a b
Left (forall a. Position -> a -> Located a
Located Position
p String
"unterminated basic string")
eofToken (MlLstrContext Position
p [String]
_) Located String
_ = forall a b. a -> Either a b
Left (forall a. Position -> a -> Located a
Located Position
p String
"unterminated multi-line literal string")
eofToken (LstrContext Position
p [String]
_) Located String
_ = forall a b. a -> Either a b
Left (forall a. Position -> a -> Located a
Located Position
p String
"unterminated literal string")
eofToken Context
_ Located String
t = forall a b. b -> Either a b
Right (Token
TokEOF forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Located String
t, Located String
t)
failure :: String -> Action
failure :: String -> Action
failure String
err Located String
t Context
_ = Located String -> Outcome
LexerError (String
err forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Located String
t)
mkError :: String -> String
mkError :: ShowS
mkError String
"" = String
"unexpected end-of-input"
mkError (Char
'\n':String
_) = String
"unexpected end-of-line"
mkError (Char
'\r':Char
'\n':String
_) = String
"unexpected end-of-line"
mkError (Char
x:String
_) = String
"unexpected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
x