module Lasercutter.Internal where

import Control.Applicative
import Control.Monad (join)
import Data.Maybe (mapMaybe)
import Lasercutter.Types


------------------------------------------------------------------------------
-- | Split a parser into a parser to run on the node's children, and how to
-- reassemble those pieces into a parser for the current node.
--
-- @since 0.1.0.0
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


------------------------------------------------------------------------------
-- | There is no work to do for the children, so ignore them.
--
-- @since 0.1.0.0
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


------------------------------------------------------------------------------
-- | Append a continuation after a 'Split'.
--
-- @since 0.1.0.0
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


------------------------------------------------------------------------------
-- | Parse the current node by splitting the parser, accumulating the results
-- of each child, and then running the continuation.
--
-- @since 0.1.0.0
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


------------------------------------------------------------------------------
-- | Run a parser on each child, accumulating the results.
--
-- @since 0.1.0.0
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


------------------------------------------------------------------------------
-- | Extract a value from a parser. The way the applicative evaluates,
-- all "combinator" effects are guaranteed to have been run by the time this
-- function gets called.
--
-- @since 0.1.0.0
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"


------------------------------------------------------------------------------
-- | Run a parser over a tree in a single pass.
--
-- @since 0.1.0.0
runParser
    :: (Monoid bc, IsTree t)
    => (t -> bc)
       -- ^ A means of summarizing the current node for tracking breadcrumbs.
       -- If you don't need breadcrumbs, use @'const' ()@.
    -> t
       -- ^ The tree to parse.
    -> Parser bc t a
       -- ^ How to parse the tree.
    -> 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


------------------------------------------------------------------------------
-- | Transformer the breadcrumbs of a 'Parser'.
--
-- @since 0.1.0.0
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