{-# LANGUAGE StrictData #-}

module Lasercutter.Types where

import Control.Applicative
import Control.Selective
import Data.Monoid
import Data.Profunctor
import Witherable


------------------------------------------------------------------------------
-- | Lasercutter supports any inductive tree types, as witnessed by
-- 'getChildren'.
--
-- @since 0.1.0.0
class IsTree t where
  -- | Get all children of the current node.
  --
  -- @since 0.1.0.0
  getChildren :: t -> [t]


------------------------------------------------------------------------------
-- | A tree parser which runs all queries in a single pass. This is
-- accomplished via a free encoding of the applicative structure, which can be
-- arbitrarily reassociated for better performance.
--
-- @since 0.1.0.0
data Parser bc t a where
  -- | The free 'pure' constructor.
  --
  -- @since 0.1.0.0
  Pure       :: a -> Parser bc t a
  -- | The free 'liftA2' constructor. This is an inlining of Day convolution.
  --
  -- @since 0.1.0.0
  LiftA2     :: (b -> c -> a) -> Parser bc t b -> Parser bc t c -> Parser bc t a
  -- | Get the breadcrumbs at the current part of the tree.
  --
  -- @since 0.1.0.0
  GetCrumbs  :: Parser bc t bc
  -- | Run the given parser at every subtree which matches the given predicate.
  -- This is not recursive --- that is, a given subtree only runs the given
  -- parser once, not in all further matching subtrees.
  --
  -- @since 0.1.0.0
  Target     :: (t -> Bool) -> Parser bc t a -> Parser bc t [a]
  -- | Run the given parser on each child of the current node.
  --
  -- @since 0.1.0.0
  OnChildren :: Parser bc t a -> Parser bc t [a]
  -- | Get the current node.
  --
  -- @since 0.1.0.0
  Current    :: Parser bc t t
  -- | Swallow a parsed 'Maybe', failing the parser if it was 'Nothing'. Don't
  -- use this constructor explicitly; prefer 'expect' which maintains some
  -- invariants.
  --
  -- 'optional' is the inverse to this parser.
  --
  -- @since 0.1.0.0
  Expect     :: Parser bc t (Maybe a) -> Parser bc t a
  -- | Immediately fail a parse. Equivalent to @'Expect' ('pure' 'Nothing')@.
  --
  -- @since 0.1.0.0
  Fail       :: Parser bc t a
  deriving (b -> Parser bc t a -> Parser bc t a
NonEmpty (Parser bc t a) -> Parser bc t a
Parser bc t a -> Parser bc t a -> Parser bc t a
(Parser bc t a -> Parser bc t a -> Parser bc t a)
-> (NonEmpty (Parser bc t a) -> Parser bc t a)
-> (forall b. Integral b => b -> Parser bc t a -> Parser bc t a)
-> Semigroup (Parser bc t a)
forall b. Integral b => b -> Parser bc t a -> Parser bc t a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall bc t a.
Semigroup a =>
NonEmpty (Parser bc t a) -> Parser bc t a
forall bc t a.
Semigroup a =>
Parser bc t a -> Parser bc t a -> Parser bc t a
forall bc t a b.
(Semigroup a, Integral b) =>
b -> Parser bc t a -> Parser bc t a
stimes :: b -> Parser bc t a -> Parser bc t a
$cstimes :: forall bc t a b.
(Semigroup a, Integral b) =>
b -> Parser bc t a -> Parser bc t a
sconcat :: NonEmpty (Parser bc t a) -> Parser bc t a
$csconcat :: forall bc t a.
Semigroup a =>
NonEmpty (Parser bc t a) -> Parser bc t a
<> :: Parser bc t a -> Parser bc t a -> Parser bc t a
$c<> :: forall bc t a.
Semigroup a =>
Parser bc t a -> Parser bc t a -> Parser bc t a
Semigroup, Semigroup (Parser bc t a)
Parser bc t a
Semigroup (Parser bc t a)
-> Parser bc t a
-> (Parser bc t a -> Parser bc t a -> Parser bc t a)
-> ([Parser bc t a] -> Parser bc t a)
-> Monoid (Parser bc t a)
[Parser bc t a] -> Parser bc t a
Parser bc t a -> Parser bc t a -> Parser bc t a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall bc t a. Monoid a => Semigroup (Parser bc t a)
forall bc t a. Monoid a => Parser bc t a
forall bc t a. Monoid a => [Parser bc t a] -> Parser bc t a
forall bc t a.
Monoid a =>
Parser bc t a -> Parser bc t a -> Parser bc t a
mconcat :: [Parser bc t a] -> Parser bc t a
$cmconcat :: forall bc t a. Monoid a => [Parser bc t a] -> Parser bc t a
mappend :: Parser bc t a -> Parser bc t a -> Parser bc t a
$cmappend :: forall bc t a.
Monoid a =>
Parser bc t a -> Parser bc t a -> Parser bc t a
mempty :: Parser bc t a
$cmempty :: forall bc t a. Monoid a => Parser bc t a
$cp1Monoid :: forall bc t a. Monoid a => Semigroup (Parser bc t a)
Monoid) via (Ap (Parser bc t) a)

instance Show (Parser bc t a) where
  show :: Parser bc t a -> String
show (Pure a
_) = String
"(Pure _)"
  show (LiftA2 b -> c -> a
_ Parser bc t b
pa' Parser bc t c
pa_bctc) =
    String
"(LiftA2 _ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Parser bc t b -> String
forall a. Show a => a -> String
show Parser bc t b
pa' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Parser bc t c -> String
forall a. Show a => a -> String
show Parser bc t c
pa_bctc String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show Parser bc t a
GetCrumbs = String
"GetCrumbs"
  show (Target t -> Bool
_ Parser bc t a
pa') = String
"(Target _ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Parser bc t a -> String
forall a. Show a => a -> String
show Parser bc t a
pa' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"')"
  show (OnChildren Parser bc t a
pa') = String
"(OnChildren " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Parser bc t a -> String
forall a. Show a => a -> String
show Parser bc t a
pa' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show Parser bc t a
Current = String
"Current"
  show (Expect Parser bc t (Maybe a)
pa') = String
"(Expect " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Parser bc t (Maybe a) -> String
forall a. Show a => a -> String
show Parser bc t (Maybe a)
pa' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show Parser bc t a
Fail = String
"Fail"


instance Functor (Parser bc t) where
  fmap :: (a -> b) -> Parser bc t a -> Parser bc t b
fmap = (a -> b) -> Parser bc t a -> Parser bc t b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA

instance Applicative (Parser bc t) where
  pure :: a -> Parser bc t a
pure = a -> Parser bc t a
forall a bc t. a -> Parser bc t a
Pure
  liftA2 :: (a -> b -> c) -> Parser bc t a -> Parser bc t b -> Parser bc t c
liftA2 a -> b -> c
f (Pure a
a) (Pure b
b) = c -> Parser bc t c
forall a bc t. a -> Parser bc t a
Pure (c -> Parser bc t c) -> c -> Parser bc t c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
f a
a b
b
  liftA2 a -> b -> c
_ Parser bc t a
Fail Parser bc t b
_ = Parser bc t c
forall bc t a. Parser bc t a
Fail
  liftA2 a -> b -> c
_ Parser bc t a
_ Parser bc t b
Fail = Parser bc t c
forall bc t a. Parser bc t a
Fail
  liftA2 a -> b -> c
f Parser bc t a
a Parser bc t b
b    = (a -> b -> c) -> Parser bc t a -> Parser bc t b -> Parser bc t c
forall b c a bc t.
(b -> c -> a) -> Parser bc t b -> Parser bc t c -> Parser bc t a
LiftA2 a -> b -> c
f Parser bc t a
a Parser bc t b
b

instance Alternative (Parser bc t) where
  empty :: Parser bc t a
empty = Parser bc t a
forall bc t a. Parser bc t a
Fail
  Parser bc t a
pa1 <|> :: Parser bc t a -> Parser bc t a -> Parser bc t a
<|> Parser bc t a
pa2 =
    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
$ Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a)
-> Parser bc t (Maybe a)
-> Parser bc t ((a -> Maybe a) -> Maybe a -> Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser bc t a -> Parser bc t (Maybe a)
forall bc t a. Parser bc t a -> Parser bc t (Maybe a)
try Parser bc t a
pa2 Parser bc t ((a -> Maybe a) -> Maybe a -> Maybe a)
-> Parser bc t (a -> Maybe a) -> Parser bc t (Maybe a -> Maybe a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> Maybe a) -> Parser bc t (a -> Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> Maybe a
forall a. a -> Maybe a
Just Parser bc t (Maybe a -> Maybe a)
-> Parser bc t (Maybe a) -> Parser bc t (Maybe a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser bc t a -> Parser bc t (Maybe a)
forall bc t a. Parser bc t a -> Parser bc t (Maybe a)
try Parser bc t a
pa1

instance Selective (Parser bc t) where
  select :: Parser bc t (Either a b) -> Parser bc t (a -> b) -> Parser bc t b
select = Parser bc t (Either a b) -> Parser bc t (a -> b) -> Parser bc t b
forall (f :: * -> *) a b.
Applicative f =>
f (Either a b) -> f (a -> b) -> f b
selectA

instance Filterable (Parser bc t) where
  catMaybes :: Parser bc t (Maybe a) -> Parser bc t a
catMaybes = Parser bc t (Maybe a) -> Parser bc t a
forall bc t a. Parser bc t (Maybe a) -> Parser bc t a
Expect

instance Profunctor (Parser bc) where
  lmap :: (a -> b) -> Parser bc b c -> Parser bc a c
lmap = (a -> b) -> Parser bc b c -> Parser bc a c
forall t t' bc a. (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree
  rmap :: (b -> c) -> Parser bc a b -> Parser bc a c
rmap = (b -> c) -> Parser bc a b -> Parser bc a c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap


------------------------------------------------------------------------------
-- | Transform the type of tree that a 'Parser' operates over.
--
-- @since 0.1.0.0
mapTree :: (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree :: (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree t -> t'
_ (Pure a
a)         = a -> Parser bc t a
forall a bc t. a -> Parser bc t a
Pure a
a
mapTree t -> t'
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 ((t -> t') -> Parser bc t' b -> Parser bc t b
forall t t' bc a. (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree t -> t'
t Parser bc t' b
pa) ((t -> t') -> Parser bc t' c -> Parser bc t c
forall t t' bc a. (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree t -> t'
t Parser bc t' c
pb)
mapTree t -> t'
_ Parser bc t' a
GetCrumbs        = Parser bc t a
forall bc t. Parser bc t bc
GetCrumbs
mapTree t -> t'
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 (t' -> Bool) -> (t -> t') -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t'
t) (Parser bc t a -> Parser bc t [a])
-> Parser bc t a -> Parser bc t [a]
forall a b. (a -> b) -> a -> b
$ (t -> t') -> Parser bc t' a -> Parser bc t a
forall t t' bc a. (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree t -> t'
t Parser bc t' a
pa
mapTree t -> t'
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
$ (t -> t') -> Parser bc t' a -> Parser bc t a
forall t t' bc a. (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree t -> t'
t Parser bc t' a
pa
mapTree t -> t'
t Parser bc t' a
Current          = (t -> t') -> Parser bc t t -> Parser bc t t'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> t'
t Parser bc t t
forall bc t. Parser bc t t
Current
mapTree t -> t'
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
$ (t -> t') -> Parser bc t' (Maybe a) -> Parser bc t (Maybe a)
forall t t' bc a. (t -> t') -> Parser bc t' a -> Parser bc t a
mapTree t -> t'
t Parser bc t' (Maybe a)
pa
mapTree t -> t'
_ Parser bc t' a
Fail             = Parser bc t a
forall bc t a. Parser bc t a
Fail


------------------------------------------------------------------------------
-- | A parser to run on children, and a subsequent continuation for how to
-- parse the parent.
--
-- @since 0.1.0.0
data Split bc t a where
  Split
      :: Parser bc t a
         -- ^ The parser to run on children.
      -> ([a] -> Parser bc t b)
         -- ^ Continuation for how to subsequently parse the current node.
      -> Split bc t b


------------------------------------------------------------------------------
-- | Swallow a parsed 'Maybe', failing the parser if it was 'Nothing'.
--
-- Use 'try' or 'optional' as the inverse to this parser.
--
-- @since 0.1.0.0
expect :: Parser bc t (Maybe a) -> Parser bc t a
expect :: Parser bc t (Maybe a) -> Parser bc t a
expect (Pure Maybe a
Nothing)  = Parser bc t a
forall bc t a. Parser bc t a
Fail
expect (Pure (Just a
a)) = a -> Parser bc t a
forall a bc t. a -> Parser bc t a
Pure a
a
expect Parser bc t (Maybe a)
p               = 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)
p


------------------------------------------------------------------------------
-- | Like 'optional', but slightly more efficient.
--
-- @since 0.1.0.0
try :: Parser bc t a -> Parser bc t (Maybe a)
try :: Parser bc t a -> Parser bc t (Maybe a)
try Parser bc t a
Fail           = Maybe a -> Parser bc t (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
try (Expect Parser bc t (Maybe a)
p)     = Parser bc t (Maybe a)
p
try (LiftA2 b -> c -> a
f Parser bc t b
a Parser bc t c
b) = (Maybe b -> Maybe c -> Maybe a)
-> Parser bc t (Maybe b)
-> Parser bc t (Maybe c)
-> Parser bc t (Maybe 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) -> 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 -> Parser bc t (Maybe b)
forall bc t a. Parser bc t a -> Parser bc t (Maybe a)
try Parser bc t b
a) (Parser bc t c -> Parser bc t (Maybe c)
forall bc t a. Parser bc t a -> Parser bc t (Maybe a)
try Parser bc t c
b)
try Parser bc t a
p              = (a -> Maybe a) -> Parser bc t a -> Parser bc t (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just Parser bc t a
p