Start on container edits

1 files changed, 74 insertions, 0 deletions

diff --git a/edit-lens/src/Control/Edit/Container.lhs b/edit-lens/src/Control/Edit/Container.lhs
new file mode 100644
index 0000000..7d0d57c
--- /dev/null
+++ b/edit-lens/src/Control/Edit/Container.lhs
@@ -0,0 +1,74 @@
+\begin{comment}
+\begin{code}
+module Control.Edit.Container
+  ( Container(..), Shape, Content
+  , ContainerEdit(..)
+  ) where
+
+import Control.Edit
+import Data.Set (Set)
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import Control.Monad
+
+import Control.Lens
+\end{code}
+\end{comment}
+
+\begin{defn}[Container]
+\begin{code}
+class ( Module (ModShape c)
+      , Module (ModContent c)
+      , Ord (Position c)
+      ) => Container c where
+  type ModShape c :: *
+  type Position c :: *
+  type ModContent c :: *
+  positions :: Shape c -> Set (Position c)
+  deconstructed :: Iso' c (Shape c, Position c -> Content c) 
+
+constructed :: Container c => Iso' (Shape c, Position c -> Content c) c
+constructed = from deconstructed
+
+type Shape c = Domain (ModShape c)
+type Content c = Domain (ModContent c)
+\end{code}
+\end{defn}
+
+\begin{defn}[container-edits]
+\begin{code}
+data ContainerEdit c where
+  Fail       :: ContainerEdit c
+  ModContent :: Position c -> ModContent c -> ContainerEdit c
+  ModShape   :: ModShape c -> (Shape c -> Position c -> Position c) -> ContainerEdit c
+\end{code}
+\end{defn}
+
+\begin{defn}[Wirkung von container-edits]
+\begin{code}
+instance Container c => Module (Seq (ContainerEdit c)) where
+  type Domain (Seq (ContainerEdit c)) = c
+  apply fs = over mapped (view constructed) . flip (foldM apply') fs . view deconstructed
+    where
+      apply' :: Container c
+             => (Shape c, Position c -> Content c)
+             -> ContainerEdit c
+             -> Maybe (Shape c, Position c -> Content c)
+      apply' _       Fail = Nothing
+      apply' (s, cf) (ModContent p dc) = do
+        c' <- dc `apply` cf p
+        let cf' x
+              | x == p    = c'
+              | otherwise = cf x
+        return (s, cf')
+      apply' (s, cf) (ModShape ds dcf) = (, cf . dcf s) <$> ds `apply` s
+  initial = view constructed (initial @(ModShape c), \_ -> initial @(ModContent c))
+  divInit x =
+    let
+      x'@(s, cf) = x ^. deconstructed
+      (ds, dcf) = over _1 divInit $ over (_2.mapped) divInit x'
+    in
+      foldMap (\p -> Seq.singleton . ModContent p $ dcf p) (positions @c s) |> (ModShape ds $ const id)
+\end{code}
+\end{defn}