{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, DefaultSignatures, TupleSections, EmptyDataDecls #-}
module Clean.Core(
  -- * Basic union and product types
  (:*:),(:+:),

  -- * Basic group and ring structure
  -- ** Classes
  Semigroup(..),SubSemi(..),Monoid(..),Ring(..),
  Unit(..),

  -- ** Common monoids
  Endo(..),Dual(..),OrdList(..),Interleave(..),

  -- * Fundamental control operations
  Category(..),
  Choice(..),Split(..),

  -- * Misc functions
  const,(&),

  first,second,left,right,

  ifThenElse,guard,fail,

  -- * The rest is imported from the Prelude
  module Prelude
  ) where

import Prelude hiding (
  Functor(..),Monad(..),
  sequence,mapM,mapM_,sequence_,(=<<),

  map,(++),foldl,foldr,concat,filter,length,sum,
  (+),(*),(.),id,const)
import qualified Prelude as P
import Data.Tree
import qualified Data.Set as S

data Void
type a:*:b = (a,b)
type a:+:b = Either a b

{-|
The class of all types that have a binary operation. Note that the operation
isn't necesarily commutative (in the case of lists, for example)
-} 
class Semigroup m where
  (+) :: m -> m -> m
  default (+) :: Num m => m -> m -> m
  (+) = (P.+)
instance Semigroup Void where _+_ = undefined
instance Semigroup () where _+_ = ()
instance Semigroup Bool where (+) = (||)
instance Semigroup Int
instance Semigroup Float
instance Semigroup Integer
instance Ord a => Semigroup (S.Set a) where (+) = S.union
instance Semigroup [a] where []+l = l ; (x:t)+l = x:(t+l)
instance (Semigroup a,Semigroup b) => Semigroup (a:*:b) where (a,b)+(c,d) = (a+c,b+d)
instance SubSemi b a => Semigroup (a:+:b) where
  Left a+Left b = Left (a+b)
  a+b = Right (from a+from b)
    where from = to <|> id

-- |A monoid is a semigroup with a null element such that @zero + a == a + zero == a@
class Semigroup m => Monoid m where
  zero :: m
  default zero :: Num m => m
  zero = 0
instance Monoid Void where zero = undefined
instance Monoid () where zero = ()
instance Monoid Int ; instance Monoid Integer ; instance Monoid Float
instance Ord a => Monoid (S.Set a) where zero = S.empty
instance Monoid [a] where zero = []
instance (Monoid a,Monoid b) => Monoid (a:*:b) where zero = (zero,zero)
instance (SubSemi b a,Monoid a) => Monoid (a:+:b) where zero = Left zero
instance Monoid Bool where zero = False

class (Semigroup a,Semigroup b) => SubSemi a b where
  to :: b -> a
instance Monoid a => SubSemi a () where to _ = zero

class Monoid m => Ring m where
  one :: m
  default one :: Num m => m
  one = 1
  (*) :: m -> m -> m
  default (*) :: Num m => m -> m -> m
  (*) = (P.*)
instance Ring Bool where one = True ; (*) = (&&)
instance Ring Int
instance Ring Integer
instance Ring Float
instance Monoid a => Ring [a] where
  one = zero:one
  (a:as) * (b:bs) = a+b:as*bs
  _ * _ = zero

class Unit f where
  pure :: a -> f a
instance Unit (Either a) where pure = Right
instance Monoid w => Unit ((,) w) where pure a = (zero,a)
instance Unit ((->) b) where pure = P.const
instance Unit [] where pure a = [a]
instance Unit Tree where pure a = Node a []
instance Unit IO where pure = P.return

class Category k where
  id :: k a a
  (.) :: k b c -> k a b -> k a c
instance Category (->) where
  id = P.id
  (.) = (P..)

class Category k => Choice k where
  (<|>) :: k a c -> k b c -> k (a:+:b) c
infixr 3 <|>
instance Choice (->) where
  (f <|> _) (Left a) = f a
  (_ <|> g) (Right b) = g b

class Category k => Split k where
  (<#>) :: k a c -> k b d -> k (a,b) (c,d)
instance Split (->) where f <#> g = \(a,b) -> (f a,g b)

{-| The Product monoid -}
newtype Product a = Product a
instance Ring a => Semigroup (Product a) where
  Product a+Product b = Product (a*b) 
instance Ring a => Monoid (Product a) where
  zero = Product one

{-| A monoid on category endomorphisms under composition -}
newtype Endo k a = Endo { runEndo :: k a a }
instance Category k => Semigroup (Endo k a) where Endo f+Endo g = Endo (f . g)
instance Category k => Monoid (Endo k a) where zero = Endo id

{-| The dual of a monoid is the same as the original, with arguments reversed -}
newtype Dual m = Dual { getDual :: m }
instance Semigroup m => Semigroup (Dual m) where Dual a+Dual b = Dual (b+a)
deriving instance Monoid m => Monoid (Dual m)
instance Ring m => Ring (Dual m) where 
  one = Dual one
  Dual a * Dual b = Dual (b*a)

-- |An ordered list
newtype OrdList a = OrdList { getOrdList :: [a] }
instance Ord a => Semigroup (OrdList a) where
  OrdList a + OrdList b = OrdList (merge a b)
    where merge xs@(x:xt) ys@(y:yt) | x<y = x:merge xt ys
                                    | otherwise = y:merge xs yt
          merge a b = a+b
deriving instance Ord a => Monoid (OrdList a)
deriving instance Unit OrdList

newtype Interleave a = Interleave { interleave :: [a] }
instance Semigroup (Interleave a) where
  Interleave as + Interleave bs = Interleave (inter as bs)
    where inter (a:as) bs = a:inter bs as
          inter [] bs = bs
deriving instance Monoid (Interleave a)

(&) = flip ($)

second a = id <#> a
first a = a <#> id
left a = a <|> id
right a = id <|> a

guard p = if p then pure () else zero

ifThenElse b th el = if b then th else el
fail = error
const = pure