{-# LANGUAGE MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, OverlappingInstances #-}

module Data.Semigroup (Monoid(..), Endo, Fusion, Point(..), Semigroup(..), endoMaybe, endoPoint, fusing', fusing, fuseCat, scatPoints', scatPoints, pJust, pNothing) where

import Data.Monoid(Monoid(..))
import Data.Maybe
import GHC.Exts

type Endo a = a -> a -> a
type Fusion a = [a] -> Maybe a
newtype Point a = Pt (Maybe a) deriving (Functor, Eq, Show, Read)

class Semigroup a where
	sappend :: Endo a
	sconcat :: Fusion a
	sconcat = fusing
	sconcat_ :: a -> [a] -> a
	sconcat_ x xs = fromJust (sconcat (x:xs))

instance Monoid a => Semigroup a where
	sappend = mappend
	sconcat = Just . mconcat
	sconcat_ x xs = mconcat (x:xs)

{-instance Semigroup a => Semigroup (Maybe a) where
	sappend = endoMaybe sappend
	sconcat xs = Just (sconcat [x | Just x <- xs])-}

instance Semigroup a => Monoid (Point a) where
	mempty = Pt Nothing
	mappend = endoPoint sappend
	mconcat = Pt . scatPoints

{-# INLINE [1] endoMaybe #-}
endoMaybe :: Endo a -> Endo (Maybe a)
endoMaybe (><) (Just a) = Just . maybe a (a ><)
endoMaybe _ Nothing = id

{-# RULES "endoMaybe/Just" forall f a b . endoMaybe f a (Just b) = Just (maybe b (`f` b) a) #-}

{-# INLINE endoPoint #-}
endoPoint :: Endo a -> Endo (Point a)
endoPoint (><) (Pt a) (Pt b) = Pt (endoMaybe (><) a b)

fusing' :: Endo a -> Fusion a
fusing' _ [] = Nothing
fusing' (><) (q:qs) = Just $ fuseCat (><) q qs

fuseCat :: Endo a -> a -> [a] -> a
fuseCat (><) = fuseCat' where
	fuseCat' x [] = x
	fuseCat' x xs = case fuse1 x xs of ( x', xs' ) -> fuseCat' x' xs'
	fuse1 x1 (x2:x3:x4:xs) = ( (x1 >< x2) >< (x3 >< x4), fuser xs )
	fuse1 x1 [x2,x3] = ( x1 >< x2 >< x3, [] )
	fuse1 x1 [x2] = ( x1 >< x2, [] )
	fuse1 x1 [] = ( x1, [] )
	fuser [] = []
	fuser (x:xs) = case fuse1 x xs of ( x, xs ) -> x:xs

fusing :: Semigroup a => Fusion a
fusing = fusing' sappend

{-# INLINE scatPoints' #-}
scatPoints' :: Fusion a -> [Point a] -> Maybe a
scatPoints' cat xs = cat [x | Pt (Just x) <- xs]

{-# INLINE scatPoints #-}
scatPoints :: Semigroup a => [Point a] -> Maybe a
scatPoints = scatPoints' sconcat

pJust :: a -> Point a
pJust = Pt . Just

pNothing :: Point a
pNothing = Pt Nothing