{-# 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 Prelude ()
import Prelude.Compat

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 = forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
apprecP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. TokenParsing m => m a -> m a
brackets (forall (m :: * -> *) a. TokenParsing m => m a -> m [a]
commaSep forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
exprParser)
    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 <- forall (m :: * -> *).
(Monad m, TokenParsing m) =>
m (Either String Expr)
recP
    case Either String Expr
r of
        Right Expr
e -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
        Left String
n  -> String -> [Expr] -> Expr
App String
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many 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 = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). (Monad m, TokenParsing m) => m String
litP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). TokenParsing m => Char -> m Char
symbolic Char
'=' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall (m :: * -> *). (Monad m, TokenParsing m) => m String
atomP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). (Monad m, TokenParsing m) => m String
identP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). (Monad m, TokenParsing m) => m String
litP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall (m :: * -> *) a. TokenParsing m => m a -> m a
braces (forall (m :: * -> *) a. TokenParsing m => m a -> m [a]
commaSep 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   = forall a b. a -> Either a b
Left String
n
    mk String
n (Just [(String, Expr)]
fs) = forall a b. b -> Either a b
Right (String -> OMap String Expr -> Expr
Rec String
n (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Monad m, TokenParsing m) =>
m (Either String Expr)
recP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. TokenParsing m => m a -> m a
parens forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
exprParser forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 = forall (m :: * -> *) a. TokenParsing m => m a -> m a
token (forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
highlight Highlight
Identifier m String
lit) where
    lit :: m [Char]
    lit :: m String
lit = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
firstLetter forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m Char
restLetter
        forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"identifier"

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

    restLetter :: m Char
    restLetter :: m Char
restLetter = 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 = forall (m :: * -> *) a. TokenParsing m => m a -> m a
token (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
between (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'"') (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'"' forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"end of string") (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m String
stringChar)
        forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"atom"

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

    stringChar :: m [Char]
    stringChar :: m String
stringChar = m String
stringLetter forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
stringEscape
        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]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). CharParsing m => m Char
anyChar

    stringLetter :: m [Char]
    stringLetter :: m String
stringLetter = forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
c 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 = forall (m :: * -> *) a. TokenParsing m => m a -> m a
token (forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
highlight Highlight
Symbol m String
lit) where
    lit :: m [Char]
    lit :: m String
lit = forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
between (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'`') (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'`' forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"end of atom") (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m Char
atomChar)
        forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"atom"

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

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

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

    atomLetter :: m Char
    atomLetter :: m Char
atomLetter = forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
c 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"[](){}`\","