{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Module containing internal helpers for our parsers.
module Jordan.FromJSON.ParseInternal
    where

import Control.Applicative (Alternative(..))
import Data.Foldable (asum)

-- | A parser for permutations.
--
-- Based on the paper Parsing Permutation Phrases by
-- Arthur Baars, Andres Loh, and S. Doaitse Swierstra.
--
-- The source code for 'Control.Applicative.Permutations' really helped
-- in writing this, although this type is structured differently (and closer to the actual paper).
-- Thank you very much to Alex Washburn!
data Permutation parser a
  = Choice [Branch parser a]
  -- ^ We have multiple options for how to parse further.
  | Empty a
  -- ^ We have reached the end and only have a single value.

-- | A branch of a permutation.
-- Permutation parsers work by building up the entire tree of
-- possible parsers, which is efficient in Haskell due to laziness.
data Branch parser a
  = forall arg. Branch (Permutation parser (arg -> a)) (parser arg)

instance (Functor m) => Functor (Branch m) where
  fmap :: (a -> b) -> Branch m a -> Branch m b
fmap a -> b
f (Branch Permutation m (arg -> a)
perm m arg
p) = Permutation m (arg -> b) -> m arg -> Branch m b
forall (parser :: * -> *) a arg.
Permutation parser (arg -> a) -> parser arg -> Branch parser a
Branch (((arg -> a) -> arg -> b)
-> Permutation m (arg -> a) -> Permutation m (arg -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f (a -> b) -> (arg -> a) -> arg -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) Permutation m (arg -> a)
perm) m arg
p

instance (Functor m) => Functor (Permutation m) where
  fmap :: (a -> b) -> Permutation m a -> Permutation m b
fmap a -> b
f = \case
    Choice [Branch m a]
c -> [Branch m b] -> Permutation m b
forall (parser :: * -> *) a.
[Branch parser a] -> Permutation parser a
Choice ([Branch m b] -> Permutation m b)
-> [Branch m b] -> Permutation m b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Branch m a -> Branch m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Branch m a -> Branch m b) -> [Branch m a] -> [Branch m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
c
    Empty a
a -> b -> Permutation m b
forall (parser :: * -> *) a. a -> Permutation parser a
Empty (a -> b
f a
a)

instance (Alternative m) => Applicative (Branch m) where
  pure :: a -> Branch m a
pure a
a = Permutation m (() -> a) -> m () -> Branch m a
forall (parser :: * -> *) a arg.
Permutation parser (arg -> a) -> parser arg -> Branch parser a
Branch ((() -> a) -> Permutation m (() -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((() -> a) -> Permutation m (() -> a))
-> (() -> a) -> Permutation m (() -> a)
forall a b. (a -> b) -> a -> b
$ a -> () -> a
forall a b. a -> b -> a
const a
a) (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  (Branch Permutation m (arg -> a -> b)
permuteF m arg
argF) <*> :: Branch m (a -> b) -> Branch m a -> Branch m b
<*> (Branch Permutation m (arg -> a)
permuteA m arg
argA) =
    Permutation m ((arg, arg) -> b) -> m (arg, arg) -> Branch m b
forall (parser :: * -> *) a arg.
Permutation parser (arg -> a) -> parser arg -> Branch parser a
Branch ((arg -> a -> b) -> (arg -> a) -> (arg, arg) -> b
forall arg1 a b arg2.
(arg1 -> a -> b) -> (arg2 -> a) -> (arg2, arg1) -> b
args ((arg -> a -> b) -> (arg -> a) -> (arg, arg) -> b)
-> Permutation m (arg -> a -> b)
-> Permutation m ((arg -> a) -> (arg, arg) -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Permutation m (arg -> a -> b)
permuteF Permutation m ((arg -> a) -> (arg, arg) -> b)
-> Permutation m (arg -> a) -> Permutation m ((arg, arg) -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m (arg -> a)
permuteA) m (arg, arg)
arguments
      where
        arguments :: m (arg, arg)
arguments = ((,) (arg -> arg -> (arg, arg)) -> m arg -> m (arg -> (arg, arg))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m arg
argA m (arg -> (arg, arg)) -> m arg -> m (arg, arg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m arg
argF) m (arg, arg) -> m (arg, arg) -> m (arg, arg)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((arg -> arg -> (arg, arg)) -> arg -> arg -> (arg, arg)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (arg -> arg -> (arg, arg)) -> m arg -> m (arg -> (arg, arg))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m arg
argF m (arg -> (arg, arg)) -> m arg -> m (arg, arg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m arg
argA)
        args :: (arg1 -> a -> b) -> (arg2 -> a) -> (arg2, arg1) -> b
        args :: (arg1 -> a -> b) -> (arg2 -> a) -> (arg2, arg1) -> b
args arg1 -> a -> b
f arg2 -> a
a (arg2
aa, arg1
fa) = arg1 -> a -> b
f arg1
fa (arg2 -> a
a arg2
aa)

instance (Alternative m) => Applicative (Permutation m) where
  pure :: a -> Permutation m a
pure = a -> Permutation m a
forall (parser :: * -> *) a. a -> Permutation parser a
Empty
  (Empty a -> b
f) <*> :: Permutation m (a -> b) -> Permutation m a -> Permutation m b
<*> (Empty a
a) = b -> Permutation m b
forall (parser :: * -> *) a. a -> Permutation parser a
Empty (b -> Permutation m b) -> b -> Permutation m b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  (Empty a -> b
f) <*> (Choice [Branch m a]
choices) = [Branch m b] -> Permutation m b
forall (parser :: * -> *) a.
[Branch parser a] -> Permutation parser a
Choice ([Branch m b] -> Permutation m b)
-> [Branch m b] -> Permutation m b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Branch m a -> Branch m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Branch m a -> Branch m b) -> [Branch m a] -> [Branch m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
choices
  (Choice [Branch m (a -> b)]
f) <*> (Empty a
a) = [Branch m b] -> Permutation m b
forall (parser :: * -> *) a.
[Branch parser a] -> Permutation parser a
Choice ([Branch m b] -> Permutation m b)
-> [Branch m b] -> Permutation m b
forall a b. (a -> b) -> a -> b
$ ((a -> b) -> b) -> Branch m (a -> b) -> Branch m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) (Branch m (a -> b) -> Branch m b)
-> [Branch m (a -> b)] -> [Branch m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m (a -> b)]
f
  t1 :: Permutation m (a -> b)
t1@(Choice [Branch m (a -> b)]
bs1) <*> t2 :: Permutation m a
t2@(Choice [Branch m a]
bs2) = [Branch m b] -> Permutation m b
forall (parser :: * -> *) a.
[Branch parser a] -> Permutation parser a
Choice ((Branch m (a -> b) -> Branch m b)
-> [Branch m (a -> b)] -> [Branch m b]
forall a b. (a -> b) -> [a] -> [b]
map Branch m (a -> b) -> Branch m b
ins2 [Branch m (a -> b)]
bs1 [Branch m b] -> [Branch m b] -> [Branch m b]
forall a. [a] -> [a] -> [a]
++ (Branch m a -> Branch m b) -> [Branch m a] -> [Branch m b]
forall a b. (a -> b) -> [a] -> [b]
map Branch m a -> Branch m b
ins1 [Branch m a]
bs2)
    where
      ins1 :: Branch m a -> Branch m b
ins1 (Branch Permutation m (arg -> a)
perm m arg
p) = Permutation m (arg -> b) -> m arg -> Branch m b
forall (parser :: * -> *) a arg.
Permutation parser (arg -> a) -> parser arg -> Branch parser a
Branch ((a -> b) -> (arg -> a) -> arg -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((a -> b) -> (arg -> a) -> arg -> b)
-> Permutation m (a -> b) -> Permutation m ((arg -> a) -> arg -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Permutation m (a -> b)
t1 Permutation m ((arg -> a) -> arg -> b)
-> Permutation m (arg -> a) -> Permutation m (arg -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m (arg -> a)
perm) m arg
p
      ins2 :: Branch m (a -> b) -> Branch m b
ins2 (Branch Permutation m (arg -> a -> b)
perm m arg
p) = Permutation m (arg -> b) -> m arg -> Branch m b
forall (parser :: * -> *) a arg.
Permutation parser (arg -> a) -> parser arg -> Branch parser a
Branch ((arg -> a -> b) -> a -> arg -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((arg -> a -> b) -> a -> arg -> b)
-> Permutation m (arg -> a -> b) -> Permutation m (a -> arg -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Permutation m (arg -> a -> b)
perm Permutation m (a -> arg -> b)
-> Permutation m a -> Permutation m (arg -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m a
t2) m arg
p

-- | Wrap up a permutation parser with two effects:
--
-- It will first interleave an infinite number of some effects, which represent parsing "junk" or unwanted fields.
-- At every stage of the permutation, we will first try to run the effect we want, and if it fails
-- we will try to run the "junk" effect instead, then try again.
--
-- We attempt to *intersperse* the second effect afterwards.
-- It adds a new effect between every effect.
-- This is used in parsing JSON to add commas.
wrapEffect
  :: forall m a b. (Alternative m)
  => m b
  -- ^ Consume a single, \"junk\" field.
  -- Used to ignore JSON keys that we do not care about.
  -> m b
  -- ^ Consume a \"separator\" between items in the permutation.
  -- This consumption is not done at the front of the permutation
  -- or after the end of it.
  -- This is used to parse commas between JSON fields.
  -> Permutation m a
  -- ^ The permutation parser to run.
  -> m a
  -- ^ The final parser.
wrapEffect :: m b -> m b -> Permutation m a -> m a
wrapEffect m b
takeSingle m b
effAfter (Empty a
a) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
wrapEffect m b
takeSingle m b
effAfter (Choice [Branch m a]
choices) = m a
consumeMany
  where
    consumeMany :: m a
consumeMany
      = [m a] -> m a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (Branch m a -> m a
forall whatever. Branch m whatever -> m whatever
pars (Branch m a -> m a) -> [Branch m a] -> [m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
choices)
      -- Base case above: one of the choices of the permutation matched
      m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (m b
takeSingle m b -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m b
effAfter m b -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
consumeMany)
      -- Interleaving case: none of the choices of the permutation matched,
      -- so run a "junk" effect, the separator, and try again.
      -- Due to the recursion here we will do this infinitely until we either cannot
      -- run the junk effect, *or* we have a field that matches one of the choices of the permutation.
    runWithEffect :: Permutation m whatever -> m whatever
    runWithEffect :: Permutation m whatever -> m whatever
runWithEffect (Empty whatever
a) = whatever -> m whatever
forall (f :: * -> *) a. Applicative f => a -> f a
pure whatever
a
    runWithEffect (Choice [Branch m whatever]
choices) = m b
effAfter m b -> m whatever -> m whatever
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m whatever
consumeRec
        where
          consumeRec :: m whatever
consumeRec
            = [m whatever] -> m whatever
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (Branch m whatever -> m whatever
forall whatever. Branch m whatever -> m whatever
pars (Branch m whatever -> m whatever)
-> [Branch m whatever] -> [m whatever]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m whatever]
choices)
            -- Run one of the effects from the permutation
            m whatever -> m whatever -> m whatever
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (m b
takeSingle m b -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m b
effAfter m b -> m whatever -> m whatever
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m whatever
consumeRec)
            -- Interleave a potentially infinite number of junk effects, with the separator effect between them.
    pars :: Branch m whatever -> m whatever
    pars :: Branch m whatever -> m whatever
pars (Branch Permutation m (arg -> whatever)
perm m arg
arg) = do
      arg
a <- m arg
arg
      arg -> whatever
rest <- Permutation m (arg -> whatever) -> m (arg -> whatever)
forall whatever. Permutation m whatever -> m whatever
runWithEffect Permutation m (arg -> whatever)
perm
      pure $ arg -> whatever
rest arg
a

asParser :: (Alternative f) => Permutation f a -> f a
asParser :: Permutation f a -> f a
asParser (Empty a
a) = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
asParser (Choice [Branch f a]
choices) = [f a] -> f a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (Branch f a -> f a
forall (f :: * -> *) a. Alternative f => Branch f a -> f a
pars (Branch f a -> f a) -> [Branch f a] -> [f a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch f a]
choices)
    where
      pars :: (Alternative f) => Branch f a -> f a
      pars :: Branch f a -> f a
pars (Branch Permutation f (arg -> a)
perm f arg
arg) = do
        arg
a <- f arg
arg
        arg -> a
rest <- Permutation f (arg -> a) -> f (arg -> a)
forall (f :: * -> *) a. Alternative f => Permutation f a -> f a
asParser Permutation f (arg -> a)
perm
        pure $ arg -> a
rest arg
a

asPermutation :: (Alternative f) => f a -> Permutation f a
asPermutation :: f a -> Permutation f a
asPermutation f a
p = [Branch f a] -> Permutation f a
forall (parser :: * -> *) a.
[Branch parser a] -> Permutation parser a
Choice ([Branch f a] -> Permutation f a)
-> [Branch f a] -> Permutation f a
forall a b. (a -> b) -> a -> b
$ Branch f a -> [Branch f a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch f a -> [Branch f a]) -> Branch f a -> [Branch f a]
forall a b. (a -> b) -> a -> b
$ Permutation f (a -> a) -> f a -> Branch f a
forall (parser :: * -> *) a arg.
Permutation parser (arg -> a) -> parser arg -> Branch parser a
Branch ((a -> a) -> Permutation f (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id) f a
p