module Clean.Core(
(:*:),(:+:),
Semigroup(..),SubSemi(..),Monoid(..),Ring(..),
Unit(..),
Endo(..),Dual(..),OrdList(..),Interleave(..),
Category(..),
Choice(..),Split(..),
const,(&),
first,second,left,right,
ifThenElse,guard,fail,
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
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
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)
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
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
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)
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