{-# LANGUAGE ScopedTypeVariables #-}
-- | Utilities to parse 'Expr'.
--
-- /Note:/ we don't parse diffs.
module Data.TreeDiff.Parser (
    exprParser
    ) where

import Control.Applicative (many, optional, (<|>))
import Data.Char           (chr, isAlphaNum, isPunctuation, isSymbol)

import Text.Parser.Char            (CharParsing (anyChar, char, satisfy))
import Text.Parser.Combinators     (between, (<?>))
import Text.Parser.Token
       (TokenParsing (highlight, token), braces, brackets, commaSep,
       hexadecimal, parens, symbolic)
import Text.Parser.Token.Highlight
       (Highlight (Identifier, StringLiteral, Symbol))

import Data.TreeDiff.Expr

import qualified Data.TreeDiff.OMap as OMap

-- | Parsers for 'Expr' using @parsers@ type-classes.
--
-- You can use this with your parser-combinator library of choice:
-- @parsec@, @attoparsec@, @trifecta@...
exprParser :: (Monad m, TokenParsing m) => m Expr
exprParser :: forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
exprParser = m Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
apprecP m Expr -> m Expr -> m Expr
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
lstP

lstP :: forall m. (Monad m, TokenParsing m) => m Expr
lstP :: forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
lstP = [Expr] -> Expr
Lst ([Expr] -> Expr) -> m [Expr] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Expr] -> m [Expr]
forall (m :: * -> *) a. TokenParsing m => m a -> m a
brackets (m Expr -> m [Expr]
forall (m :: * -> *) a. TokenParsing m => m a -> m [a]
commaSep m Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
exprParser)
    m Expr -> String -> m Expr
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"list"

apprecP :: forall m. (Monad m, TokenParsing m) => m Expr
apprecP :: forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
apprecP = do
    Either String Expr
r <- m (Either String Expr)
forall (m :: * -> *).
(Monad m, TokenParsing m) =>
m (Either String Expr)
recP
    case Either String Expr
r of
        Right Expr
e -> Expr -> m Expr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
        Left String
n  -> String -> [Expr] -> Expr
App String
n ([Expr] -> Expr) -> m [Expr] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Expr -> m [Expr]
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
litP'

fieldP :: forall m. (Monad m, TokenParsing m) => m (FieldName, Expr)
fieldP :: forall (m :: * -> *). (Monad m, TokenParsing m) => m (String, Expr)
fieldP = (,) (String -> Expr -> (String, Expr))
-> m String -> m (Expr -> (String, Expr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). (Monad m, TokenParsing m) => m String
litP m (Expr -> (String, Expr)) -> m Char -> m (Expr -> (String, Expr))
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> m Char
forall (m :: * -> *). TokenParsing m => Char -> m Char
symbolic Char
'=' m (Expr -> (String, Expr)) -> m Expr -> m (String, Expr)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
exprParser

litP :: forall m. (Monad m, TokenParsing m) => m String
litP :: forall (m :: * -> *). (Monad m, TokenParsing m) => m String
litP = m String
forall (m :: * -> *). (Monad m, TokenParsing m) => m String
atomP m String -> m String -> m String
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
forall (m :: * -> *). (Monad m, TokenParsing m) => m String
identP m String -> m String -> m String
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
forall (m :: * -> *). (Monad m, TokenParsing m) => m String
stringP

recP :: forall m. (Monad m, TokenParsing m) => m (Either String Expr)
recP :: forall (m :: * -> *).
(Monad m, TokenParsing m) =>
m (Either String Expr)
recP = String -> Maybe [(String, Expr)] -> Either String Expr
mk (String -> Maybe [(String, Expr)] -> Either String Expr)
-> m String -> m (Maybe [(String, Expr)] -> Either String Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). (Monad m, TokenParsing m) => m String
litP m (Maybe [(String, Expr)] -> Either String Expr)
-> m (Maybe [(String, Expr)]) -> m (Either String Expr)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [(String, Expr)] -> m (Maybe [(String, Expr)])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m [(String, Expr)] -> m [(String, Expr)]
forall (m :: * -> *) a. TokenParsing m => m a -> m a
braces (m (String, Expr) -> m [(String, Expr)]
forall (m :: * -> *) a. TokenParsing m => m a -> m [a]
commaSep m (String, Expr)
forall (m :: * -> *). (Monad m, TokenParsing m) => m (String, Expr)
fieldP)) where
    mk :: String -> Maybe [(String, Expr)] -> Either String Expr
mk String
n Maybe [(String, Expr)]
Nothing   = String -> Either String Expr
forall a b. a -> Either a b
Left String
n
    mk String
n (Just [(String, Expr)]
fs) = Expr -> Either String Expr
forall a b. b -> Either a b
Right (String -> OMap String Expr -> Expr
Rec String
n ([(String, Expr)] -> OMap String Expr
forall k v. Ord k => [(k, v)] -> OMap k v
OMap.fromList [(String, Expr)]
fs))

litP' :: forall m. (Monad m, TokenParsing m) => m Expr
litP' :: forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
litP' = Either String Expr -> Expr
mk (Either String Expr -> Expr) -> m (Either String Expr) -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either String Expr)
forall (m :: * -> *).
(Monad m, TokenParsing m) =>
m (Either String Expr)
recP m Expr -> m Expr -> m Expr
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Expr -> m Expr
forall (m :: * -> *) a. TokenParsing m => m a -> m a
parens m Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
exprParser m Expr -> m Expr -> m Expr
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
lstP
  where
    mk :: Either String Expr -> Expr
mk (Left String
n)  = String -> [Expr] -> Expr
App String
n []
    mk (Right Expr
e) = Expr
e

identP :: forall m. (Monad m, TokenParsing m) => m String
identP :: forall (m :: * -> *). (Monad m, TokenParsing m) => m String
identP = m String -> m String
forall a. m a -> m a
forall (m :: * -> *) a. TokenParsing m => m a -> m a
token (Highlight -> m String -> m String
forall a. Highlight -> m a -> m a
forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
highlight Highlight
Identifier m String
lit) where
    lit :: m [Char]
    lit :: m String
lit = (:) (Char -> String -> String) -> m Char -> m (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
firstLetter m (String -> String) -> m String -> m String
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Char -> m String
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m Char
restLetter
        m String -> String -> m String
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"identifier"

    firstLetter :: m Char
    firstLetter :: m Char
firstLetter = (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\Char
c -> Char -> Bool
valid' Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'+')

    restLetter :: m Char
    restLetter :: m Char
restLetter = (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy Char -> Bool
valid'

stringP :: forall m. (Monad m, TokenParsing m) => m String
stringP :: forall (m :: * -> *). (Monad m, TokenParsing m) => m String
stringP = m String -> m String
forall a. m a -> m a
forall (m :: * -> *) a. TokenParsing m => m a -> m a
token (Highlight -> m String -> m String
forall a. Highlight -> m a -> m a
forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
highlight Highlight
StringLiteral m String
lit) where
    lit :: m [Char]
    lit :: m String
lit = [String] -> String
mk ([String] -> String) -> m [String] -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m Char -> m [String] -> m [String]
forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
between (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'"') (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'"' m Char -> String -> m Char
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"end of string") (m String -> m [String]
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m String
stringChar)
        m String -> String -> m String
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"atom"

    mk :: [[Char]] -> String
    mk :: [String] -> String
mk [String]
ss = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
ss String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

    stringChar :: m [Char]
    stringChar :: m String
stringChar = m String
stringLetter m String -> m String -> m String
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
stringEscape
        m String -> String -> m String
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"string character"

    stringEscape :: m [Char]
    stringEscape :: m String
stringEscape = (\Char
x Char
y -> [Char
x,Char
y]) (Char -> Char -> String) -> m Char -> m (Char -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'\\' m (Char -> String) -> m Char -> m String
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar

    stringLetter :: m [Char]
    stringLetter :: m String
stringLetter = Char -> String
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String) -> m Char -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"')

atomP :: forall m. (Monad m, TokenParsing m) => m String
atomP :: forall (m :: * -> *). (Monad m, TokenParsing m) => m String
atomP = m String -> m String
forall a. m a -> m a
forall (m :: * -> *) a. TokenParsing m => m a -> m a
token (Highlight -> m String -> m String
forall a. Highlight -> m a -> m a
forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
highlight Highlight
Symbol m String
lit) where
    lit :: m [Char]
    lit :: m String
lit = m Char -> m Char -> m String -> m String
forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
between (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'`') (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'`' m Char -> String -> m Char
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"end of atom") (m Char -> m String
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m Char
atomChar)
        m String -> String -> m String
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"atom"

    atomChar :: m Char
    atomChar :: m Char
atomChar = m Char
atomLetter m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
atomEscape m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
' '
        m Char -> String -> m Char
forall a. m a -> String -> m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"atom character"

    atomEscape :: m Char
    atomEscape :: m Char
atomEscape = Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'\\' m Char -> m Char -> m Char
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'\\' m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'`' m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
escapedHex)

    escapedHex :: m Char
    escapedHex :: m Char
escapedHex = Int -> Char
chr (Int -> Char) -> (Integer -> Int) -> Integer -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Char) -> m Integer -> m Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Integer
forall (m :: * -> *). TokenParsing m => m Integer
hexadecimal m Char -> m Char -> m Char
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
';'

    atomLetter :: m Char
    atomLetter :: m Char
atomLetter = (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=  Char
'`' Bool -> Bool -> Bool
&& Char -> Bool
valid Char
c)

valid :: Char -> Bool
valid :: Char -> Bool
valid Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSymbol Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c

valid' :: Char -> Bool
valid' :: Char -> Bool
valid' Char
c = Char -> Bool
valid Char
c Bool -> Bool -> Bool
&& Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"[](){}`\","