{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeOperators, TypeFamilies #-}
module Text.Boomerang.Prim
(
Parser(..), Boomerang(..), PrinterParser, (.~)
, parse, parse1, unparse, unparse1, bestErrors
, xpure, val, xmap
, xmaph
) where
import Prelude hiding ((.), id)
import Control.Arrow (first)
import Control.Applicative (Applicative(..), Alternative(..))
import Control.Category (Category((.), id))
import Control.Monad (MonadPlus(mzero, mplus), ap)
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.Monoid (Monoid(mappend, mempty))
import qualified Data.Semigroup as SG
import Text.Boomerang.HStack ((:-)(..), hdMap, hdTraverse)
import Text.Boomerang.Pos (ErrorPosition(..), InitialPosition(..), Pos)
compose
:: (a -> b -> c)
-> (i -> [(a, j)])
-> (j -> [(b, k)])
-> (i -> [(c, k)])
compose :: forall a b c i j k.
(a -> b -> c)
-> (i -> [(a, j)]) -> (j -> [(b, k)]) -> i -> [(c, k)]
compose a -> b -> c
op i -> [(a, j)]
mf j -> [(b, k)]
mg i
s = do
(a
f, j
s') <- i -> [(a, j)]
mf i
s
(b
g, k
s'') <- j -> [(b, k)]
mg j
s'
forall (m :: * -> *) a. Monad m => a -> m a
return (a
f a -> b -> c
`op` b
g, k
s'')
maximumsBy :: (a -> a -> Ordering) -> [a] -> [a]
maximumsBy :: forall a. (a -> a -> Ordering) -> [a] -> [a]
maximumsBy a -> a -> Ordering
_ [] = forall a. HasCallStack => [Char] -> a
error [Char]
"Text.Boomerang.Core.maximumsBy: empty list"
maximumsBy a -> a -> Ordering
cmp (a
x:[a]
xs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [a] -> a -> [a]
maxBy [a
x] [a]
xs
where
maxBy :: [a] -> a -> [a]
maxBy xs :: [a]
xs@(a
x:[a]
_) a
y =
case a -> a -> Ordering
cmp a
x a
y of
Ordering
GT -> [a]
xs
Ordering
EQ -> (a
yforall a. a -> [a] -> [a]
:[a]
xs)
Ordering
LT -> [a
y]
newtype Parser e tok a = Parser { forall e tok a.
Parser e tok a -> tok -> Pos e -> [Either e ((a, tok), Pos e)]
runParser :: tok -> Pos e -> [Either e ((a, tok), Pos e)] }
instance Functor (Parser e tok) where
fmap :: forall a b. (a -> b) -> Parser e tok a -> Parser e tok b
fmap a -> b
f (Parser tok -> Pos e -> [Either e ((a, tok), Pos e)]
p) =
forall e tok a.
(tok -> Pos e -> [Either e ((a, tok), Pos e)]) -> Parser e tok a
Parser forall a b. (a -> b) -> a -> b
$ \tok
tok Pos e
pos ->
forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> b
f))) (tok -> Pos e -> [Either e ((a, tok), Pos e)]
p tok
tok Pos e
pos)
instance Applicative (Parser e tok) where
pure :: forall a. a -> Parser e tok a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b.
Parser e tok (a -> b) -> Parser e tok a -> Parser e tok b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (Parser e tok) where
return :: forall a. a -> Parser e tok a
return a
a =
forall e tok a.
(tok -> Pos e -> [Either e ((a, tok), Pos e)]) -> Parser e tok a
Parser forall a b. (a -> b) -> a -> b
$ \tok
tok Pos e
pos ->
[forall a b. b -> Either a b
Right ((a
a, tok
tok), Pos e
pos)]
(Parser tok -> Pos e -> [Either e ((a, tok), Pos e)]
p) >>= :: forall a b.
Parser e tok a -> (a -> Parser e tok b) -> Parser e tok b
>>= a -> Parser e tok b
f =
forall e tok a.
(tok -> Pos e -> [Either e ((a, tok), Pos e)]) -> Parser e tok a
Parser forall a b. (a -> b) -> a -> b
$ \tok
tok Pos e
pos ->
case forall a b. [Either a b] -> ([a], [b])
partitionEithers (tok -> Pos e -> [Either e ((a, tok), Pos e)]
p tok
tok Pos e
pos) of
([], []) -> []
([e]
errs,[]) -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [e]
errs
([e]
_,[((a, tok), Pos e)]
as) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ forall e tok a.
Parser e tok a -> tok -> Pos e -> [Either e ((a, tok), Pos e)]
runParser (a -> Parser e tok b
f a
a) tok
tok' Pos e
pos' | ((a
a, tok
tok'), Pos e
pos') <- [((a, tok), Pos e)]
as ]
instance Alternative (Parser e tok) where
empty :: forall a. Parser e tok a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
<|> :: forall a. Parser e tok a -> Parser e tok a -> Parser e tok a
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance MonadPlus (Parser e tok) where
mzero :: forall a. Parser e tok a
mzero = forall e tok a.
(tok -> Pos e -> [Either e ((a, tok), Pos e)]) -> Parser e tok a
Parser forall a b. (a -> b) -> a -> b
$ \tok
tok Pos e
pos -> []
(Parser tok -> Pos e -> [Either e ((a, tok), Pos e)]
x) mplus :: forall a. Parser e tok a -> Parser e tok a -> Parser e tok a
`mplus` (Parser tok -> Pos e -> [Either e ((a, tok), Pos e)]
y) =
forall e tok a.
(tok -> Pos e -> [Either e ((a, tok), Pos e)]) -> Parser e tok a
Parser forall a b. (a -> b) -> a -> b
$ \tok
tok Pos e
pos ->
(tok -> Pos e -> [Either e ((a, tok), Pos e)]
x tok
tok Pos e
pos) forall a. [a] -> [a] -> [a]
++ (tok -> Pos e -> [Either e ((a, tok), Pos e)]
y tok
tok Pos e
pos)
composeP
:: (a -> b -> c)
-> Parser e tok a
-> Parser e tok b
-> Parser e tok c
composeP :: forall a b c e tok.
(a -> b -> c) -> Parser e tok a -> Parser e tok b -> Parser e tok c
composeP a -> b -> c
op Parser e tok a
mf Parser e tok b
mg =
do a
f <- Parser e tok a
mf
b
g <- Parser e tok b
mg
forall (m :: * -> *) a. Monad m => a -> m a
return (a
f a -> b -> c
`op` b
g)
bestErrors :: (ErrorPosition e, Ord (Pos e)) => [e] -> [e]
bestErrors :: forall e. (ErrorPosition e, Ord (Pos e)) => [e] -> [e]
bestErrors [] = []
bestErrors [e]
errs = forall a. (a -> a -> Ordering) -> [a] -> [a]
maximumsBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall err. ErrorPosition err => err -> Maybe (Pos err)
getPosition) [e]
errs
data Boomerang e tok a b = Boomerang
{ forall e tok a b. Boomerang e tok a b -> Parser e tok (a -> b)
prs :: Parser e tok (a -> b)
, forall e tok a b. Boomerang e tok a b -> b -> [(tok -> tok, a)]
ser :: b -> [(tok -> tok, a)]
}
type PrinterParser = Boomerang
{-# DEPRECATED PrinterParser "Use Boomerang instead" #-}
instance Category (Boomerang e tok) where
id :: forall a. Boomerang e tok a a
id = forall e tok a b.
Parser e tok (a -> b)
-> (b -> [(tok -> tok, a)]) -> Boomerang e tok a b
Boomerang
(forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
(\a
x -> [(forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id, a
x)])
~(Boomerang Parser e tok (b -> c)
pf c -> [(tok -> tok, b)]
sf) . :: forall b c a.
Boomerang e tok b c -> Boomerang e tok a b -> Boomerang e tok a c
. ~(Boomerang Parser e tok (a -> b)
pg b -> [(tok -> tok, a)]
sg) = forall e tok a b.
Parser e tok (a -> b)
-> (b -> [(tok -> tok, a)]) -> Boomerang e tok a b
Boomerang
(forall a b c e tok.
(a -> b -> c) -> Parser e tok a -> Parser e tok b -> Parser e tok c
composeP forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.) Parser e tok (b -> c)
pf Parser e tok (a -> b)
pg)
(forall a b c i j k.
(a -> b -> c)
-> (i -> [(a, j)]) -> (j -> [(b, k)]) -> i -> [(c, k)]
compose forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.) c -> [(tok -> tok, b)]
sf b -> [(tok -> tok, a)]
sg)
instance SG.Semigroup (Boomerang e tok a b) where
~(Boomerang Parser e tok (a -> b)
pf b -> [(tok -> tok, a)]
sf) <> :: Boomerang e tok a b -> Boomerang e tok a b -> Boomerang e tok a b
<> ~(Boomerang Parser e tok (a -> b)
pg b -> [(tok -> tok, a)]
sg) = forall e tok a b.
Parser e tok (a -> b)
-> (b -> [(tok -> tok, a)]) -> Boomerang e tok a b
Boomerang
(Parser e tok (a -> b)
pf forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Parser e tok (a -> b)
pg)
(\b
s -> b -> [(tok -> tok, a)]
sf b
s forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` b -> [(tok -> tok, a)]
sg b
s)
instance Monoid (Boomerang e tok a b) where
mempty :: Boomerang e tok a b
mempty = forall e tok a b.
Parser e tok (a -> b)
-> (b -> [(tok -> tok, a)]) -> Boomerang e tok a b
Boomerang
forall (m :: * -> *) a. MonadPlus m => m a
mzero
(forall a b. a -> b -> a
const forall (m :: * -> *) a. MonadPlus m => m a
mzero)
mappend :: Boomerang e tok a b -> Boomerang e tok a b -> Boomerang e tok a b
mappend = forall a. Semigroup a => a -> a -> a
(SG.<>)
infixr 9 .~
(.~) :: Boomerang e tok a b -> Boomerang e tok b c -> Boomerang e tok a c
~(Boomerang Parser e tok (a -> b)
pf b -> [(tok -> tok, a)]
sf) .~ :: forall e tok a b c.
Boomerang e tok a b -> Boomerang e tok b c -> Boomerang e tok a c
.~ ~(Boomerang Parser e tok (b -> c)
pg c -> [(tok -> tok, b)]
sg) = forall e tok a b.
Parser e tok (a -> b)
-> (b -> [(tok -> tok, a)]) -> Boomerang e tok a b
Boomerang
(forall a b c e tok.
(a -> b -> c) -> Parser e tok a -> Parser e tok b -> Parser e tok c
composeP (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)) Parser e tok (a -> b)
pf Parser e tok (b -> c)
pg)
(forall a b c i j k.
(a -> b -> c)
-> (i -> [(a, j)]) -> (j -> [(b, k)]) -> i -> [(c, k)]
compose (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)) c -> [(tok -> tok, b)]
sg b -> [(tok -> tok, a)]
sf)
xmap :: (a -> b) -> (b -> Maybe a) -> Boomerang e tok r a -> Boomerang e tok r b
xmap :: forall a b e tok r.
(a -> b)
-> (b -> Maybe a) -> Boomerang e tok r a -> Boomerang e tok r b
xmap a -> b
f b -> Maybe a
g (Boomerang Parser e tok (r -> a)
p a -> [(tok -> tok, r)]
s) = forall e tok a b.
Parser e tok (a -> b)
-> (b -> [(tok -> tok, a)]) -> Boomerang e tok a b
Boomerang Parser e tok (r -> b)
p' b -> [(tok -> tok, r)]
s'
where
p' :: Parser e tok (r -> b)
p' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Parser e tok (r -> a)
p
s' :: b -> [(tok -> tok, r)]
s' b
url = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero a -> [(tok -> tok, r)]
s (b -> Maybe a
g b
url)
xpure :: (a -> b) -> (b -> Maybe a) -> Boomerang e tok a b
xpure :: forall a b e tok. (a -> b) -> (b -> Maybe a) -> Boomerang e tok a b
xpure a -> b
f b -> Maybe a
g = forall a b e tok r.
(a -> b)
-> (b -> Maybe a) -> Boomerang e tok r a -> Boomerang e tok r b
xmap a -> b
f b -> Maybe a
g forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
xmaph :: (a -> b) -> (b -> Maybe a) -> Boomerang e tok i (a :- o) -> Boomerang e tok i (b :- o)
xmaph :: forall a b e tok i o.
(a -> b)
-> (b -> Maybe a)
-> Boomerang e tok i (a :- o)
-> Boomerang e tok i (b :- o)
xmaph a -> b
f b -> Maybe a
g = forall a b e tok r.
(a -> b)
-> (b -> Maybe a) -> Boomerang e tok r a -> Boomerang e tok r b
xmap (forall a1 a2 b. (a1 -> a2) -> (a1 :- b) -> a2 :- b
hdMap a -> b
f) (forall (f :: * -> *) a b t.
Functor f =>
(a -> f b) -> (a :- t) -> f (b :- t)
hdTraverse b -> Maybe a
g)
val :: forall e tok a r. Parser e tok a -> (a -> [tok -> tok]) -> Boomerang e tok r (a :- r)
val :: forall e tok a r.
Parser e tok a -> (a -> [tok -> tok]) -> Boomerang e tok r (a :- r)
val Parser e tok a
rs a -> [tok -> tok]
ss = forall e tok a b.
Parser e tok (a -> b)
-> (b -> [(tok -> tok, a)]) -> Boomerang e tok a b
Boomerang Parser e tok (r -> a :- r)
rs' (a :- r) -> [(tok -> tok, r)]
ss'
where
rs' :: Parser e tok (r -> (a :- r))
rs' :: Parser e tok (r -> a :- r)
rs' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> b -> a :- b
(:-) Parser e tok a
rs
ss' :: (a :- r) -> [(tok -> tok, r)]
ss' = (\(a
a :- r
r) -> forall a b. (a -> b) -> [a] -> [b]
map (\tok -> tok
f -> (tok -> tok
f, r
r)) (a -> [tok -> tok]
ss a
a))
parse :: forall e a p tok. (InitialPosition e) => Boomerang e tok () a -> tok -> [Either e (a, tok)]
parse :: forall e a p tok.
InitialPosition e =>
Boomerang e tok () a -> tok -> [Either e (a, tok)]
parse Boomerang e tok () a
p tok
s =
forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (\((() -> a
f, tok
tok), Pos e
_) -> forall a b. b -> Either a b
Right (() -> a
f (), tok
tok))) forall a b. (a -> b) -> a -> b
$ forall e tok a.
Parser e tok a -> tok -> Pos e -> [Either e ((a, tok), Pos e)]
runParser (forall e tok a b. Boomerang e tok a b -> Parser e tok (a -> b)
prs Boomerang e tok () a
p) tok
s (forall e. InitialPosition e => Maybe e -> Pos e
initialPos (forall a. Maybe a
Nothing :: Maybe e))
parse1 :: (ErrorPosition e, InitialPosition e, Show e, Ord (Pos e)) =>
(tok -> Bool) -> Boomerang e tok () (a :- ()) -> tok -> Either [e] a
parse1 :: forall e tok a.
(ErrorPosition e, InitialPosition e, Show e, Ord (Pos e)) =>
(tok -> Bool)
-> Boomerang e tok () (a :- ()) -> tok -> Either [e] a
parse1 tok -> Bool
isComplete Boomerang e tok () (a :- ())
r tok
paths =
let results :: [Either e (a :- (), tok)]
results = forall e a p tok.
InitialPosition e =>
Boomerang e tok () a -> tok -> [Either e (a, tok)]
parse Boomerang e tok () (a :- ())
r tok
paths
in case [ a :- ()
a | (Right (a :- ()
a,tok
tok)) <- [Either e (a :- (), tok)]
results, tok -> Bool
isComplete tok
tok ] of
((a
u :- ()):[a :- ()]
_) -> forall a b. b -> Either a b
Right a
u
[a :- ()]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. (ErrorPosition e, Ord (Pos e)) => [e] -> [e]
bestErrors [ e
e | Left e
e <- [Either e (a :- (), tok)]
results ]
unparse :: tok -> Boomerang e tok () url -> url -> [tok]
unparse :: forall tok e url. tok -> Boomerang e tok () url -> url -> [tok]
unparse tok
tok Boomerang e tok () url
p = (forall a b. (a -> b) -> [a] -> [b]
map ((forall a b. (a -> b) -> a -> b
$ tok
tok) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> a
fst)) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e tok a b. Boomerang e tok a b -> b -> [(tok -> tok, a)]
ser Boomerang e tok () url
p
unparse1 :: tok -> Boomerang e tok () (a :- ()) -> a -> Maybe tok
unparse1 :: forall tok e a.
tok -> Boomerang e tok () (a :- ()) -> a -> Maybe tok
unparse1 tok
tok Boomerang e tok () (a :- ())
p a
a =
case forall tok e url. tok -> Boomerang e tok () url -> url -> [tok]
unparse tok
tok Boomerang e tok () (a :- ())
p (a
a forall a b. a -> b -> a :- b
:- ()) of
[] -> forall a. Maybe a
Nothing
(tok
s:[tok]
_) -> forall a. a -> Maybe a
Just tok
s