module Lasercutter.Internal where
import Control.Applicative
import Control.Monad (join)
import Data.Maybe (mapMaybe)
import Lasercutter.Types
split :: bc -> Parser bc t a -> t -> Split bc t a
split :: bc -> Parser bc t a -> t -> Split bc t a
split bc
_ (Pure a
a) t
_ = Parser bc t a -> Split bc t a
forall bc t b. Parser bc t b -> Split bc t b
ignoreChildren (Parser bc t a -> Split bc t a) -> Parser bc t a -> Split bc t a
forall a b. (a -> b) -> a -> b
$ a -> Parser bc t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
split bc
cr Parser bc t a
GetCrumbs t
_ = Parser bc t bc -> Split bc t bc
forall bc t b. Parser bc t b -> Split bc t b
ignoreChildren (Parser bc t bc -> Split bc t bc)
-> Parser bc t bc -> Split bc t bc
forall a b. (a -> b) -> a -> b
$ bc -> Parser bc t bc
forall (f :: * -> *) a. Applicative f => a -> f a
pure bc
cr
split bc
cr (LiftA2 b -> c -> a
f Parser bc t b
l Parser bc t c
r) t
tt =
case (bc -> Parser bc t b -> t -> Split bc t b
forall bc t a. bc -> Parser bc t a -> t -> Split bc t a
split bc
cr Parser bc t b
l t
tt, bc -> Parser bc t c -> t -> Split bc t c
forall bc t a. bc -> Parser bc t a -> t -> Split bc t a
split bc
cr Parser bc t c
r t
tt) of
(Split Parser bc t a
l' [a] -> Parser bc t b
kl, Split Parser bc t a
r' [a] -> Parser bc t c
kr) ->
Parser bc t (a, a) -> ([(a, a)] -> Parser bc t a) -> Split bc t a
forall bc t a b.
Parser bc t a -> ([a] -> Parser bc t b) -> Split bc t b
Split ((a -> a -> (a, a))
-> Parser bc t a -> Parser bc t a -> Parser bc t (a, a)
forall b c a bc t.
(b -> c -> a) -> Parser bc t b -> Parser bc t c -> Parser bc t a
LiftA2 (,) Parser bc t a
l' Parser bc t a
r') (([(a, a)] -> Parser bc t a) -> Split bc t a)
-> ([(a, a)] -> Parser bc t a) -> Split bc t a
forall a b. (a -> b) -> a -> b
$ \([(a, a)] -> ([a], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip -> ([a]
lcs, [a]
rcs)) ->
(b -> c -> a) -> Parser bc t b -> Parser bc t c -> Parser bc t a
forall b c a bc t.
(b -> c -> a) -> Parser bc t b -> Parser bc t c -> Parser bc t a
LiftA2 b -> c -> a
f ([a] -> Parser bc t b
kl [a]
lcs) ([a] -> Parser bc t c
kr [a]
rcs)
split bc
cr p0 :: Parser bc t a
p0@(Target t -> Bool
se Parser bc t a
pa) t
tt
| t -> Bool
se t
tt
= (Parser bc t a -> Parser bc t [a])
-> Split bc t a -> Split bc t [a]
forall bc t a b.
(Parser bc t a -> Parser bc t b) -> Split bc t a -> Split bc t b
continue ((a -> [a]) -> Parser bc t a -> Parser bc t [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Split bc t a -> Split bc t [a]) -> Split bc t a -> Split bc t [a]
forall a b. (a -> b) -> a -> b
$ bc -> Parser bc t a -> t -> Split bc t a
forall bc t a. bc -> Parser bc t a -> t -> Split bc t a
split bc
cr Parser bc t a
pa t
tt
| Bool
otherwise
= Parser bc t a -> ([a] -> Parser bc t [a]) -> Split bc t [a]
forall bc t a b.
Parser bc t a -> ([a] -> Parser bc t b) -> Split bc t b
Split Parser bc t a
p0 (([a] -> Parser bc t [a]) -> Split bc t [a])
-> ([a] -> Parser bc t [a]) -> Split bc t [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Parser bc t [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Parser bc t [a])
-> ([[a]] -> [a]) -> [[a]] -> Parser bc t [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [a]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
split bc
cr (Expect Parser bc t (Maybe a)
pa) t
tt = (Parser bc t (Maybe a) -> Parser bc t a)
-> Split bc t (Maybe a) -> Split bc t a
forall bc t a b.
(Parser bc t a -> Parser bc t b) -> Split bc t a -> Split bc t b
continue Parser bc t (Maybe a) -> Parser bc t a
forall bc t a. Parser bc t (Maybe a) -> Parser bc t a
expect (Split bc t (Maybe a) -> Split bc t a)
-> Split bc t (Maybe a) -> Split bc t a
forall a b. (a -> b) -> a -> b
$ bc -> Parser bc t (Maybe a) -> t -> Split bc t (Maybe a)
forall bc t a. bc -> Parser bc t a -> t -> Split bc t a
split bc
cr Parser bc t (Maybe a)
pa t
tt
split bc
_ (OnChildren Parser bc t a
pa) t
_ = Parser bc t a -> ([a] -> Parser bc t [a]) -> Split bc t [a]
forall bc t a b.
Parser bc t a -> ([a] -> Parser bc t b) -> Split bc t b
Split Parser bc t a
pa [a] -> Parser bc t [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
split bc
_ Parser bc t a
Current t
tt = Parser bc t t -> Split bc t t
forall bc t b. Parser bc t b -> Split bc t b
ignoreChildren (Parser bc t t -> Split bc t t) -> Parser bc t t -> Split bc t t
forall a b. (a -> b) -> a -> b
$ t -> Parser bc t t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
tt
split bc
_ Parser bc t a
Fail t
_ = Parser bc t Any -> ([Any] -> Parser bc t a) -> Split bc t a
forall bc t a b.
Parser bc t a -> ([a] -> Parser bc t b) -> Split bc t b
Split Parser bc t Any
forall bc t a. Parser bc t a
Fail (([Any] -> Parser bc t a) -> Split bc t a)
-> ([Any] -> Parser bc t a) -> Split bc t a
forall a b. (a -> b) -> a -> b
$ Parser bc t a -> [Any] -> Parser bc t a
forall a b. a -> b -> a
const (Parser bc t a -> [Any] -> Parser bc t a)
-> Parser bc t a -> [Any] -> Parser bc t a
forall a b. (a -> b) -> a -> b
$ Parser bc t a
forall bc t a. Parser bc t a
Fail
ignoreChildren :: Parser bc t b -> Split bc t b
ignoreChildren :: Parser bc t b -> Split bc t b
ignoreChildren = Parser bc t () -> ([()] -> Parser bc t b) -> Split bc t b
forall bc t a b.
Parser bc t a -> ([a] -> Parser bc t b) -> Split bc t b
Split (() -> Parser bc t ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (([()] -> Parser bc t b) -> Split bc t b)
-> (Parser bc t b -> [()] -> Parser bc t b)
-> Parser bc t b
-> Split bc t b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser bc t b -> [()] -> Parser bc t b
forall a b. a -> b -> a
const
continue :: (Parser bc t a -> Parser bc t b) -> Split bc t a -> Split bc t b
continue :: (Parser bc t a -> Parser bc t b) -> Split bc t a -> Split bc t b
continue Parser bc t a -> Parser bc t b
f (Split Parser bc t a
p [a] -> Parser bc t a
k) = Parser bc t a -> ([a] -> Parser bc t b) -> Split bc t b
forall bc t a b.
Parser bc t a -> ([a] -> Parser bc t b) -> Split bc t b
Split Parser bc t a
p (([a] -> Parser bc t b) -> Split bc t b)
-> ([a] -> Parser bc t b) -> Split bc t b
forall a b. (a -> b) -> a -> b
$ Parser bc t a -> Parser bc t b
f (Parser bc t a -> Parser bc t b)
-> ([a] -> Parser bc t a) -> [a] -> Parser bc t b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Parser bc t a
k
parseNode
:: (Semigroup bc, IsTree t)
=> (t -> bc)
-> bc
-> Parser bc t a
-> t
-> Parser bc t a
parseNode :: (t -> bc) -> bc -> Parser bc t a -> t -> Parser bc t a
parseNode t -> bc
summarize bc
cr Parser bc t a
p t
tt =
case bc -> Parser bc t a -> t -> Split bc t a
forall bc t a. bc -> Parser bc t a -> t -> Split bc t a
split bc
cr' Parser bc t a
p t
tt of
Split (Pure a
a) [a] -> Parser bc t a
k -> [a] -> Parser bc t a
k [a
a]
Split Parser bc t a
pa [a] -> Parser bc t a
k -> [a] -> Parser bc t a
k ([a] -> Parser bc t a) -> [a] -> Parser bc t a
forall a b. (a -> b) -> a -> b
$ (t -> bc) -> bc -> Parser bc t a -> [t] -> [a]
forall t bc a.
(IsTree t, Semigroup bc) =>
(t -> bc) -> bc -> Parser bc t a -> [t] -> [a]
parseChildren t -> bc
summarize bc
cr' Parser bc t a
pa ([t] -> [a]) -> [t] -> [a]
forall a b. (a -> b) -> a -> b
$ t -> [t]
forall t. IsTree t => t -> [t]
getChildren t
tt
where
cr' :: bc
cr' = t -> bc
summarize t
tt bc -> bc -> bc
forall a. Semigroup a => a -> a -> a
<> bc
cr
parseChildren
:: (IsTree t, Semigroup bc)
=> (t -> bc)
-> bc
-> Parser bc t a
-> [t]
-> [a]
parseChildren :: (t -> bc) -> bc -> Parser bc t a -> [t] -> [a]
parseChildren t -> bc
summarize bc
cr Parser bc t a
pa =
(t -> Maybe a) -> [t] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((t -> Maybe a) -> [t] -> [a]) -> (t -> Maybe a) -> [t] -> [a]
forall a b. (a -> b) -> a -> b
$ Parser bc t a -> Maybe a
forall bc t a. Parser bc t a -> Maybe a
getResult (Parser bc t a -> Maybe a) -> (t -> Parser bc t a) -> t -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> bc) -> bc -> Parser bc t a -> t -> Parser bc t a
forall bc t a.
(Semigroup bc, IsTree t) =>
(t -> bc) -> bc -> Parser bc t a -> t -> Parser bc t a
parseNode t -> bc
summarize bc
cr Parser bc t a
pa
getResult :: Parser bc t a -> Maybe a
getResult :: Parser bc t a -> Maybe a
getResult (Pure a
a) = a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
getResult (LiftA2 b -> c -> a
f Parser bc t b
a Parser bc t c
b) = (b -> c -> a) -> Maybe b -> Maybe c -> Maybe a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> c -> a
f (Parser bc t b -> Maybe b
forall bc t a. Parser bc t a -> Maybe a
getResult Parser bc t b
a) (Parser bc t c -> Maybe c
forall bc t a. Parser bc t a -> Maybe a
getResult Parser bc t c
b)
getResult (Expect Parser bc t (Maybe a)
pa) = Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a) -> Maybe (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ Parser bc t (Maybe a) -> Maybe (Maybe a)
forall bc t a. Parser bc t a -> Maybe a
getResult Parser bc t (Maybe a)
pa
getResult Parser bc t a
Fail = Maybe a
forall a. Maybe a
Nothing
getResult Parser bc t a
GetCrumbs = [Char] -> Maybe a
forall a. HasCallStack => [Char] -> a
error [Char]
"getResult: impossible"
getResult (Target t -> Bool
_ Parser bc t a
_) = [Char] -> Maybe a
forall a. HasCallStack => [Char] -> a
error [Char]
"getResult: impossible"
getResult (OnChildren Parser bc t a
_) = [Char] -> Maybe a
forall a. HasCallStack => [Char] -> a
error [Char]
"getResult: impossible"
getResult Parser bc t a
Current = [Char] -> Maybe a
forall a. HasCallStack => [Char] -> a
error [Char]
"getResult: impossible"
runParser
:: (Monoid bc, IsTree t)
=> (t -> bc)
-> t
-> Parser bc t a
-> Maybe a
runParser :: (t -> bc) -> t -> Parser bc t a -> Maybe a
runParser t -> bc
summarize t
tt =
Parser bc t a -> Maybe a
forall bc t a. Parser bc t a -> Maybe a
getResult (Parser bc t a -> Maybe a)
-> (Parser bc t a -> Parser bc t a) -> Parser bc t a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parser bc t a -> t -> Parser bc t a)
-> t -> Parser bc t a -> Parser bc t a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((t -> bc) -> bc -> Parser bc t a -> t -> Parser bc t a
forall bc t a.
(Semigroup bc, IsTree t) =>
(t -> bc) -> bc -> Parser bc t a -> t -> Parser bc t a
parseNode t -> bc
summarize bc
forall a. Monoid a => a
mempty) t
tt
mapBreadcrumbs :: (bc' -> bc) -> Parser bc t a -> Parser bc' t a
mapBreadcrumbs :: (bc' -> bc) -> Parser bc t a -> Parser bc' t a
mapBreadcrumbs bc' -> bc
_ (Pure a
a) = a -> Parser bc' t a
forall a bc t. a -> Parser bc t a
Pure a
a
mapBreadcrumbs bc' -> bc
t (LiftA2 b -> c -> a
f Parser bc t b
pa Parser bc t c
pb) = (b -> c -> a) -> Parser bc' t b -> Parser bc' t c -> Parser bc' t a
forall b c a bc t.
(b -> c -> a) -> Parser bc t b -> Parser bc t c -> Parser bc t a
LiftA2 b -> c -> a
f ((bc' -> bc) -> Parser bc t b -> Parser bc' t b
forall bc' bc t a. (bc' -> bc) -> Parser bc t a -> Parser bc' t a
mapBreadcrumbs bc' -> bc
t Parser bc t b
pa) ((bc' -> bc) -> Parser bc t c -> Parser bc' t c
forall bc' bc t a. (bc' -> bc) -> Parser bc t a -> Parser bc' t a
mapBreadcrumbs bc' -> bc
t Parser bc t c
pb)
mapBreadcrumbs bc' -> bc
t Parser bc t a
GetCrumbs = (bc' -> bc) -> Parser bc' t bc' -> Parser bc' t bc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap bc' -> bc
t Parser bc' t bc'
forall bc t. Parser bc t bc
GetCrumbs
mapBreadcrumbs bc' -> bc
t (Target t -> Bool
p Parser bc t a
pa) = (t -> Bool) -> Parser bc' t a -> Parser bc' t [a]
forall t bc a. (t -> Bool) -> Parser bc t a -> Parser bc t [a]
Target t -> Bool
p (Parser bc' t a -> Parser bc' t [a])
-> Parser bc' t a -> Parser bc' t [a]
forall a b. (a -> b) -> a -> b
$ (bc' -> bc) -> Parser bc t a -> Parser bc' t a
forall bc' bc t a. (bc' -> bc) -> Parser bc t a -> Parser bc' t a
mapBreadcrumbs bc' -> bc
t Parser bc t a
pa
mapBreadcrumbs bc' -> bc
t (OnChildren Parser bc t a
pa) = Parser bc' t a -> Parser bc' t [a]
forall bc t a. Parser bc t a -> Parser bc t [a]
OnChildren (Parser bc' t a -> Parser bc' t [a])
-> Parser bc' t a -> Parser bc' t [a]
forall a b. (a -> b) -> a -> b
$ (bc' -> bc) -> Parser bc t a -> Parser bc' t a
forall bc' bc t a. (bc' -> bc) -> Parser bc t a -> Parser bc' t a
mapBreadcrumbs bc' -> bc
t Parser bc t a
pa
mapBreadcrumbs bc' -> bc
_ Parser bc t a
Current = Parser bc' t a
forall bc t. Parser bc t t
Current
mapBreadcrumbs bc' -> bc
t (Expect Parser bc t (Maybe a)
pa) = Parser bc' t (Maybe a) -> Parser bc' t a
forall bc t a. Parser bc t (Maybe a) -> Parser bc t a
Expect (Parser bc' t (Maybe a) -> Parser bc' t a)
-> Parser bc' t (Maybe a) -> Parser bc' t a
forall a b. (a -> b) -> a -> b
$ (bc' -> bc) -> Parser bc t (Maybe a) -> Parser bc' t (Maybe a)
forall bc' bc t a. (bc' -> bc) -> Parser bc t a -> Parser bc' t a
mapBreadcrumbs bc' -> bc
t Parser bc t (Maybe a)
pa
mapBreadcrumbs bc' -> bc
_ Parser bc t a
Fail = Parser bc' t a
forall bc t a. Parser bc t a
Fail