{-# LANGUAGE OverloadedStrings #-}

module Data.EDN.AST.Parser
  ( parseText
   -- * EDN document
  , parseDoc
    -- * Single value
  , parseTagged
  , parseValue
    -- * Primitive parsers
  , parseDiscard
  , parseNil
  , parseBool
  , parseNumber
  , parseKeyword
  , parseSymbol
  , parseCollections
    -- * Character classes
  , tagChars
  , keywordInitialChars
  , keywordChars
  , symbolInitialChars
  , symbolChars
    -- ** Basic characters
  , digitChars
  , lowerChars
  , upperChars
  , miscChars
  ) where

import Control.Applicative ((<|>))
import Data.Char (chr)
import Data.Text (Text)

import qualified Data.Text as Text
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P

import Data.EDN.AST.Types (Parser, Tagged(..), TaggedValue, Value(..))

import qualified Data.EDN.AST.Lexer as L
import qualified Data.EDN.AST.Types as EDN

parseText
  :: String -- ^ Source name, for megaparsec error reports
            -- e.g. @/path/to/file.edn@ or @<stdin>@
  -> Text   -- ^ EDN document body
  -> Either String TaggedValue
parseText :: String -> Text -> Either String TaggedValue
parseText String
sourceName =
  (ParseErrorBundle Text Void -> Either String TaggedValue)
-> (TaggedValue -> Either String TaggedValue)
-> Either (ParseErrorBundle Text Void) TaggedValue
-> Either String TaggedValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String TaggedValue
forall a b. a -> Either a b
Left (String -> Either String TaggedValue)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Either String TaggedValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
P.errorBundlePretty) TaggedValue -> Either String TaggedValue
forall a b. b -> Either a b
Right (Either (ParseErrorBundle Text Void) TaggedValue
 -> Either String TaggedValue)
-> (Text -> Either (ParseErrorBundle Text Void) TaggedValue)
-> Text
-> Either String TaggedValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Parsec Void Text TaggedValue
-> String
-> Text
-> Either (ParseErrorBundle Text Void) TaggedValue
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.parse Parsec Void Text TaggedValue
parseDoc String
sourceName

parseDoc :: Parser TaggedValue
parseDoc :: Parsec Void Text TaggedValue
parseDoc = do
  Parser ()
L.dropWS
  Parsec Void Text TaggedValue
parseTagged Parsec Void Text TaggedValue
-> Parser () -> Parsec Void Text TaggedValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof

parseTagged :: Parser TaggedValue
parseTagged :: Parsec Void Text TaggedValue
parseTagged = [Parsec Void Text TaggedValue] -> Parsec Void Text TaggedValue
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
  [ Parsec Void Text TaggedValue -> Parsec Void Text TaggedValue
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try Parsec Void Text TaggedValue
withNS
  , Parsec Void Text TaggedValue -> Parsec Void Text TaggedValue
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try Parsec Void Text TaggedValue
withoutNS
  , Parsec Void Text TaggedValue
forall tag. ParsecT Void Text Identity (Tagged tag Value)
withoutTag
  ]
  where
    withNS :: Parsec Void Text TaggedValue
withNS = Text -> Text -> Value -> TaggedValue
forall tag a. tag -> tag -> a -> Tagged tag a
Tagged
      (Text -> Text -> Value -> TaggedValue)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Value -> TaggedValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'#' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
parseIdent)
      ParsecT Void Text Identity (Text -> Value -> TaggedValue)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Value -> TaggedValue)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'/' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
parseIdent)
      ParsecT Void Text Identity (Value -> TaggedValue)
-> ParsecT Void Text Identity Value -> Parsec Void Text TaggedValue
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
L.dropWS Parser ()
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Value
parseValue)

    withoutNS :: Parsec Void Text TaggedValue
withoutNS = Text -> Text -> Value -> TaggedValue
forall tag a. tag -> tag -> a -> Tagged tag a
Tagged
      (Text -> Text -> Value -> TaggedValue)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Value -> TaggedValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParsecT Void Text Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty
      ParsecT Void Text Identity (Text -> Value -> TaggedValue)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Value -> TaggedValue)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'#' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
parseIdent)
      ParsecT Void Text Identity (Value -> TaggedValue)
-> ParsecT Void Text Identity Value -> Parsec Void Text TaggedValue
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
L.dropWS Parser ()
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Value
parseValue)

    withoutTag :: ParsecT Void Text Identity (Tagged tag Value)
withoutTag = Value -> Tagged tag Value
forall tag a. a -> Tagged tag a
NoTag
      (Value -> Tagged tag Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity (Tagged tag Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Value
parseValue

    parseIdent :: Parser Text
    parseIdent :: ParsecT Void Text Identity Text
parseIdent =
      Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"tag") (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
tagChars)

parseValue :: Parser Value
parseValue :: ParsecT Void Text Identity Value
parseValue = do
  Parser () -> Parser ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
P.skipMany Parser ()
parseDiscard
  [ParsecT Void Text Identity Value]
-> ParsecT Void Text Identity Value
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
    [ ParsecT Void Text Identity Value
parseNil
    , ParsecT Void Text Identity Value
parseBool
    , ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT Void Text Identity Value
parseNumber
    , ParsecT Void Text Identity Value
parseSymbol
    , ParsecT Void Text Identity Value
parseCharacter
    , ParsecT Void Text Identity Value
parseString
    , ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT Void Text Identity Value
parseKeyword
    , ParsecT Void Text Identity Value
parseCollections
    ]

parseDiscard :: Parser ()
parseDiscard :: Parser ()
parseDiscard = do
  Text
_ <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"#_"
  () () -> ParsecT Void Text Identity Value -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void Text Identity Value
parseValue

parseCollections :: Parser Value
parseCollections :: ParsecT Void Text Identity Value
parseCollections = ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a. Parser a -> Parser a
L.lexeme (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> (ParsecT Void Text Identity Value
    -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a b. (a -> b) -> a -> b
$ do
  Char
start <- [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
P.oneOf [Char
'#', Char
'{', Char
'[', Char
'(']
  case Char
start of
    Char
'#' -> do
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'{'
      [TaggedValue] -> Value
forall (f :: * -> *). Foldable f => f TaggedValue -> Value
EDN.mkSet ([TaggedValue] -> Value)
-> ParsecT Void Text Identity [TaggedValue]
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char
-> Parsec Void Text TaggedValue
-> ParsecT Void Text Identity [TaggedValue]
forall a.
Char
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
parseItemsTill Char
'}' Parsec Void Text TaggedValue
parseTagged
    Char
'{' -> do
      let pairs :: ParsecT Void Text Identity (TaggedValue, TaggedValue)
pairs = (,) (TaggedValue -> TaggedValue -> (TaggedValue, TaggedValue))
-> Parsec Void Text TaggedValue
-> ParsecT
     Void Text Identity (TaggedValue -> (TaggedValue, TaggedValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text TaggedValue
parseTagged ParsecT
  Void Text Identity (TaggedValue -> (TaggedValue, TaggedValue))
-> Parsec Void Text TaggedValue
-> ParsecT Void Text Identity (TaggedValue, TaggedValue)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Void Text TaggedValue
parseTagged
      [(TaggedValue, TaggedValue)] -> Value
forall (f :: * -> *).
Foldable f =>
f (TaggedValue, TaggedValue) -> Value
EDN.mkMap ([(TaggedValue, TaggedValue)] -> Value)
-> ParsecT Void Text Identity [(TaggedValue, TaggedValue)]
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char
-> ParsecT Void Text Identity (TaggedValue, TaggedValue)
-> ParsecT Void Text Identity [(TaggedValue, TaggedValue)]
forall a.
Char
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
parseItemsTill Char
'}' ParsecT Void Text Identity (TaggedValue, TaggedValue)
pairs
    Char
'[' ->
      [TaggedValue] -> Value
forall (f :: * -> *). Foldable f => f TaggedValue -> Value
EDN.mkVec ([TaggedValue] -> Value)
-> ParsecT Void Text Identity [TaggedValue]
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char
-> Parsec Void Text TaggedValue
-> ParsecT Void Text Identity [TaggedValue]
forall a.
Char
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
parseItemsTill Char
']' Parsec Void Text TaggedValue
parseTagged
    Char
'(' ->
      [TaggedValue] -> Value
forall (f :: * -> *). Foldable f => f TaggedValue -> Value
EDN.mkList ([TaggedValue] -> Value)
-> ParsecT Void Text Identity [TaggedValue]
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char
-> Parsec Void Text TaggedValue
-> ParsecT Void Text Identity [TaggedValue]
forall a.
Char
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
parseItemsTill Char
')' Parsec Void Text TaggedValue
parseTagged
    Char
_ ->
      String -> ParsecT Void Text Identity Value
forall a. HasCallStack => String -> a
error String
"assert: start is one of the collection openers"
  where
    parseItemsTill :: Char
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
parseItemsTill Char
end ParsecT Void Text Identity a
p = do
      Parser ()
L.dropWS
      ParsecT Void Text Identity a
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [a]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill (Parser ()
L.dropWS Parser ()
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity a
p) (Parser ()
L.dropWS Parser ()
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
end)

parseNil :: Parser Value
parseNil :: ParsecT Void Text Identity Value
parseNil = Value
Nil Value
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"nil"

parseBool :: Parser Value
parseBool :: ParsecT Void Text Identity Value
parseBool = [ParsecT Void Text Identity Value]
-> ParsecT Void Text Identity Value
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
  [ Bool -> Value
Boolean Bool
True  Value
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"true"
  , Bool -> Value
Boolean Bool
False Value
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"false"
  ]

parseSymbol :: Parser Value
parseSymbol :: ParsecT Void Text Identity Value
parseSymbol = String
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
P.label String
"symbol" (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> (ParsecT Void Text Identity Value
    -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a. Parser a -> Parser a
L.lexeme (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a b. (a -> b) -> a -> b
$ do
  Either Char Char
initial <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Either Char Char)
forall (m :: * -> *) a b.
Alternative m =>
m a -> m b -> m (Either a b)
P.eitherP (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'/') ([Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
P.oneOf String
[Token Text]
symbolInitialChars)
  (Text
ns, Text
name) <- case Either Char Char
initial of
    Left Char
_slash ->
      (Text, Text) -> ParsecT Void Text Identity (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"", Text
"/")
    Right Char
char ->
      ParsecT Void Text Identity (Text, Text)
-> ParsecT Void Text Identity (Text, Text)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (Char -> ParsecT Void Text Identity (Text, Text)
withNS Char
char) ParsecT Void Text Identity (Text, Text)
-> ParsecT Void Text Identity (Text, Text)
-> ParsecT Void Text Identity (Text, Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT Void Text Identity (Text, Text)
withoutNS Char
char
  Value -> ParsecT Void Text Identity Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ParsecT Void Text Identity Value)
-> Value -> ParsecT Void Text Identity Value
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Value
Symbol Text
ns Text
name
  where
    withNS :: Char -> Parser (Text, Text)
    withNS :: Char -> ParsecT Void Text Identity (Text, Text)
withNS Char
nsInitial = do
      Text
ns <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"symbol namespace") (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
symbolChars)
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'/'
      Char
nameInitial <- [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
P.oneOf String
[Token Text]
symbolInitialChars
      Text
name <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"symbol name") (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
symbolChars)
      (Text, Text) -> ParsecT Void Text Identity (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Text -> Text
Text.cons Char
nsInitial Text
ns, Char -> Text -> Text
Text.cons Char
nameInitial Text
name)

    withoutNS :: Char -> Parser (Text, Text)
    withoutNS :: Char -> ParsecT Void Text Identity (Text, Text)
withoutNS Char
nameInitial = do
      Text
name <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"symbol name") (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
symbolChars)
      (Text, Text) -> ParsecT Void Text Identity (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"", Char -> Text -> Text
Text.cons Char
nameInitial Text
name)

parseCharacter :: Parser Value
parseCharacter :: ParsecT Void Text Identity Value
parseCharacter = do
  Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'\\'
  (Char -> Value)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Value
Character (ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT Void Text Identity Char
unicode ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
named ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a. Parser a -> Parser a
L.lexeme ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.printChar)
  where
    unicode :: ParsecT Void Text Identity Char
unicode = String
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
P.label String
"hex-encoded unicode character" (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity Char)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b. (a -> b) -> a -> b
$ do
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'u'
      (Int -> Char)
-> ParsecT Void Text Identity Int
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
chr ParsecT Void Text Identity Int
L.hexadecimal

    named :: ParsecT Void Text Identity Char
named = String
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
P.label String
"whitespace character name" (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity Char)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
      [ Char
'\n' Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"newline"
      , Char
'\r' Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"return"
      , Char
' '  Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"space"
      , Char
'\t' Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT Void Text Identity Text
L.symbol Text
"tab"
      ]

parseString :: Parser Value
parseString :: ParsecT Void Text Identity Value
parseString = ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a. Parser a -> Parser a
L.lexeme (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a b. (a -> b) -> a -> b
$
  ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
P.between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'"') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'"') (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a b. (a -> b) -> a -> b
$
    Text -> Value
String (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Value)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (ParsecT Void Text Identity Char
escaped ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
plain)
  where
    escaped :: Parser Char
    escaped :: ParsecT Void Text Identity Char
escaped = do
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'\\'
      Char
c <- ParsecT Void Text Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
P.anySingle
      Char -> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ParsecT Void Text Identity Char)
-> Char -> ParsecT Void Text Identity Char
forall a b. (a -> b) -> a -> b
$ case Char
c of
        Char
'n' -> Char
'\n'
        Char
't' -> Char
'\t'
        Char
'r' -> Char
'\r'
        -- 'u' -> error "TODO: unicode escapes \u1234"
        Char
_   -> Char
c
    plain :: ParsecT Void Text Identity (Token Text)
plain = Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
P.anySingleBut Char
Token Text
'"'

parseNumber :: Parser Value
parseNumber :: ParsecT Void Text Identity Value
parseNumber = ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT Void Text Identity Value
parseFloating ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Value
parseInteger
  where
    parseFloating :: ParsecT Void Text Identity Value
parseFloating = Double -> Value
Floating (Double -> Value)
-> ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Double
L.floating
    parseInteger :: ParsecT Void Text Identity Value
parseInteger = Int -> Value
Integer (Int -> Value)
-> ParsecT Void Text Identity Int
-> ParsecT Void Text Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Int
L.integer

parseKeyword :: Parser Value
parseKeyword :: ParsecT Void Text Identity Value
parseKeyword = String
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
P.label String
"keyword" (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> (ParsecT Void Text Identity Value
    -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a. Parser a -> Parser a
L.lexeme (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity Value)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a b. (a -> b) -> a -> b
$ do
  Char
c <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
':' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
keywordInitialChars)
  Text
cs <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
keywordChars)
  Value -> ParsecT Void Text Identity Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ParsecT Void Text Identity Value)
-> Value -> ParsecT Void Text Identity Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
Keyword (Char -> Text -> Text
Text.cons Char
c Text
cs)

tagChars :: [Char]
tagChars :: String
tagChars = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
  [ String
lowerChars
  , String
upperChars
  , String
digitChars
  , String
"-"
  ]

keywordInitialChars :: [Char]
keywordInitialChars :: String
keywordInitialChars = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
  [ String
lowerChars
  , String
upperChars
  , String
miscChars
  ]

keywordChars :: [Char]
keywordChars :: String
keywordChars = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
  [ String
keywordInitialChars
  , String
digitChars
  , String
"/#:"
  ]

symbolInitialChars :: [Char]
symbolInitialChars :: String
symbolInitialChars = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
  [ String
lowerChars
  , String
upperChars
  , String
miscChars
  ]

symbolChars :: [Char]
symbolChars :: String
symbolChars = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
  [ String
symbolInitialChars
  , String
digitChars
  , String
"#:"
  ]

digitChars :: [Char]
digitChars :: String
digitChars = [Char
'0' .. Char
'9']

upperChars :: [Char]
upperChars :: String
upperChars = [Char
'A' .. Char
'Z']

lowerChars :: [Char]
lowerChars :: String
lowerChars = [Char
'a' .. Char
'z']

miscChars :: [Char]
miscChars :: String
miscChars = String
".*<>!?$%&=+_-"