{-# LANGUAGE ScopedTypeVariables #-}
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
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
"[](){}`\","