From b9db9f8d7f3eb993ed345357c428a94c9a208c5b Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 23 Nov 2017 20:29:33 +0100
Subject: Start on container edits

---
 edit-lens/package.yaml                   |  5 ++-
 edit-lens/src/Control/Edit.lhs           | 10 ++---
 edit-lens/src/Control/Edit/Container.lhs | 74 ++++++++++++++++++++++++++++++++
 edit-lens/src/Control/Edit/Tree.lhs      |  9 ----
 4 files changed, 82 insertions(+), 16 deletions(-)
 create mode 100644 edit-lens/src/Control/Edit/Container.lhs
 delete mode 100644 edit-lens/src/Control/Edit/Tree.lhs

diff --git a/edit-lens/package.yaml b/edit-lens/package.yaml
index db1f021..5737fb4 100644
--- a/edit-lens/package.yaml
+++ b/edit-lens/package.yaml
@@ -19,12 +19,15 @@ library:
     - AllowAmbiguousTypes
     - TypeApplications
     - GADTs
+    - TupleSections
+    - ScopedTypeVariables
   source-dirs: src
   dependencies:
     - base
     - lens
+    - containers
   exposed-modules:
     - Control.Edit
-    - Control.Edit.Tree
+    - Control.Edit.Container
     - Control.Lens.Edit
   
diff --git a/edit-lens/src/Control/Edit.lhs b/edit-lens/src/Control/Edit.lhs
index 7be8db4..11f2c12 100644
--- a/edit-lens/src/Control/Edit.lhs
+++ b/edit-lens/src/Control/Edit.lhs
@@ -2,6 +2,7 @@
 \begin{code}
 module Control.Edit
   ( Module(..) 
+  , ModuleHom
   ) where
 \end{code}
 \end{comment}
@@ -26,12 +27,12 @@ Eine Repräsentierung als Typklasse bietet sich an:
 \begin{code}
 class Monoid m => Module m where
   type Domain m :: *
-  apply :: Domain m -> m -> Maybe (Domain m)
+  apply :: m -> Domain m -> Maybe (Domain m)
   -- ^ A partial monoid-action of `m` on `Domain m`
   --
   -- prop> m `apply` mempty = m
   -- prop> m `apply` (e `mappend` e') = (m `apply` e) `apply` e'
-  init :: Domain m
+  initial :: Domain m
   -- ^ 'init @m' (TypeApplication) is the initial element of 'm'
   divInit :: Domain m -> m
   -- ^ Calculate a representation of an element of 'Domain m' in 'Del m'
@@ -42,7 +43,6 @@ class Monoid m => Module m where
 
 Wir weichen von der originalen Definition von Moduln aus \cite{hofmann2012edit} darin ab, dass wir für das ausgezeichnete Element $\init_X$ des Trägers explizit (und konstruktiv) fordern, dass es ein schwach-initiales Element bzgl. der Monoidwirkung sei.
 
-\begin{comment}
 \begin{defn}[Modulhomomorphismen]
 Unter einem Modulhomomorphismus zwischen Moduln $M$ und $M^\prime$ verstehen wir ein Paar $(f, \phi$) bestehend aus Abbildungen $f \colon \Dom M \to \Dom M^\prime$ und $\phi \colon \partial M \to \partial M^\prime$, sodass gilt:
 \begin{itemize}
@@ -61,11 +61,9 @@ Unter einem Modulhomomorphismus zwischen Moduln $M$ und $M^\prime$ verstehen wir
 \end{itemize}
 
 \begin{code}
-{-
+-- | A homomorphism between 'Module's
 data ModuleHom m n where
   ModuleHom :: (Module m, Module n) => (Domain m -> Domain n) -> (m -> n) -> ModuleHom m n
--}
 \end{code}
 \end{defn}
-\end{comment}
 
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}
diff --git a/edit-lens/src/Control/Edit/Tree.lhs b/edit-lens/src/Control/Edit/Tree.lhs
deleted file mode 100644
index 28320c5..0000000
--- a/edit-lens/src/Control/Edit/Tree.lhs
+++ /dev/null
@@ -1,9 +0,0 @@
-\begin{comment}
-\begin{code}
-module Control.Edit.Tree
-  (
-  ) where
-
-import Control.Edit
-\end{code}
-\end{comment}
-- 
cgit v1.2.3