{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
module Jordan.FromJSON.Internal.Permutation where
import Control.Applicative (Alternative (..))
import Control.Monad (void, when)
import Data.Bifunctor
import Data.Foldable (asum)
import Data.Functor.Compose
import qualified Data.Map.Lazy as Map
import Data.Maybe (fromMaybe, isJust)
import Debug.Trace
data FailingParser parser
= FailingParser (forall a. parser a)
| NoFailingParser
instance (Applicative parser) => Semigroup (FailingParser parser) where
(FailingParser forall a. parser a
a) <> :: FailingParser parser
-> FailingParser parser -> FailingParser parser
<> (FailingParser forall a. parser a
b) = (forall a. parser a) -> FailingParser parser
forall (parser :: * -> *).
(forall a. parser a) -> FailingParser parser
FailingParser (parser Any
forall a. parser a
a parser Any -> parser a -> parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> parser a
forall a. parser a
b)
(FailingParser forall a. parser a
a) <> FailingParser parser
NoFailingParser = (forall a. parser a) -> FailingParser parser
forall (parser :: * -> *).
(forall a. parser a) -> FailingParser parser
FailingParser forall a. parser a
a
FailingParser parser
NoFailingParser <> (FailingParser forall a. parser a
a) = (forall a. parser a) -> FailingParser parser
forall (parser :: * -> *).
(forall a. parser a) -> FailingParser parser
FailingParser forall a. parser a
a
FailingParser parser
NoFailingParser <> FailingParser parser
NoFailingParser = FailingParser parser
forall (parser :: * -> *). FailingParser parser
NoFailingParser
eliminateFailing :: (Alternative parser) => FailingParser parser -> parser a
eliminateFailing :: FailingParser parser -> parser a
eliminateFailing (FailingParser forall a. parser a
f) = parser a
forall a. parser a
f
eliminateFailing FailingParser parser
NoFailingParser = parser a
forall (f :: * -> *) a. Alternative f => f a
empty
type role Permutation nominal representational
data Permutation parser a
= Permutation !(Maybe a) !(FailingParser parser) [Branch parser a]
type role Branch nominal representational
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 (Permutation Maybe a
def FailingParser m
failing [Branch m a]
branches) =
Maybe b -> FailingParser m -> [Branch m b] -> Permutation m b
forall (parser :: * -> *) a.
Maybe a
-> FailingParser parser
-> [Branch parser a]
-> Permutation parser a
Permutation (a -> b
f (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
def) FailingParser m
failing ((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]
branches)
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
val = Maybe a -> FailingParser m -> [Branch m a] -> Permutation m a
forall (parser :: * -> *) a.
Maybe a
-> FailingParser parser
-> [Branch parser a]
-> Permutation parser a
Permutation (a -> Maybe a
forall a. a -> Maybe a
Just a
val) FailingParser m
forall (parser :: * -> *). FailingParser parser
NoFailingParser [Branch m a]
forall (f :: * -> *) a. Alternative f => f a
empty
t1 :: Permutation m (a -> b)
t1@(Permutation Maybe (a -> b)
defF FailingParser m
failingF [Branch m (a -> b)]
choiceF) <*> :: Permutation m (a -> b) -> Permutation m a -> Permutation m b
<*> t2 :: Permutation m a
t2@(Permutation Maybe a
defA FailingParser m
failingA [Branch m a]
choiceA) =
Maybe b -> FailingParser m -> [Branch m b] -> Permutation m b
forall (parser :: * -> *) a.
Maybe a
-> FailingParser parser
-> [Branch parser a]
-> Permutation parser a
Permutation (Maybe (a -> b)
defF Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
defA) FailingParser m
forall (parser :: * -> *). FailingParser parser
NoFailingParser ((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)]
choiceF [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]
choiceA)
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
wrapEffect ::
forall m a b.
(Alternative m) =>
m b ->
m b ->
Permutation m a ->
m a
wrapEffect :: m b -> m b -> Permutation m a -> m a
wrapEffect m b
takeSingle m b
effAfter (Permutation Maybe a
def FailingParser m
failing [Branch m a]
choices) = m a
consumeMany
where
consumeMany :: m a
consumeMany =
(Branch m a -> m a -> m a) -> m a -> [Branch m a] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (m a -> m a -> m a)
-> (Branch m a -> m a) -> Branch m a -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch m a -> m a
forall whatever. Branch m whatever -> m whatever
pars) m a
forall (f :: * -> *) a. Alternative f => f a
empty [Branch m a]
choices
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)
m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (f :: * -> *) a. Alternative f => f a
empty a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
def
runWithEffect :: Permutation m whatever -> m whatever
runWithEffect :: Permutation m whatever -> m whatever
runWithEffect (Permutation Maybe whatever
def FailingParser m
failing [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) m whatever -> m whatever -> m whatever
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m whatever
-> (whatever -> m whatever) -> Maybe whatever -> m whatever
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FailingParser m -> m whatever
forall (parser :: * -> *) a.
Alternative parser =>
FailingParser parser -> parser a
eliminateFailing FailingParser m
failing) whatever -> m whatever
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe whatever
def
where
consumeRec :: m whatever
consumeRec =
(Branch m whatever -> m whatever -> m whatever)
-> m whatever -> [Branch m whatever] -> m whatever
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (m whatever -> m whatever -> m whatever
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (m whatever -> m whatever -> m whatever)
-> (Branch m whatever -> m whatever)
-> Branch m whatever
-> m whatever
-> m whatever
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch m whatever -> m whatever
forall whatever. Branch m whatever -> m whatever
pars) m whatever
forall (f :: * -> *) a. Alternative f => f a
empty [Branch m whatever]
choices
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)
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 (Permutation Maybe a
def FailingParser f
failing [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) f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a -> (a -> f a) -> Maybe a -> f a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe f a
forall (f :: * -> *) a. Alternative f => f a
empty a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
def f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FailingParser f -> f a
forall (parser :: * -> *) a.
Alternative parser =>
FailingParser parser -> parser a
eliminateFailing FailingParser f
failing
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 = Maybe a -> FailingParser f -> [Branch f a] -> Permutation f a
forall (parser :: * -> *) a.
Maybe a
-> FailingParser parser
-> [Branch parser a]
-> Permutation parser a
Permutation Maybe a
forall a. Maybe a
Nothing FailingParser f
forall (parser :: * -> *). FailingParser parser
NoFailingParser ([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
asPermutationWithDefault :: (Alternative f) => f a -> a -> Permutation f a
asPermutationWithDefault :: f a -> a -> Permutation f a
asPermutationWithDefault f a
per a
def = Maybe a -> FailingParser f -> [Branch f a] -> Permutation f a
forall (parser :: * -> *) a.
Maybe a
-> FailingParser parser
-> [Branch parser a]
-> Permutation parser a
Permutation (a -> Maybe a
forall a. a -> Maybe a
Just a
def) FailingParser f
forall (parser :: * -> *). FailingParser parser
NoFailingParser ([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
per
asPermutationWithFailing :: (Alternative f) => f a -> (forall b. f b) -> Permutation f a
asPermutationWithFailing :: f a -> (forall b. f b) -> Permutation f a
asPermutationWithFailing f a
parse forall b. f b
fail = Maybe a -> FailingParser f -> [Branch f a] -> Permutation f a
forall (parser :: * -> *) a.
Maybe a
-> FailingParser parser
-> [Branch parser a]
-> Permutation parser a
Permutation Maybe a
forall a. Maybe a
Nothing ((forall b. f b) -> FailingParser f
forall (parser :: * -> *).
(forall a. parser a) -> FailingParser parser
FailingParser forall b. f b
fail) ([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
parse
asPermutationWithDefaultFailing :: (Alternative f) => f a -> (forall b. f b) -> a -> Permutation f a
asPermutationWithDefaultFailing :: f a -> (forall b. f b) -> a -> Permutation f a
asPermutationWithDefaultFailing f a
parse forall b. f b
fail a
def = Maybe a -> FailingParser f -> [Branch f a] -> Permutation f a
forall (parser :: * -> *) a.
Maybe a
-> FailingParser parser
-> [Branch parser a]
-> Permutation parser a
Permutation (a -> Maybe a
forall a. a -> Maybe a
Just a
def) ((forall b. f b) -> FailingParser f
forall (parser :: * -> *).
(forall a. parser a) -> FailingParser parser
FailingParser forall b. f b
fail) ([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
parse