{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module: Covenant.Zipper
-- Copyright: (C) MLabs 2025
-- License: Apache 2.0
-- Maintainer: koz@mlabs.city, sean@mlabs.city
--
-- A read-only zipper for the Covenant ASG, based on an action monad.
--
-- @since 1.3.0
module Covenant.Zipper
  ( -- * Types
    ZipperAction,
    Tape (..),
    ZipperState (WorkingZipper, BrokenZipper),
    ASGZipper,

    -- * Functions

    -- ** Actions
    moveUp,
    moveDown,
    moveLeft,
    moveRight,
    resetZipper,

    -- ** Elimination
    runASGZipper,
  )
where

import Control.Monad.Action
  ( Action (StateOf, act),
    Actionable,
    MonadUpdate,
    UpdateT,
    actionable,
    runUpdateT,
  )
import Covenant.ASG
  ( ASG,
    ASGNode (ACompNode, AValNode, AnError),
    Arg,
    CompNodeInfo (Force, Lam),
    Id,
    Ref (AnArg, AnId),
    ValNodeInfo (App, Cata, DataConstructor, Match, Thunk),
    nodeAt,
    topLevelId,
  )
import Covenant.Util (pattern ConsV, pattern NilV)
import Data.Functor.Identity (Identity, runIdentity)
import Data.Kind (Type)
import Data.Monoid (Endo (Endo))
import GHC.Exts (toList)

-- | A requested movement from the zipper. To build these, use dedicated smart
-- constructors in this module. You can \'chain together\' 'ZipperAction' using
-- the 'Semigroup' instance.
--
-- @since 1.3.0
newtype ZipperAction = ZipperAction (Actionable ZipperStep)
  deriving
    ( -- | @since 1.3.0
      NonEmpty ZipperAction -> ZipperAction
ZipperAction -> ZipperAction -> ZipperAction
(ZipperAction -> ZipperAction -> ZipperAction)
-> (NonEmpty ZipperAction -> ZipperAction)
-> (forall b. Integral b => b -> ZipperAction -> ZipperAction)
-> Semigroup ZipperAction
forall b. Integral b => b -> ZipperAction -> ZipperAction
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: ZipperAction -> ZipperAction -> ZipperAction
<> :: ZipperAction -> ZipperAction -> ZipperAction
$csconcat :: NonEmpty ZipperAction -> ZipperAction
sconcat :: NonEmpty ZipperAction -> ZipperAction
$cstimes :: forall b. Integral b => b -> ZipperAction -> ZipperAction
stimes :: forall b. Integral b => b -> ZipperAction -> ZipperAction
Semigroup,
      -- | @since 1.3.0
      Semigroup ZipperAction
ZipperAction
Semigroup ZipperAction =>
ZipperAction
-> (ZipperAction -> ZipperAction -> ZipperAction)
-> ([ZipperAction] -> ZipperAction)
-> Monoid ZipperAction
[ZipperAction] -> ZipperAction
ZipperAction -> ZipperAction -> ZipperAction
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: ZipperAction
mempty :: ZipperAction
$cmappend :: ZipperAction -> ZipperAction -> ZipperAction
mappend :: ZipperAction -> ZipperAction -> ZipperAction
$cmconcat :: [ZipperAction] -> ZipperAction
mconcat :: [ZipperAction] -> ZipperAction
Monoid
    )
    via (Actionable ZipperStep)

-- | @since 1.3.0
instance Action ZipperAction where
  type StateOf ZipperAction = ZipperState
  act :: ZipperAction -> Endo (StateOf ZipperAction)
act (ZipperAction Actionable ZipperStep
acts) = (ZipperStep -> Endo ZipperState)
-> Actionable ZipperStep -> Endo ZipperState
forall m a. Monoid m => (a -> m) -> Actionable a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ZipperStep -> Endo ZipperState
go Actionable ZipperStep
acts
    where
      go :: ZipperStep -> Endo ZipperState
      go :: ZipperStep -> Endo ZipperState
go =
        (ZipperState -> ZipperState) -> Endo ZipperState
forall a. (a -> a) -> Endo a
Endo ((ZipperState -> ZipperState) -> Endo ZipperState)
-> (ZipperStep -> ZipperState -> ZipperState)
-> ZipperStep
-> Endo ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
          ZipperStep
ZipperDown -> ZipperState -> ZipperState
downStep
          ZipperStep
ZipperUp -> ZipperState -> ZipperState
upStep
          ZipperStep
ZipperLeft -> ZipperState -> ZipperState
leftStep
          ZipperStep
ZipperRight -> ZipperState -> ZipperState
rightStep
          ZipperStep
ZipperReset -> ZipperState -> ZipperState
resetStep

-- | Move towards the source of the ASG, \'back up\' along the path taken to
-- reach the current position. Will put the zipper in a broken state if used at
-- the source node.
--
-- @since 1.3.0
moveUp :: ZipperAction
moveUp :: ZipperAction
moveUp = Actionable ZipperStep -> ZipperAction
ZipperAction (Actionable ZipperStep -> ZipperAction)
-> (ZipperStep -> Actionable ZipperStep)
-> ZipperStep
-> ZipperAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZipperStep -> Actionable ZipperStep
forall a. a -> Actionable a
actionable (ZipperStep -> ZipperAction) -> ZipperStep -> ZipperAction
forall a b. (a -> b) -> a -> b
$ ZipperStep
ZipperUp

-- | Move to the leftmost child of the current position. Will put the zipper in
-- a broken state if used at a sink node.
--
-- @since 1.3.0
moveDown :: ZipperAction
moveDown :: ZipperAction
moveDown = Actionable ZipperStep -> ZipperAction
ZipperAction (Actionable ZipperStep -> ZipperAction)
-> (ZipperStep -> Actionable ZipperStep)
-> ZipperStep
-> ZipperAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZipperStep -> Actionable ZipperStep
forall a. a -> Actionable a
actionable (ZipperStep -> ZipperAction) -> ZipperStep -> ZipperAction
forall a b. (a -> b) -> a -> b
$ ZipperStep
ZipperDown

-- | Move to the sibling immediately to the left of the current position. Will
-- put the zipper in a broken state if used at a leftmost sibling.
--
-- @since 1.3.0
moveLeft :: ZipperAction
moveLeft :: ZipperAction
moveLeft = Actionable ZipperStep -> ZipperAction
ZipperAction (Actionable ZipperStep -> ZipperAction)
-> (ZipperStep -> Actionable ZipperStep)
-> ZipperStep
-> ZipperAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZipperStep -> Actionable ZipperStep
forall a. a -> Actionable a
actionable (ZipperStep -> ZipperAction) -> ZipperStep -> ZipperAction
forall a b. (a -> b) -> a -> b
$ ZipperStep
ZipperLeft

-- | Move to the sibling immediately to the right of the current position. Will
-- put the zipper in a broken state if used at a rightmost sibling.
--
-- @since 1.3.0
moveRight :: ZipperAction
moveRight :: ZipperAction
moveRight = Actionable ZipperStep -> ZipperAction
ZipperAction (Actionable ZipperStep -> ZipperAction)
-> (ZipperStep -> Actionable ZipperStep)
-> ZipperStep
-> ZipperAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZipperStep -> Actionable ZipperStep
forall a. a -> Actionable a
actionable (ZipperStep -> ZipperAction) -> ZipperStep -> ZipperAction
forall a b. (a -> b) -> a -> b
$ ZipperStep
ZipperRight

-- | If the zipper is currently in a broken state, reset it to the last position
-- it was at before breaking. Otherwise, this does nothing.
--
-- @since 1.3.0
resetZipper :: ZipperAction
resetZipper :: ZipperAction
resetZipper = Actionable ZipperStep -> ZipperAction
ZipperAction (Actionable ZipperStep -> ZipperAction)
-> (ZipperStep -> Actionable ZipperStep)
-> ZipperStep
-> ZipperAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZipperStep -> Actionable ZipperStep
forall a. a -> Actionable a
actionable (ZipperStep -> ZipperAction) -> ZipperStep -> ZipperAction
forall a b. (a -> b) -> a -> b
$ ZipperStep
ZipperReset

-- | A \'list with a focus\', which may be of a different type to the rest. The
-- first field is \'backwards\', in that its first element is actually the
-- /furthest/ from the focus. Thus, if we have @Tape [3, 2, 1] "foo" [4, 5]@,
-- the \'list\' actually looks like this:
--
-- @[1, 2, 3, "foo", 4, 5]@
--
-- but /not/ like this:
--
-- @[3, 2, 1, "foo", 4, 5]@
--
-- @since 1.3.0
data Tape a b = Tape [a] b [a]
  deriving stock
    ( -- | @since 1.3.0
      (forall a b. (a -> b) -> Tape a a -> Tape a b)
-> (forall a b. a -> Tape a b -> Tape a a) -> Functor (Tape a)
forall a b. a -> Tape a b -> Tape a a
forall a b. (a -> b) -> Tape a a -> Tape a b
forall a a b. a -> Tape a b -> Tape a a
forall a a b. (a -> b) -> Tape a a -> Tape a b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a a b. (a -> b) -> Tape a a -> Tape a b
fmap :: forall a b. (a -> b) -> Tape a a -> Tape a b
$c<$ :: forall a a b. a -> Tape a b -> Tape a a
<$ :: forall a b. a -> Tape a b -> Tape a a
Functor
    )

-- | The current state of the zipper, including whether it's in a broken state
-- or not, and if not in a broken state, the current position and the path taken
-- to get here.
--
-- @since 1.3.0
data ZipperState = ZipperState Bool ASG [Tape Ref Id] (Tape Ref Ref)

-- | Matches on a working zipper, giving access to a stack of 'Tape's
-- representing the path taken to get here (tracking sibling positions) and the
-- current position, with the focus at either an 'Arg' or an 'ASGNode'.
--
-- Parent positions use 'Id' for the focus, as 'Arg's cannot have descendants.
--
-- @since 1.3.0
pattern WorkingZipper :: [Tape Ref Id] -> Tape Ref (Either Arg (Id, ASGNode)) -> ZipperState
pattern $mWorkingZipper :: forall {r}.
ZipperState
-> ([Tape Ref Id] -> Tape Ref (Either Arg (Id, ASGNode)) -> r)
-> ((# #) -> r)
-> r
WorkingZipper parents curr <- ZipperState False g parents (getNodeInfo g -> curr)

-- | Matches on a zipper in a broken state.
--
-- @since 1.3.0
pattern BrokenZipper :: ZipperState
pattern $mBrokenZipper :: forall {r}. ZipperState -> ((# #) -> r) -> ((# #) -> r) -> r
BrokenZipper <- ZipperState True _ _ _

{-# COMPLETE WorkingZipper, BrokenZipper #-}

-- | A \'zipper command monad\', designed to traverse an ASG. Based on an action
-- monad.
--
-- To perform zipper moves, use 'Control.Monad.Action.send' together with a
-- 'ZipperAction'. If you want to find out something about where we're standing,
-- use 'Control.Monad.Action.request', together with pattern matching on
-- 'ZipperState'.
--
-- @since 1.3.0
newtype ASGZipper (a :: Type)
  = ASGZipper (UpdateT ZipperAction Identity a)
  deriving
    ( -- | @since 1.3.0
      (forall a b. (a -> b) -> ASGZipper a -> ASGZipper b)
-> (forall a b. a -> ASGZipper b -> ASGZipper a)
-> Functor ASGZipper
forall a b. a -> ASGZipper b -> ASGZipper a
forall a b. (a -> b) -> ASGZipper a -> ASGZipper b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ASGZipper a -> ASGZipper b
fmap :: forall a b. (a -> b) -> ASGZipper a -> ASGZipper b
$c<$ :: forall a b. a -> ASGZipper b -> ASGZipper a
<$ :: forall a b. a -> ASGZipper b -> ASGZipper a
Functor,
      -- | @since 1.3.0
      Functor ASGZipper
Functor ASGZipper =>
(forall a. a -> ASGZipper a)
-> (forall a b. ASGZipper (a -> b) -> ASGZipper a -> ASGZipper b)
-> (forall a b c.
    (a -> b -> c) -> ASGZipper a -> ASGZipper b -> ASGZipper c)
-> (forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b)
-> (forall a b. ASGZipper a -> ASGZipper b -> ASGZipper a)
-> Applicative ASGZipper
forall a. a -> ASGZipper a
forall a b. ASGZipper a -> ASGZipper b -> ASGZipper a
forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b
forall a b. ASGZipper (a -> b) -> ASGZipper a -> ASGZipper b
forall a b c.
(a -> b -> c) -> ASGZipper a -> ASGZipper b -> ASGZipper c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> ASGZipper a
pure :: forall a. a -> ASGZipper a
$c<*> :: forall a b. ASGZipper (a -> b) -> ASGZipper a -> ASGZipper b
<*> :: forall a b. ASGZipper (a -> b) -> ASGZipper a -> ASGZipper b
$cliftA2 :: forall a b c.
(a -> b -> c) -> ASGZipper a -> ASGZipper b -> ASGZipper c
liftA2 :: forall a b c.
(a -> b -> c) -> ASGZipper a -> ASGZipper b -> ASGZipper c
$c*> :: forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b
*> :: forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b
$c<* :: forall a b. ASGZipper a -> ASGZipper b -> ASGZipper a
<* :: forall a b. ASGZipper a -> ASGZipper b -> ASGZipper a
Applicative,
      -- | @since 1.3.0
      Applicative ASGZipper
Applicative ASGZipper =>
(forall a b. ASGZipper a -> (a -> ASGZipper b) -> ASGZipper b)
-> (forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b)
-> (forall a. a -> ASGZipper a)
-> Monad ASGZipper
forall a. a -> ASGZipper a
forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b
forall a b. ASGZipper a -> (a -> ASGZipper b) -> ASGZipper b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. ASGZipper a -> (a -> ASGZipper b) -> ASGZipper b
>>= :: forall a b. ASGZipper a -> (a -> ASGZipper b) -> ASGZipper b
$c>> :: forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b
>> :: forall a b. ASGZipper a -> ASGZipper b -> ASGZipper b
$creturn :: forall a. a -> ASGZipper a
return :: forall a. a -> ASGZipper a
Monad,
      -- | @since 1.3.0
      MonadUpdate ZipperAction
    )
    via (UpdateT ZipperAction Identity)

-- | Perform the stated actions to traverse over the 'ASG' given by the
-- argument.
--
-- @since 1.3.0
runASGZipper ::
  forall (a :: Type).
  ASG ->
  ASGZipper a ->
  a
runASGZipper :: forall a. ASG -> ASGZipper a -> a
runASGZipper ASG
g (ASGZipper UpdateT ZipperAction Identity a
comp) =
  let i :: Id
i = ASG -> Id
topLevelId ASG
g
   in (\(ZipperState
_, ZipperAction
_, a
x) -> a
x)
        ((ZipperState, ZipperAction, a) -> a)
-> ([Ref] -> (ZipperState, ZipperAction, a)) -> [Ref] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (ZipperState, ZipperAction, a)
-> (ZipperState, ZipperAction, a)
forall a. Identity a -> a
runIdentity
        (Identity (ZipperState, ZipperAction, a)
 -> (ZipperState, ZipperAction, a))
-> ([Ref] -> Identity (ZipperState, ZipperAction, a))
-> [Ref]
-> (ZipperState, ZipperAction, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateT ZipperAction Identity a
-> StateOf ZipperAction
-> Identity (StateOf ZipperAction, ZipperAction, a)
forall act (m :: Type -> Type) a.
(Functor m, Action act) =>
UpdateT act m a -> StateOf act -> m (StateOf act, act, a)
runUpdateT UpdateT ZipperAction Identity a
comp
        (ZipperState -> Identity (ZipperState, ZipperAction, a))
-> ([Ref] -> ZipperState)
-> [Ref]
-> Identity (ZipperState, ZipperAction, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
False ASG
g []
        (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] (Id -> Ref
AnId Id
i)
        ([Ref] -> a) -> [Ref] -> a
forall a b. (a -> b) -> a -> b
$ []

-- Helpers

data ZipperStep = ZipperDown | ZipperUp | ZipperLeft | ZipperRight | ZipperReset
  deriving stock (ZipperStep -> ZipperStep -> Bool
(ZipperStep -> ZipperStep -> Bool)
-> (ZipperStep -> ZipperStep -> Bool) -> Eq ZipperStep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZipperStep -> ZipperStep -> Bool
== :: ZipperStep -> ZipperStep -> Bool
$c/= :: ZipperStep -> ZipperStep -> Bool
/= :: ZipperStep -> ZipperStep -> Bool
Eq, Int -> ZipperStep -> ShowS
[ZipperStep] -> ShowS
ZipperStep -> String
(Int -> ZipperStep -> ShowS)
-> (ZipperStep -> String)
-> ([ZipperStep] -> ShowS)
-> Show ZipperStep
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ZipperStep -> ShowS
showsPrec :: Int -> ZipperStep -> ShowS
$cshow :: ZipperStep -> String
show :: ZipperStep -> String
$cshowList :: [ZipperStep] -> ShowS
showList :: [ZipperStep] -> ShowS
Show)

downStep :: ZipperState -> ZipperState
downStep :: ZipperState -> ZipperState
downStep zs :: ZipperState
zs@(ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel) =
  if Bool
walkedOff
    then ZipperState
zs
    else case Tape Ref Ref
currentLevel of
      Tape [Ref]
lefts Ref
curr [Ref]
rights ->
        let miss :: ZipperState
miss = Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
True ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel
         in case Ref
curr of
              AnArg Arg
_ -> ZipperState
miss
              AnId Id
i ->
                let next :: Tape Ref Ref -> ZipperState
next = Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
walkedOff ASG
g ([Ref] -> Id -> [Ref] -> Tape Ref Id
forall a b. [a] -> b -> [a] -> Tape a b
Tape [Ref]
lefts Id
i [Ref]
rights Tape Ref Id -> [Tape Ref Id] -> [Tape Ref Id]
forall a. a -> [a] -> [a]
: [Tape Ref Id]
parentLevels)
                 in case Id -> ASG -> ASGNode
nodeAt Id
i ASG
g of
                      ACompNode CompT AbstractTy
_ CompNodeInfo
info -> case CompNodeInfo
info of
                        Lam Ref
r -> Tape Ref Ref -> ZipperState
next (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] Ref
r ([Ref] -> ZipperState) -> [Ref] -> ZipperState
forall a b. (a -> b) -> a -> b
$ []
                        Force Ref
r -> Tape Ref Ref -> ZipperState
next (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] Ref
r ([Ref] -> ZipperState) -> [Ref] -> ZipperState
forall a b. (a -> b) -> a -> b
$ []
                        CompNodeInfo
_ -> ZipperState
miss
                      AValNode ValT AbstractTy
_ ValNodeInfo
info -> case ValNodeInfo
info of
                        App Id
f Vector Ref
args Vector (Wedge BoundTyVar (ValT Void))
_ -> Tape Ref Ref -> ZipperState
next (Tape Ref Ref -> ZipperState)
-> (Vector Ref -> Tape Ref Ref) -> Vector Ref -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] (Id -> Ref
AnId Id
f) ([Ref] -> Tape Ref Ref)
-> (Vector Ref -> [Ref]) -> Vector Ref -> Tape Ref Ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Ref -> [Item (Vector Ref)]
Vector Ref -> [Ref]
forall l. IsList l => l -> [Item l]
toList (Vector Ref -> ZipperState) -> Vector Ref -> ZipperState
forall a b. (a -> b) -> a -> b
$ Vector Ref
args
                        Thunk Id
f -> Tape Ref Ref -> ZipperState
next (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] (Id -> Ref
AnId Id
f) ([Ref] -> ZipperState) -> [Ref] -> ZipperState
forall a b. (a -> b) -> a -> b
$ []
                        Cata Ref
alg Ref
x -> Tape Ref Ref -> ZipperState
next (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] Ref
alg ([Ref] -> ZipperState) -> [Ref] -> ZipperState
forall a b. (a -> b) -> a -> b
$ [Ref
x]
                        DataConstructor TyName
_ ConstructorName
_ Vector Ref
args -> case Vector Ref
args of
                          Vector Ref
NilV -> ZipperState
miss
                          ConsV Ref
arg Vector Ref
args' -> Tape Ref Ref -> ZipperState
next (Tape Ref Ref -> ZipperState)
-> (Vector Ref -> Tape Ref Ref) -> Vector Ref -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] Ref
arg ([Ref] -> Tape Ref Ref)
-> (Vector Ref -> [Ref]) -> Vector Ref -> Tape Ref Ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Ref -> [Item (Vector Ref)]
Vector Ref -> [Ref]
forall l. IsList l => l -> [Item l]
toList (Vector Ref -> ZipperState) -> Vector Ref -> ZipperState
forall a b. (a -> b) -> a -> b
$ Vector Ref
args'
                        Match Ref
x Vector Ref
handlers -> Tape Ref Ref -> ZipperState
next (Tape Ref Ref -> ZipperState)
-> (Vector Ref -> Tape Ref Ref) -> Vector Ref -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [] Ref
x ([Ref] -> Tape Ref Ref)
-> (Vector Ref -> [Ref]) -> Vector Ref -> Tape Ref Ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Ref -> [Item (Vector Ref)]
Vector Ref -> [Ref]
forall l. IsList l => l -> [Item l]
toList (Vector Ref -> ZipperState) -> Vector Ref -> ZipperState
forall a b. (a -> b) -> a -> b
$ Vector Ref
handlers
                        ValNodeInfo
_ -> ZipperState
miss
                      ASGNode
AnError -> ZipperState
miss

upStep :: ZipperState -> ZipperState
upStep :: ZipperState -> ZipperState
upStep zs :: ZipperState
zs@(ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel) =
  if Bool
walkedOff
    then ZipperState
zs
    else case [Tape Ref Id]
parentLevels of
      [] -> Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
True ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel
      (Tape Ref Id
p : [Tape Ref Id]
ps) -> case Tape Ref Id
p of
        Tape [Ref]
lefts Id
curr [Ref]
rights -> Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
ps (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [Ref]
lefts (Id -> Ref
AnId Id
curr) ([Ref] -> ZipperState) -> [Ref] -> ZipperState
forall a b. (a -> b) -> a -> b
$ [Ref]
rights

leftStep :: ZipperState -> ZipperState
leftStep :: ZipperState -> ZipperState
leftStep zs :: ZipperState
zs@(ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel) =
  if Bool
walkedOff
    then ZipperState
zs
    else case Tape Ref Ref
currentLevel of
      Tape [Ref]
lefts Ref
curr [Ref]
rights -> case [Ref]
lefts of
        [] -> Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
True ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel
        (Ref
l : [Ref]
ls) -> Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
parentLevels (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape [Ref]
ls Ref
l ([Ref] -> ZipperState) -> [Ref] -> ZipperState
forall a b. (a -> b) -> a -> b
$ Ref
curr Ref -> [Ref] -> [Ref]
forall a. a -> [a] -> [a]
: [Ref]
rights

rightStep :: ZipperState -> ZipperState
rightStep :: ZipperState -> ZipperState
rightStep zs :: ZipperState
zs@(ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel) =
  if Bool
walkedOff
    then ZipperState
zs
    else case Tape Ref Ref
currentLevel of
      Tape [Ref]
lefts Ref
curr [Ref]
rights -> case [Ref]
rights of
        [] -> Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
True ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel
        (Ref
r : [Ref]
rs) -> Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
parentLevels (Tape Ref Ref -> ZipperState)
-> ([Ref] -> Tape Ref Ref) -> [Ref] -> ZipperState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ref] -> Ref -> [Ref] -> Tape Ref Ref
forall a b. [a] -> b -> [a] -> Tape a b
Tape (Ref
curr Ref -> [Ref] -> [Ref]
forall a. a -> [a] -> [a]
: [Ref]
lefts) Ref
r ([Ref] -> ZipperState) -> [Ref] -> ZipperState
forall a b. (a -> b) -> a -> b
$ [Ref]
rs

resetStep :: ZipperState -> ZipperState
resetStep :: ZipperState -> ZipperState
resetStep zs :: ZipperState
zs@(ZipperState Bool
walkedOff ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel) =
  if Bool
walkedOff
    then Bool -> ASG -> [Tape Ref Id] -> Tape Ref Ref -> ZipperState
ZipperState Bool
False ASG
g [Tape Ref Id]
parentLevels Tape Ref Ref
currentLevel
    else ZipperState
zs

getNodeInfo :: ASG -> Tape Ref Ref -> Tape Ref (Either Arg (Id, ASGNode))
getNodeInfo :: ASG -> Tape Ref Ref -> Tape Ref (Either Arg (Id, ASGNode))
getNodeInfo ASG
g =
  (Ref -> Either Arg (Id, ASGNode))
-> Tape Ref Ref -> Tape Ref (Either Arg (Id, ASGNode))
forall a b. (a -> b) -> Tape Ref a -> Tape Ref b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \case
        AnId Id
i -> (Id, ASGNode) -> Either Arg (Id, ASGNode)
forall a b. b -> Either a b
Right (Id
i, Id -> ASG -> ASGNode
nodeAt Id
i ASG
g)
        AnArg Arg
arg -> Arg -> Either Arg (Id, ASGNode)
forall a b. a -> Either a b
Left Arg
arg
    )