Sequenceable.hs

{-# language DeriveFunctor #-}
{-# language FlexibleInstances #-}
{-# language FlexibleContexts #-}
module Rasa.Ext.Views.Internal.CoTree where

import Data.List as L

class Monoid g => Group g where
  identity :: g
  identity = mempty

  (|+|) :: g -> g -> g
  (|+|) = mappend

  invert :: g -> g

class (Group r) => Ring r where
  (|*|) :: r -> r -> r

class Ring r => DivRing r where
  divide :: r -> r -> r

data Cmd =
  Mv FilePath FilePath
  | Rm FilePath
  | Restore FilePath
  deriving (Show, Eq)

data Sequenceable a =
    Sequential [Sequenceable a]
  | Concurrent [Sequenceable a]
  | Single a
  deriving (Show, Eq, Functor)

instance Applicative Sequenceable where
  pure = Single
  Single f <*> a = fmap f a
  Sequential xs <*> y = Sequential $ fmap (<*> y) xs
  Concurrent xs <*> y = Concurrent $ fmap (<*> y) xs

instance Monad Sequenceable where
  Single a >>= f = f a
  Sequential xs >>= f = Sequential ((>>= f) <$> xs)
  Concurrent xs >>= f = Concurrent ((>>= f) <$> xs)

instance Monoid (Sequenceable a) where
  mempty = Concurrent []
  Concurrent [] `mappend` y = y
  x `mappend` Concurrent [] = x

  Concurrent xs `mappend` Concurrent ys = Concurrent (xs ++ ys)

  Single x `mappend` Concurrent ys = Concurrent (Single x:ys)
  Concurrent xs `mappend` Single y = Concurrent (Single y:xs)

  x `mappend` Concurrent ys = Concurrent (x:ys)
  Concurrent xs `mappend` y = Concurrent (y:xs)

  x `mappend` y = Concurrent [x, y]

instance Group (Sequenceable Cmd) where
  invert (Sequential xs) = Sequential . L.reverse . fmap invert $ xs
  invert (Concurrent xs) = Concurrent $ fmap invert xs
  invert (Single x) = Single $ inv x
    where
      inv (Mv src dest) = Mv dest src
      inv (Restore fp) = Rm fp
      inv (Rm fp) = Restore fp

instance Ring (Sequenceable Cmd) where
  Sequential xs |*| Sequential ys = Sequential (xs ++ ys)
  x |*| Sequential ys = Sequential (x:ys)
  Sequential xs |*| y = Sequential (xs ++ [y])
  x |*| y = Sequential [x, y]

infixl 6 |+|
infixl 6 |*|

andThen :: Ring r => r -> r -> r
andThen a b = a |*| b

concurrently :: Group r => r -> r -> r
concurrently a b = a |+| b

series :: [a] -> Sequenceable a
series = Sequential . fmap pure

conc :: [a] -> Sequenceable a
conc = Concurrent . fmap pure

prog :: Sequenceable Cmd
prog =
  pure (Mv "start" "end") 
  `andThen` pure (Mv "end" "start")
  `concurrently` series [Restore "file", Restore "otherfile"]
  `andThen` pure (Rm "important-file")