[refactor] Wetterhorn -> Montis

1 files changed, 48 insertions, 0 deletions

diff --git a/plug/src/Montis/Layout/Combine.hs b/plug/src/Montis/Layout/Combine.hs
new file mode 100644
index 0000000..7563876
--- /dev/null
+++ b/plug/src/Montis/Layout/Combine.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Montis.Layout.Combine where
+
+import Data.Typeable
+import Montis.Constraints
+import Montis.Core.W
+
+data (|||) a b = Comb LR a b
+  deriving (Typeable, Read, Show)
+
+data Next = Next
+  deriving (Typeable)
+
+data Reset = Reset
+  deriving (Typeable)
+
+(|||) :: a -> b -> (a ||| b)
+a ||| b = Comb L a b
+
+data LR = L | R deriving (Read, Show, Ord, Eq, Enum)
+
+instance (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where
+  handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r)
+  handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r)
+  handleMessage mesg (Comb L l r) =
+    Comb L <$> handleMessage mesg l <*> pure r
+  handleMessage mesg (Comb R l r) =
+    Comb L l <$> handleMessage mesg r
+
+instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
+  -- In order to use this layout class, the lay-out type 'a' must satisfy BOTH
+  -- the left and right constraints.
+  type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint b
+
+  runLayout as (Comb R r l) = do
+    (r', ret) <- runLayout as r
+    return (Comb R r' l, ret)
+  runLayout as (Comb L r l) = do
+    (l', ret) <- runLayout as l
+    return (Comb R r l', ret)
+
+  serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r))
+  readLayout str = Comb lr <$> l <*> r
+    where
+      (Comb lr (readLayout -> l) (readLayout -> r)) = read str
+
+  description (Comb _ l r) = description l ++ " ||| " ++ description r