Generic Paths in Purescript

GenericPath.purs

--------------------------------------------------------------------------------
-- Tree
--------------------------------------------------------------------------------
data Tree a
  = Tree a (Array (Tree a))

instance functorTree :: Functor Tree where
  map f (Tree a ts) = Tree (f a) (map f <$> ts)

instance applyTree :: Apply Tree where
  apply (Tree f fts) (Tree a ats) = Tree (f a) (map (uncurry apply) (fts `zip` ats))

instance applicativeTree :: Applicative Tree where
  pure a = Tree a []

instance foldableTree :: Foldable Tree where
  foldr = unsafeThrow "TODO"
  foldl = unsafeThrow "TODO"
  foldMap = unsafeThrow "TODO"

instance traversableTree :: Traversable Tree where
  traverse f (Tree a ts) = Tree <$> f a <*> sequence (map (traverse f) ts)
  sequence (Tree a ts) = Tree <$> a <*> sequence (map sequence ts)

--------------------------------------------------------------------------------
-- Treelike
--------------------------------------------------------------------------------
class Treelike a b | a -> b where
  toTree :: a -> Tree b
  fromTree' :: Tree b -> Maybe a

instance treelikeTree :: Treelike (Tree a) a where
  toTree = identity
  fromTree' = Just

instance treelikeSum :: (Treelike a1 t1, Treelike a2 t2) => Treelike (Sum a1 a2) (Either3 (Either Unit Unit) t1 t2) where
  toTree (Inl a1) = Tree (in1 (Left unit)) [ in2 <$> toTree a1 ]
  toTree (Inr a2) = Tree (in1 (Right unit)) [ in3 <$> toTree a2 ]
  fromTree' = case _ of
    Tree (Left (Left _)) [ t1 ] -> Inl <$> (fromTree' =<< traverse fromT1 t1)
    Tree (Left (Right _)) [ t2 ] -> Inr <$> (fromTree' =<< traverse fromT2 t2)
    _ -> Nothing
    where
    fromT1 :: Either3 (Either Unit Unit) t1 t2 -> Maybe t1
    fromT1 = case _ of
      Right (Left t1) -> Just t1
      _ -> Nothing

    fromT2 :: Either3 (Either Unit Unit) t1 t2 -> Maybe t2
    fromT2 = case _ of
      Right (Right (Left t2)) -> Just t2
      _ -> Nothing

instance treelikeProduct :: (Treelike a1 t1, Treelike a2 t2) => Treelike (Product a1 a2) (Either3 Unit t1 t2) where
  toTree (Product a1 a2) = Tree (Left unit) [ in2 <$> toTree a1, in3 <$> toTree a2 ]
  fromTree' = case _ of
    Tree (Left _) [ t1, t2 ] -> Product <$> (fromTree' =<< traverse fromT1 t1) <*> (fromTree' =<< traverse fromT2 t2)
    _ -> Nothing
    where
    fromT1 :: Either3 Unit t1 t2 -> Maybe t1
    fromT1 = case _ of
      Right (Left t1) -> Just t1
      _ -> Nothing

    fromT2 :: Either3 Unit t1 t2 -> Maybe t2
    fromT2 = case _ of
      Right (Right (Left t2)) -> Just t2
      _ -> Nothing

instance treelikeConstructor :: Treelike a t => Treelike (Constructor name a) (Either (Proxy name) t) where
  toTree (Constructor a) = Tree (Left Proxy) [ Right <$> toTree a ]
  fromTree' = case _ of
    Tree (Left Proxy) [ t ] -> Constructor <$> (fromTree' =<< traverse fromT t)
    _ -> Nothing
    where
    fromT = case _ of
      Right t -> Just t
      _ -> Nothing

instance treelikeArgument :: Treelike a t => Treelike (Argument a) (Either (Proxy "Argument") t) where
  toTree (Argument a) = Tree (Left Proxy) [ Right <$> toTree a ]
  fromTree' = case _ of
    Tree (Left Proxy) [ t ] -> Argument <$> (fromTree' =<< traverse fromT t)
    _ -> Nothing
    where
    fromT = case _ of
      Right t -> Just t
      _ -> Nothing

--------------------------------------------------------------------------------
-- Path
--------------------------------------------------------------------------------
-- before, head, after
data Step a
  = Step { val :: a, before :: Array (Tree a), after :: Array (Tree a) }

type Path a
  = Array (Step a)

type Loc a
  = { path :: Path a, tree :: Tree a }

cutAt :: forall a. Int -> Array a -> Maybe { before :: Array a, head :: a, after :: Array a }
cutAt i as = do
  let
    { after, before } = Array.splitAt i as
  { head, tail } <- Array.uncons after
  pure { before, head, after: tail }

stepDown :: forall a. Int -> Loc a -> Maybe (Loc a)
stepDown i { path, tree: Tree val ts } = do
  { before, head: tree, after } <- cutAt i ts
  pure { path: Step { val, before, after } : path, tree }

stepUp :: forall a. Loc a -> Maybe (Loc a)
stepUp { path, tree } = do
  { head: step, tail: path' } <- Array.uncons path
  pure { path: path', tree: unstep step tree }

stepLeft :: forall a. Loc a -> Maybe (Loc a)
stepLeft { path, tree } = do
  { head: Step { val, before, after }, tail: path' } <- Array.uncons path
  { head: tree', tail: before' } <- Array.uncons before
  pure { path: Step { val, before: before', after: tree : after } : path', tree: tree' }

stepRight :: forall a. Loc a -> Maybe (Loc a)
stepRight { path, tree } = do
  { head: Step { val, before, after }, tail: path' } <- Array.uncons path
  { head: tree', tail: after' } <- Array.uncons after
  pure { path: Step { val, before: tree : before, after: after' } : path', tree: tree' }

unstep :: forall a. Step a -> Tree a -> Tree a
unstep (Step { val, before, after }) tree = Tree val (before <> [ tree ] <> after)