Improve multimonitor and clean code

I found a bug in the code that set the active screen from your mouse
location. I'm not sure it ever worked...

Also, I broke up the Standard.hs file into smaller files.

src/Actions/Actions.hs

@@ -278,7 +278,7 @@ killActive = do
 
   -- We use the Beam data type to get the window at the end of
   -- the tree if it exists.
-  let window = extract $ ana @(Beam _) makeList root
+  let window = hylo getEnd makeList root
   -- TODO This seems convoluted and should be simplified...
   l <- case window of
     Just (parent, child) -> do

src/Base/DoAll.hs

@@ -84,6 +84,8 @@ type From name = ReaderIORef ((Rename name (Field name () (MonadReader M))))
 type FromInput name = Rename name (Field name () (MonadReader M))
 type ShouldRedraw = Maybe ()
 
+-- TODO Having to type out Input, Output, and State makes this code
+-- significantly noisier than it needs to be.
 newtype M a = M { runM :: R.ReaderT Ctx IO a }
   deriving (Functor, Applicative, Monad, MonadIO, R.MonadReader Ctx)
   deriving (Input Mode, Output Mode, State Mode) via (Logged "activeMode" Mode)
@@ -117,12 +119,8 @@ newtype M a = M { runM :: R.ReaderT Ctx IO a }
   deriving (Input Font.Font) via (FromInput "fontChoice")
   deriving (Input XCursor) via (FromInput "cursor")
   deriving (Log LogData) via (Logger M)
+  deriving (Semigroup, Monoid) via Ap M a
 
-instance Semigroup a => Semigroup (M a) where
-  a <> b = liftM2 (<>) a b
-
-instance Monoid a => Monoid (M a) where
-  mempty = return mempty
 
 type LostWindow = Map Window [ParentChild]
 

src/Core.hs

@@ -294,7 +294,7 @@ xFocus
 xFocus = do
   root <- get @Tiler
   rWin <- input @Window
-  let w = fromMaybe (ParentChild rWin rWin) $ extract $ ana @(Beam _) makeList root
+  let w = fromMaybe (ParentChild rWin rWin) $ hylo getEnd makeList root
   setFocus w
  where
   makeList (Wrap pc)              = EndF $ Just pc
@@ -369,7 +369,7 @@ writeActiveWindow = do
   root <- input
   tilers <- gets @Tiler Fix
   naw <- getAtom False "_NET_ACTIVE_WINDOW"
-  putProperty 32 naw root wINDOW [fromMaybe (fromIntegral root) . extract $ ana @(Beam _) makeList tilers]
+  putProperty 32 naw root wINDOW [fromMaybe (fromIntegral root) $ hylo getEnd makeList tilers]
     where makeList (Fix (Wrap (ParentChild _ w))) = EndF . Just $ fromIntegral w
           makeList (Fix (InputControllerOrMonitor _ (Just t))) = ContinueF t
           makeList (Fix (InputControllerOrMonitor _ Nothing)) = EndF Nothing

src/Standard.hs

@@ -1,41 +1,16 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ConstraintKinds #-}
 
+-- |This module (and the ones in Standard/*) are all part of my custom prelude.
+-- All of it is super adhoc but makes things either more "pure" or fixes little
+-- annoyances. Many of these changes assume that breaking convention has no
+-- cost. As a result, there are probably some contraversial changes in here.
 module Standard
     ( module All
     , modify
-    , Beam (..)
-    , BeamF (..)
-    , Path (..)
-    , PathF (..)
-    , journey
-    , Stream (..)
-    , filterStream
-    , repeatStream
-    , overStream
     , pattern CofreeF
     , pattern Cofree
-    , RectA(..)
-    , Rect
-    , XRect
-    , Transformation(..)
-    , toScreenCoord
-    , getStartingPoint
     , trd
     , fromEither
     , map
@@ -50,14 +25,17 @@ module Standard
     , remove
     , error
     , pattern Text
-    , Tagged (..)
     ) where
 
 import BasePrelude as All hiding (gunfold, log, tail, head, init, last, fmap, map, show, lazy, arr, uncons, index, String, error, left, right, appendFile, getContents, getLine, interact, putStrLn, putStr, readFile, writeFile, filter, (!!), unlines)
-import Data.IORef
+import Standard.Beam as All
+import Standard.RectA as All
+import Standard.Stream as All
+import Standard.Tagged as All
+import Standard.Transformation as All
+
 import qualified BasePrelude
 import Base.Effects as All
-import Control.Monad.Trans.Maybe
 import Data.Text as All (Text, unlines)
 import Data.Text.IO as All
 import Data.List.NonEmpty as All (filter, nonEmpty, (!!), (<|), tail, init)
@@ -75,25 +53,14 @@ import qualified Control.Comonad.Cofree as CC (Cofree((:<)))
 import Control.Comonad as All hiding (fmap)
 import qualified Control.Comonad.Trans.Cofree as C hiding (Cofree)
 import Data.Functor.Foldable as All hiding (fold, unfold, embed)
-import Data.Kind (Type, Constraint)
+import Data.Kind (Type)
 import Data.Functor.Foldable.TH as All
-import Data.Bifunctor.TH
 import Control.Lens as All hiding (para, none, (<|))
-import Control.Monad.Reader
-import GHC.TypeLits hiding (Text)
-import Control.Monad.State.Strict (StateT(runStateT))
 import Capability.State as All hiding (zoom, modify)
 import Capability.Sink as All hiding (yield)
 import Capability.Source as All
 import Data.Semigroup.Foldable as All
 
--- instance 
--- runInputIO :: IO i 
--- instance MonadIO newM => Input (IO i) (MonadIO) newM i m a where
---   reduce ioAction m = liftIO ioAction >>
-
--- TODO I can probably split out a lot of these functions into other places...
-
 {-# COMPLETE CofreeF #-}
 pattern CofreeF :: forall (f :: Type -> Type) a b. a -> f b -> C.CofreeF f a b
 pattern CofreeF a b = a C.:< b
@@ -102,117 +69,7 @@ pattern CofreeF a b = a C.:< b
 pattern Cofree :: forall (f :: Type -> Type) a. a -> f (CC.Cofree f a) -> CC.Cofree f a
 pattern Cofree a b = a CC.:< b
 
--- |A rectangle with any kind of dimension you could every want.
-data RectA a b = Rect { x :: a
-                      , y :: a
-                      , w :: b
-                      , h :: b
-                      }
-  deriving (Show, Eq)
-deriveBifunctor ''RectA
-
--- |A rectangle over Doubles. This is usually what people think of
--- when you say rectangle.
-type Rect = RectA Double Double
-
--- |A rectangle according to X11.
-type XRect = RectA Int32 Word32
-
--- There must be some way to get the Compiler to make this one...
-instance (Num n, Num m) => Semigroup (RectA n m) where
-  Rect a1 a2 a3 a4 <> Rect b1 b2 b3 b4 = Rect (a1 + b1) (a2 + b2) (a3 + b3) (a4 + b4)
-
--- And this one as well...
-instance (Num n, Num m) => Monoid (RectA n m) where
-  mempty = Rect 0 0 0 0
-
--- |Some transformations you might want to make to a rectangle.
--- Instead of just doing the transformation with something like:
---
--- "slide :: Rect -> Rect -> Rect"
---
--- we create a list of transformations and wait to apply them until the
--- last moment. This lets our drawing functions inspect how they're going
--- to be transformed.
-data Transformation = Slide Rect Transformation | Spin Transformation | StartingPoint XRect
-  deriving (Eq, Show)
-
-makeBaseFunctor ''Transformation
-
--- |Actually does the computations to create a new rectangle.
-toScreenCoord :: Transformation -> XRect
-toScreenCoord = bimap floor ceiling . snd . cata \case
-  SlideF (Rect dx dy dw dh) (False, Rect {..}) ->
-    (False, Rect (x + dx * w) (y + dy * h) (w * dw) (h * dh))
-  SlideF (Rect dx dy dw dh) (True, Rect {..}) ->
-    (False, Rect (x + dy * w) (y + dx * h) (w * dh) (h * dw))
-  SpinF (_, Rect {..}) -> (True, Rect x y w h)
-  StartingPointF r -> (False, bimap fromIntegral fromIntegral r)
-
--- |Extracts the original untransformed rectangle.
-getStartingPoint :: Transformation -> XRect
-getStartingPoint = cata $ \case
-  StartingPointF r -> r
-  SpinF r -> r
-  SlideF _ r -> r
-
-
--- |You can think of a beam as the opposite of a list. instead of having
--- 0 or more elements and a guaranteed empty case, Beam has 0 or more
--- empty cases and a guaranteed element wrapped inside.
---
--- You might be thinking, "This looks completely useluss!" and if we think of
--- it as a normal container (like array, tree, list, etc.) then you would
--- probably be right. If you think of Beam not as a container but as control
--- flow, you get some cool results though. Imagine wanting to find the smallest
--- element in a tree. Instead of doing it recursively, you can use a
--- hylomorphism to abstract away the recursion. At this point though, you need
--- to pick a data type for F wich will wrap the intermediate result.  What do
--- you pick? Well Beam makes a great choice. For each recursive call, you just
--- return Continue. Once you reach the leaf, you return End. Then, you can use
--- a simple catamorphism to extract the value from the beam.
-data Beam a = End a | Continue (Beam a)
-  deriving (Eq, Show, Functor)
-
-makeBaseFunctor ''Beam
 
--- TBH I only really wanted this for the extract function. I think it follows
--- all of the laws but don't quote me on that...
-instance Comonad Beam where
-  extract = cata getEnd
-    where getEnd (EndF a)      = a
-          getEnd (ContinueF a) = a
-  duplicate = End
-
--- Path looks a lot like Beam and List combined. Not only do you have some
--- finish value, you also have intermediate ones you can store. Path uses a fun
--- travelling metaphor to explain its constructors.
-data Path a b = Finish a | Road (Path a b) | Break b (Path a b)
-  deriving (Eq, Show, Functor)
-
-makeBaseFunctor ''Path
-
--- |Turn a Path into a list of stops and a final destination.
-journey :: Path a b -> ([b], a)
-journey = cata step
-  where step (FinishF a) = ([], a)
-        step (BreakF b (bs, a)) = (b:bs, a)
-        step (RoadF result) = result
-
-
-data Stream m a = Stream a (m (Stream m a))
-  -- deriving (Functor, Foldable, Traversable)
-
-filterStream :: Monad m => (a -> Bool) -> Stream m a -> m (Stream m a)
-filterStream p (Stream a m)
-  | p a = return $ Stream a (filterStream p =<< m)
-  | otherwise = filterStream p =<< m
-
-repeatStream :: Functor m => m a -> m (Stream m a)
-repeatStream m = fmap (\a -> Stream a $ repeatStream m) m
-
-overStream :: Monad m => (a -> m b) -> Stream m a -> m c
-overStream f (Stream a m) = f a >> m >>= overStream f
 
 -- |Like fst and snd but for the third element.
 trd :: (a, b, c) -> c
@@ -222,9 +79,11 @@ fromEither :: Either a a -> a
 fromEither (Left a) = a
 fromEither (Right a) = a
 
+-- |The f in fmap seems to be historical baggage.
 map :: Functor f => (a -> b) -> (f a -> f b)
 map = BP.fmap
 
+-- TODO replace this with a real Text alternative that doesn't create a String.
 show :: Show a => a -> Text
 show = Text . BasePrelude.show
 
@@ -237,7 +96,7 @@ head = view head1
 tailMay :: Cons s s a a => s -> Maybe s
 tailMay = preview _tail
 
--- TODO There must ba a typeclass for this...
+-- TODO Given the amount of symmetry here, I'm amazed this one has stumped me.
 -- tail :: Traversable1 t => NonEmpty a -> Maybe (NonEmpty a)
 
 lastMay :: Snoc s s a a => s -> Maybe a
@@ -249,6 +108,8 @@ last = view last1
 initMay :: Snoc s s a a => s -> Maybe s
 initMay = preview _init
 
+-- TODO Symmetry reveals itself again. Since tail was really hard to write,
+-- init is too.
 -- init :: Traversable1 t => t a -> Maybe (t a)
 
 removeAt :: Int -> NonEmpty a -> Maybe (NonEmpty a)
@@ -268,23 +129,3 @@ pattern Text a <- (view _Text -> a) where
 
 modify :: forall a m. HasState a a m => (a -> a) -> m ()
 modify = modify' @a
-
--- TODO This feels like something there should be a library for
-data Tagged a = Failed a | Succeeded a
-  deriving (Show, Eq, Read, Functor, Foldable, Traversable)
-
-instance Semigroup (Tagged a) where
-  Failed _ <> a = a
-  a <> _ = a
-
-instance Applicative Tagged where
-  pure a = Failed a
-  Succeeded f <*> ta = Succeeded $ f $ extract ta
-  Failed f <*> ta = fmap f ta
-
-instance Comonad Tagged where
-  extract (Failed a) = a
-  extract (Succeeded a) = a
-
-  duplicate (Failed a) = Failed $ Failed a
-  duplicate (Succeeded a) = Succeeded $ Succeeded a

src/Standard/Beam.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Standard.Beam where
+
+import Data.Functor.Foldable.TH
+import BasePrelude
+
+-- |You can think of a beam as the opposite of a list. instead of having
+-- 0 or more elements and a guaranteed empty case, Beam has 0 or more
+-- empty cases and a guaranteed element wrapped inside.
+--
+-- You might be thinking, "This looks completely useluss!" and if we think of
+-- it as a normal container (like array, tree, list, etc.) then you would
+-- probably be right. If you think of Beam not as a container but as control
+-- flow, you get some cool results though. For an example, look at onInput .
+-- Instead of doing it recursively, you can use a hylomorphism to abstract away
+-- the recursion. At this point though, you need to pick a data type for F wich
+-- will wrap the intermediate result.  What do you pick? Well Beam makes a
+-- great choice. For each recursive call, you just return Continue. Once you
+-- reach the leaf, you return End. Then, you can use a simple catamorphism to
+-- extract the value from the beam.
+data Beam a = End a | Continue (Beam a)
+  deriving (Eq, Show, Functor)
+
+makeBaseFunctor ''Beam
+
+getEnd :: BeamF a a -> a
+getEnd (EndF a)      = a
+getEnd (ContinueF a) = a

src/Standard/RectA.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Standard.RectA where
+
+import Data.Bifunctor.TH
+import BasePrelude
+
+-- |A rectangle with any kind of dimension you could every want. The A stands
+-- for abstract. You probably want one of the type synonyms below.
+data RectA a b = Rect { x :: a
+                      , y :: a
+                      , w :: b
+                      , h :: b
+                      }
+  deriving (Show, Eq)
+deriveBifunctor ''RectA
+
+-- |A rectangle over Doubles. This is usually what people think of
+-- when you say rectangle.
+type Rect = RectA Double Double
+
+-- |A rectangle according to X11.
+type XRect = RectA Int32 Word32
+
+-- TODO There must be some way to get the Compiler to make this one...
+instance (Num n, Num m) => Semigroup (RectA n m) where
+  Rect a1 a2 a3 a4 <> Rect b1 b2 b3 b4 = Rect (a1 + b1) (a2 + b2) (a3 + b3) (a4 + b4)
+
+-- And this one as well...
+instance (Num n, Num m) => Monoid (RectA n m) where
+  mempty = Rect 0 0 0 0

src/Standard/Stream.hs

@@ -0,0 +1,20 @@
+module Standard.Stream where
+
+import BasePrelude
+
+-- |This stream lets me return an infinite list of values where each value
+-- comes from some monadic computation. To understand why I need this, consider
+-- implementing filterStream on something of type [m a] where filterStream
+-- remains lazy.
+data Stream m a = Stream a (m (Stream m a))
+
+filterStream :: Monad m => (a -> Bool) -> Stream m a -> m (Stream m a)
+filterStream p (Stream a m)
+  | p a = return $ Stream a (filterStream p =<< m)
+  | otherwise = filterStream p =<< m
+
+repeatStream :: Functor m => m a -> m (Stream m a)
+repeatStream m = fmap (\a -> Stream a $ repeatStream m) m
+
+overStream :: Monad m => (a -> m b) -> Stream m a -> m c
+overStream f (Stream a m) = f a >> m >>= overStream f