{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeOperators, TypeFamilies #-}
module Text.Boomerang.Prim
    ( -- * Types
    Parser(..), Boomerang(..), PrinterParser, (.~)
    -- * Running routers
    , parse, parse1, unparse, unparse1, bestErrors
    -- * Constructing / Manipulating Boomerangs
    , xpure, val, xmap
    -- heterogeneous list functions
    , 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'')

-- | The 'maximumsBy' function takes a comparison function and a list
-- and returns the greatest elements of the list by the comparison function.
-- The list must be finite and non-empty.
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]

-- |Yet another parser.
--
-- Returns all possible parses and parse errors
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)

-- | Attempt to extract the most relevant errors from a list of parse errors.
--
-- The current heuristic is to find error (or errors) where the error position is highest.
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

-- | A @Boomerang a b@ takes an @a@ to parse a URL and results in @b@ if parsing succeeds.
--   And it takes a @b@ to serialize to a URL and results in @a@ if serializing succeeds.
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 .~
-- | Reverse composition, but with the side effects still in left-to-right order.
(.~) :: 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)

-- | Map over routers.
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)

-- | Lift a constructor-destructor pair to a pure router.
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

-- | Like "xmap", but only maps over the top of the stack.
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)

-- | lift a 'Parser' and a printer into a 'Boomerang'
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))

-- | Give all possible parses or errors.
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))

-- | Give the first parse, for Boomerangs with a parser that yields just one value.
-- Otherwise return the error (or errors) with the highest error position.
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 ]

-- | Give all possible serializations.
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

-- | Give the first serialization, for Boomerangs with a serializer that needs just one value.
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