module Data.Semigroup.Numbered ( SemigroupNo(..)
, SemigroupX, SemigroupY, SemigroupZ
, (|||), (===)
, (│), (──), (■), (┃), (━━), (██)
) where
import GHC.TypeLits
import qualified Data.List.NonEmpty as NE
import Data.Foldable
import Data.Proxy
import Data.Void
import Data.CallStack (HasCallStack)
class SemigroupNo (n :: Nat) g where
sappendN :: proxy n -> g -> g -> g
sappendN p x y = sconcatN p $ x NE.:|[y]
sconcatN :: proxy n -> NE.NonEmpty g -> g
sconcatN = foldr1 . sappendN
stimesN :: (Integral b, HasCallStack) => proxy n -> b -> g -> g
stimesN p y₀ x₀
| y₀ <= 0 = error "stimesN: positive multiplier expected"
| otherwise = f x₀ y₀
where
f x y
| even y = f (x <> x) (y `quot` 2)
| y == 1 = x
| otherwise = g (x <> x) (pred y `quot` 2) x
g x y z
| even y = g (x <> x) (y `quot` 2) z
| y == 1 = x <> z
| otherwise = g (x <> x) (pred y `quot` 2) (x <> z)
(<>) = sappendN p
instance (SemigroupNo n g) => SemigroupNo n (a -> g) where
sappendN p f g x = sappendN p (f x) (g x)
sconcatN p fs x = sconcatN p $ ($x)<$>fs
stimesN p n f = stimesN p n . f
instance (SemigroupNo n g) => SemigroupNo n (Maybe g) where
sappendN _ Nothing b = b
sappendN _ a Nothing = a
sappendN p (Just a) (Just b) = Just $ sappendN p a b
stimesN _ _ Nothing = Nothing
stimesN p n (Just a) = Just $ stimesN p n a
instance SemigroupNo n () where
sappendN _ () () = ()
sconcatN _ _ = ()
stimesN _ _ () = ()
instance SemigroupNo n (Proxy x) where
sappendN _ Proxy Proxy = Proxy
sconcatN _ _ = Proxy
stimesN _ _ Proxy = Proxy
instance SemigroupNo n Void where
sappendN _ = absurd
stimesN _ _ = absurd
instance SemigroupNo 0 [Void] where sappendN _ [] [] = []
instance SemigroupNo 0 [()] where sappendN _ = (++)
instance SemigroupNo 0 [Char] where sappendN _ = (++)
instance SemigroupNo 0 [Int] where sappendN _ = (++)
instance SemigroupNo 0 [Integer] where sappendN _ = (++)
instance SemigroupNo 0 [Float] where sappendN _ = (++)
instance SemigroupNo 0 [Double] where sappendN _ = (++)
instance SemigroupNo 0 [Rational] where sappendN _ = (++)
instance SemigroupNo 0 [Maybe a] where sappendN _ = (++)
instance (SemigroupNo 0 [a]) => SemigroupNo 0 [[a]] where
sappendN _ [] ys = ys
sappendN _ xs [] = xs
sappendN p (x:xs) (y:ys) = sappendN p x y : sappendN p xs ys
instance SemigroupNo 1 [[Void]] where sappendN _ = (++)
instance SemigroupNo 1 [[()]] where sconcatN _ = paddedLines () . concat
instance SemigroupNo 1 [[Char]] where sconcatN _ = paddedLines ' ' . concat
instance SemigroupNo 1 [[Int]] where sconcatN _ = paddedLines 0 . concat
instance SemigroupNo 1 [[Integer]] where sconcatN _ = paddedLines 0 . concat
instance SemigroupNo 1 [[Float]] where sconcatN _ = paddedLines 0 . concat
instance SemigroupNo 1 [[Double]] where sconcatN _ = paddedLines 0 . concat
instance SemigroupNo 1 [[Rational]] where sconcatN _ = paddedLines 0 . concat
instance SemigroupNo 1 [[Maybe a]] where sconcatN _ = paddedLines Nothing . concat
instance (SemigroupNo 1 [[a]]) => SemigroupNo 1 [[[a]]] where
sappendN _ [] ys = ys
sappendN _ xs [] = xs
sappendN p (x:xs) (y:ys) = sappendN p x y : sappendN p xs ys
paddedLines :: a -> [[a]] -> [[a]]
paddedLines padr xs = mkPadded <$> xs
where mkPadded cs = cs ++ replicate (paddingLen length cs) padr
paddingLen = maximum $ length <$> xs
type SemigroupX = SemigroupNo 0
infixr 6 │
(│) :: SemigroupX g => g -> g -> g
(│) = sappendN (Proxy :: Proxy 0)
infixr 3 ┃
(┃) :: SemigroupX g => g -> g -> g
(┃) = sappendN (Proxy :: Proxy 0)
infixl 6 |||
(|||) :: SemigroupX g => g -> g -> g
(|||) = sappendN (Proxy :: Proxy 0)
type SemigroupY = SemigroupNo 1
infixr 5 ──
(──) :: SemigroupY g => g -> g -> g
(──) = sappendN (Proxy :: Proxy 1)
infixr 2 ━━
(━━) :: SemigroupY g => g -> g -> g
(━━) = sappendN (Proxy :: Proxy 1)
infixl 6 ===
(===) :: SemigroupY g => g -> g -> g
(===) = sappendN (Proxy :: Proxy 1)
type SemigroupZ = SemigroupNo 2
infixr 4 ■
(■) :: SemigroupZ g => g -> g -> g
(■) = sappendN (Proxy :: Proxy 2)
infixr 1 ██
(██) :: SemigroupZ g => g -> g -> g
(██) = sappendN (Proxy :: Proxy 2)