module Toml.Lexer.Utils (
Action,
Context(..),
Outcome(..),
locatedUncons,
token,
token_,
timeValue,
eofToken,
failure,
strFrag,
startMlBstr,
startBstr,
startMlLstr,
startLstr,
endStr,
unicodeEscape,
recommendEscape,
mkError,
) where
import Data.Char (ord, chr, isAscii, isControl)
import Data.Foldable (asum)
import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime)
import Numeric (readHex)
import Text.Printf (printf)
import Toml.Lexer.Token (Token(..))
import Toml.Located (Located(..))
import Toml.Position (move, Position)
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"
recommendEscape :: Action
recommendEscape :: Action
recommendEscape (Located Position
p String
x) Context
_ =
Located String -> Outcome
LexerError (forall a. Position -> a -> Located a
Located Position
p (forall r. PrintfType r => String -> r
printf String
"control characters must be escaped, use: \\u%04X" (Char -> Int
ord (forall a. [a] -> a
head String
x))))
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
_)
| Char -> Bool
isControl Char
x = String
"control characters prohibited"
| Bool
otherwise = String
"unexpected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
x