Commit c71896a1 authored by Steffen Michels's avatar Steffen Michels

Merge branch '18-organisation-of-class-instances' into 'master'

Resolve "Organisation of class instances"

See merge request !88
parents a58fb123 b6b0a9c7
Pipeline #8639 passed with stage
in 1 minute and 32 seconds
......@@ -12,12 +12,15 @@ unwrapMonad :: !(WrappedMonad m a) -> m a
getConst :: !(Const a b) -> a
instance Applicative ((->) r)
instance Applicative Maybe
instance Applicative []
class Applicative f | Functor f
where
pure :: a -> f a
(<*>) infixl 4 :: !(f (a -> b)) (f a) -> f b
instance Alternative Maybe
instance Alternative []
class Alternative f | Applicative f
where
empty :: f a
(<|>) infixl 3 :: !(f a) (f a) -> f a
instance Functor (Const m)
instance Functor (WrappedMonad m) | Monad m
......@@ -30,14 +33,6 @@ instance Alternative (WrappedMonad m) | MonadPlus m
instance Semigroup (Const a b) | Semigroup a
instance Monoid (Const a b) | Monoid a
class Applicative f | Functor f where
pure :: a -> f a
(<*>) infixl 4 :: !(f (a -> b)) (f a) -> f b
class Alternative f | Applicative f where
empty :: f a
(<|>) infixl 3 :: !(f a) (f a) -> f a
some :: (f a) -> f [a] | Alternative f
many :: (f a) -> f [a] | Alternative f
......@@ -54,7 +49,6 @@ many :: (f a) -> f [a] | Alternative f
*/
class (*>) infixl 4 f :: !(f a) (f b) -> f b | Applicative f
instance *> f
instance *> Maybe
/**
* Sequence actions and take the value of the left argument.
......@@ -65,7 +59,6 @@ instance *> Maybe
*/
class (<*) infixl 4 f :: !(f a) (f b) -> f a | Applicative f
instance <* f
instance <* Maybe
(<**>) infixl 4 :: (f a) (f (a -> b)) -> f b | Applicative f
......
......@@ -39,28 +39,6 @@ instance Alternative (WrappedMonad m) | MonadPlus m where
empty = WrapMonad mzero
(<|>) (WrapMonad u) (WrapMonad v) = WrapMonad (mplus u v)
instance Applicative ((->) r) where
pure x = const x
(<*>) f g = \x -> f x (g x)
instance Applicative Maybe where
pure x = Just x
(<*>) Nothing _ = Nothing
(<*>) (Just f) ma = fmap f ma
instance Applicative [] where
pure x = [x]
(<*>) xs x = liftA2 id xs x
instance Alternative Maybe where
empty = Nothing
(<|>) Nothing r = r
(<|>) l _ = l
instance Alternative [] where
empty = []
(<|>) fa fa` = fa ++ fa`
some :: (f a) -> f [a] | Alternative f
some v = some_v
where many_v = some_v <|> lift []
......@@ -73,19 +51,8 @@ many v = many_v
instance *> f where *> fa fb = id <$ fa <*> fb
instance *> Maybe
where
*> (Just _) m = m
*> _ _ = Nothing
instance <* f where <* fa fb = liftA2 const fa fb
instance <* Maybe
where
<* Nothing _ = Nothing
<* m (Just _) = m
<* _ _ = Nothing
(<**>) infixl 4 :: (f a) (f (a -> b)) -> f b | Applicative f
(<**>) fa fab = liftA2 (flip ($)) fa fab
......
......@@ -2,9 +2,9 @@ definition module Control.Monad
from Control.Applicative import class Applicative
from Data.Functor import class Functor
from Data.Maybe import :: Maybe
class Monad m | Applicative m where
class Monad m | Applicative m
where
bind :: !(m a) (a -> m b) -> m b
(>>=) infixl 1 :: (m a) (a -> m b) -> m b | Monad m
......@@ -19,19 +19,10 @@ class Monad m | Applicative m where
(=<<) infixr 1 :: (a -> m b) (m a) -> m b | Monad m
(=<<) f x :== x >>= f
instance Monad ((->) r)
instance Monad []
instance Monad Maybe
class MonadPlus m | Monad m where
mzero :: m a
mplus :: !(m a) (m a) -> m a
instance MonadPlus []
instance MonadPlus Maybe
class MonadPlus m | Monad m
where
mzero :: m a
mplus :: !(m a) (m a) -> m a
sequence :: !.[a b] -> a [b] | Monad a
sequence_ :: !.[a b] -> a () | Monad a
......
......@@ -3,31 +3,10 @@ implementation module Control.Monad
from Control.Applicative import class Applicative (..), lift
from Data.Functor import class Functor (..)
from Data.List import map, zipWith, replicate
from Data.Maybe import :: Maybe, Nothing, Just
from StdList import foldr, ++
from StdList import foldr
from StdFunc import flip, id, o, const
from StdInt import class +, instance + Int
instance Monad ((->) r) where
bind ma a2mb = \r -> a2mb (ma r) r
instance Monad [] where
bind m k = foldr ((++) o k) [] m
instance Monad Maybe where
bind (Just x) k = k x
bind Nothing _ = Nothing
instance MonadPlus [] where
mzero = []
mplus xs ys = xs ++ ys
instance MonadPlus Maybe where
mzero = Nothing
mplus Nothing ys = ys
mplus xs _ = xs
sequence :: !.[a b] -> a [b] | Monad a
sequence ms = foldr k (lift []) ms
where
......
......@@ -3,7 +3,7 @@ implementation module Control.Monad.Fix
from StdFunc import o
from StdMisc import abort
import Control.Applicative
from Control.Monad import class Monad, instance Monad []
from Control.Monad import class Monad
from Data.Func import fix
import Data.List
import Data.Maybe
......
definition module Data.Bifunctor
from Data.Either import :: Either
class Bifunctor p where
bifmap :: (a -> b) (c -> d) (p a c) -> p b d
first :: (a -> b) (p a c) -> p b c
second :: (b -> c) (p a b) -> p a c
instance Bifunctor (,)
instance Bifunctor ((,,) x)
instance Bifunctor ((,,,) x y)
instance Bifunctor ((,,,,) x y z)
instance Bifunctor Either
class Bifunctor p
where
bifmap :: (a -> b) (c -> d) (p a c) -> p b d
first :: (a -> b) (p a c) -> p b c
second :: (b -> c) (p a b) -> p a c
implementation module Data.Bifunctor
from StdFunc import o, id
import Data.Either
instance Bifunctor (,) where
bifmap f g t = let (a, b) = t in (f a, g b)
first f d = bifmap f id d
second g d = bifmap id g d
instance Bifunctor ((,,) x) where
bifmap f g t = let (x, a, b) = t in (x, f a, g b)
first f d = bifmap f id d
second g d = bifmap id g d
instance Bifunctor ((,,,) x y) where
bifmap f g t = let (x, y, a, b) = t in (x, y, f a, g b)
first f d = bifmap f id d
second g d = bifmap id g d
instance Bifunctor ((,,,,) x y z) where
bifmap f g t = let (x, y, z, a, b) = t in (x, y, z, f a, g b)
first f d = bifmap f id d
second g d = bifmap id g d
instance Bifunctor Either where
bifmap f _ (Left a) = Left (f a)
bifmap _ g (Right b) = Right (g b)
first f d = bifmap f id d
second g d = bifmap id g d
......@@ -8,6 +8,9 @@ definition module Data.Either
from Control.Applicative import class Applicative, class *>, class <*
from Control.Monad import class Monad
from Data.Functor import class Functor
from Data.Foldable import class Foldable
from Data.Traversable import class Traversable
from Data.Bifunctor import class Bifunctor
:: Either a b = Left a | Right b
......@@ -22,4 +25,9 @@ instance <* (Either e)
instance Monad (Either e)
instance Foldable (Either a)
instance Traversable (Either a)
instance Bifunctor Either
either :: (.a -> .c) (.b -> .c) !(Either .a .b) -> .c
implementation module Data.Either
from StdEnv import flip, id, o
from StdMisc import abort
import Control.Applicative
import Control.Monad
import Data.Functor
import Data.Maybe
import Data.Monoid
from Data.Foldable import class Foldable(foldMap,foldl,foldr)
from Data.Traversable import class Traversable(traverse)
import qualified Data.Traversable as T
import Data.Bifunctor
instance Functor (Either a) where
fmap f (Left l) = Left l
......@@ -24,9 +32,47 @@ where
<* _ (Left l) = Left l
<* x _ = x
instance Monad (Either e) where
bind (Left l) _ = Left l
bind (Right r) k = k r
instance Monad (Either e)
where
bind (Left l) _ = Left l
bind (Right r) k = k r
instance Foldable (Either a)
where
foldMap _ (Left _) = mempty
foldMap f (Right y) = f y
fold x = foldMap id x
foldr _ z (Left _) = z
foldr f z (Right y) = f y z
foldr` f z0 xs = foldl f` id xs z0
where f` k x z = k (f x z)
foldl f z t = appEndo (getDual (foldMap (Dual o Endo o flip f) t)) z
foldl` f z0 xs = foldr f` id xs z0
where f` x k z = k (f z x)
foldr1 f xs = fromMaybe (abort "foldr1: empty structure") (foldr mf Nothing xs)
where
mf x Nothing = Just x
mf x (Just y) = Just (f x y)
foldl1 f xs = fromMaybe (abort "foldl1: empty structure") (foldl mf Nothing xs)
where
mf Nothing y = Just y
mf (Just x) y = Just (f x y)
instance Traversable (Either a)
where
traverse _ (Left x) = pure (Left x)
traverse f (Right y) = Right <$> f y
sequenceA f = traverse id f
mapM f x = unwrapMonad (traverse (WrapMonad o f) x)
sequence x = 'T'.mapM id x
instance Bifunctor Either
where
bifmap f _ (Left a) = Left (f a)
bifmap _ g (Right b) = Right (g b)
first f d = bifmap f id d
second g d = bifmap id g d
either :: (.a -> .c) (.b -> .c) !(Either .a .b) -> .c
either f _ (Left x) = f x
......
......@@ -2,7 +2,6 @@ definition module Data.Foldable
from Control.Applicative import class Applicative (..), :: Const, class Alternative (..), class *>
from Control.Monad import class Monad (..), >>=, class MonadPlus (..)
from Data.Either import :: Either
from Data.Functor import class Functor (..)
from Data.Monoid import class Monoid (..), class Semigroup (..)
from Data.Maybe import :: Maybe
......@@ -85,11 +84,6 @@ class Foldable t where
*/
foldl1 :: (a a -> a) !(t a) -> a
instance Foldable Maybe
instance Foldable []
instance Foldable (Either a)
instance Foldable ((,) a)
// TODO Cleanify
//instance Ix i => Foldable (Array i)
......
......@@ -4,8 +4,7 @@ from StdFunc import o, id, flip
from StdMisc import abort
import Control.Applicative
from Control.Monad import class Monad(..), >>=
import qualified Data.List as DL
import Data.Either
from Data.List import instance Semigroup [a], instance Monoid [a], instance Foldable []
import Data.Monoid
import Data.Maybe
import qualified StdList as SL
......@@ -13,84 +12,6 @@ import StdClass
from StdOverloaded import class < (..)
from StdBool import not
instance Foldable Maybe where
fold x = foldMap id x
foldMap f x = foldr (mappend o f) mempty x
foldr _ z Nothing = z
foldr f z (Just x) = f x z
foldr` f z0 xs = foldl f` id xs z0
where f` k x z = k (f x z)
foldl _ z Nothing = z
foldl f z (Just x) = f z x
foldl` f z0 xs = foldr f` id xs z0
where f` x k z = k (f z x)
foldr1 f xs = fromMaybe (abort "foldr1: empty structure")
(foldr mf Nothing xs)
where
mf x Nothing = Just x
mf x (Just y) = Just (f x y)
foldl1 f xs = fromMaybe (abort "foldl1: empty structure")
(foldl mf Nothing xs)
where
mf Nothing y = Just y
mf (Just x) y = Just (f x y)
instance Foldable [] where
fold x = foldMap id x
foldMap f x = foldr (mappend o f) mempty x
foldr f x y = 'SL'.foldr f x y
foldr` f z0 xs = foldl f` id xs z0
where f` k x z = k (f x z)
foldl f x y = 'SL'.foldl f x y
foldl` f x y = 'DL'.foldl f x y
foldr1 f x = 'DL'.foldr1 f x
foldl1 f x = 'DL'.foldl1 f x
instance Foldable (Either a) where
foldMap _ (Left _) = mempty
foldMap f (Right y) = f y
fold x = foldMap id x
foldr _ z (Left _) = z
foldr f z (Right y) = f y z
foldr` f z0 xs = foldl f` id xs z0
where f` k x z = k (f x z)
foldl f z t = appEndo (getDual (foldMap (Dual o Endo o flip f) t)) z
foldl` f z0 xs = foldr f` id xs z0
where f` x k z = k (f z x)
foldr1 f xs = fromMaybe (abort "foldr1: empty structure")
(foldr mf Nothing xs)
where
mf x Nothing = Just x
mf x (Just y) = Just (f x y)
foldl1 f xs = fromMaybe (abort "foldl1: empty structure")
(foldl mf Nothing xs)
where
mf Nothing y = Just y
mf (Just x) y = Just (f x y)
instance Foldable ((,) a) where
foldMap f (_, y) = f y
fold x = foldMap id x
foldr f z (_, y) = f y z
foldr` f z0 xs = foldl f` id xs z0
where f` k x z = k (f x z)
foldl f z t = appEndo (getDual (foldMap (Dual o Endo o flip f) t)) z
foldl` f z0 xs = foldr f` id xs z0
where f` x k z = k (f z x)
foldr1 f xs = fromMaybe (abort "foldr1: empty structure")
(foldr mf Nothing xs)
where
mf x Nothing = Just x
mf x (Just y) = Just (f x y)
foldl1 f xs = fromMaybe (abort "foldl1: empty structure")
(foldl mf Nothing xs)
where
mf Nothing y = Just y
mf (Just x) y = Just (f x y)
// TODO Cleanify
//instance Ix i => Foldable (Array i) where
//foldr f z = Prelude.foldr f z o elems
......
definition module Data.Func
from Data.Functor import class Functor
from Control.Applicative import class Applicative
from Control.Monad import class Monad
from Data.Monoid import class Semigroup, class Monoid
instance Functor ((->) r)
instance Applicative ((->) r)
instance Monad ((->) r)
instance Semigroup (a -> b) | Semigroup b
instance Monoid (a -> b) | Monoid b
/**
* Function application.
* @type (a -> b) a -> b
......
implementation module Data.Func
from StdFunc import const, o
import Data.Functor
import Data.Monoid
import Control.Applicative
import Control.Monad
instance Functor ((->) r)
where
fmap f g = \x -> (f o g) x
instance Applicative ((->) r)
where
pure x = const x
(<*>) f g = \x -> f x (g x)
instance Monad ((->) r)
where
bind ma a2mb = \r -> a2mb (ma r) r
instance Semigroup (a -> b) | Semigroup b
where
mappend f g = \x -> mappend (f x) (g x)
instance Monoid (a -> b) | Monoid b
where
mempty = \_ -> mempty
seqSt :: !(a .st -> .st) ![a] !.st -> .st
seqSt f [] st = st
seqSt f [x:xs] st = seqSt f xs (f x st)
......
definition module Data.Functor
from System.IO import :: IO
from StdFunc import const
class Functor f where
class Functor f
where
fmap :: (a -> b) !(f a) -> f b
(<$>) infixl 4 :: (a -> b) !(f a) -> f b | Functor f
......@@ -17,7 +17,3 @@ class Functor f where
void :: !(f a) -> f () | Functor f
void x :== () <$ x
instance Functor ((->) r)
instance Functor ((,) a)
implementation module Data.Functor
from StdFunc import o
import Control.Applicative
instance Functor ((->) r) where
fmap f g = \x -> (f o g) x
instance Functor ((,) a) where
fmap f (x, y) = (x, f y)
definition module Data.Generics.GenBimap
// from StdGeneric import generic bimap
import StdGeneric
from StdMaybe import :: Maybe
from Data.Maybe import :: Maybe
derive bimap Maybe, [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
definition module Data.Generics.GenCompress
import StdGeneric, StdMaybe
import StdGeneric
from Data.Maybe import :: Maybe
:: BitVector :== {#Int}
......
implementation module Data.Generics.GenCompress
import StdGeneric, StdEnv, StdMaybe, Data.Generics._Array
import StdGeneric, StdEnv, Data.Generics._Array
from Data.Maybe import :: Maybe(..)
//--------------------------------------------------
// uncompressor monad
......
......@@ -7,4 +7,3 @@ generic gDefault a :: a
derive gDefault Int, Real, String, PAIR, EITHER, CONS, FIELD, OBJECT
derive gDefault [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
......@@ -16,4 +16,3 @@ gDefault{|FIELD|} df = FIELD df
gDefault{|OBJECT|} do = OBJECT do
derive gDefault [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
definition module Data.Generics.GenFMap
import StdGeneric, StdMaybe
import StdGeneric
from Data.Maybe import :: Maybe
:: FMap v
derive bimap FMap
......
implementation module Data.Generics.GenFMap
import StdGeneric, StdEnv, StdMaybe, Data.Generics._Array, Data.Generics.GenMonad
import StdGeneric, StdEnv, Data.Generics._Array, Data.Generics.GenMonad
from Data.Maybe import :: Maybe(..)
derive bimap (,), []
......
......@@ -8,4 +8,3 @@ Out :: !u:(Fix v:a) -> v:(a w:(Fix v:a)), [u <= w]
hylo :: ((.f .b) -> .b) (.a -> (.f .a)) -> (.a -> .b) | gMap{|*->*|} f
cata :: (u:(f .a) -> .a) -> (Fix u:f) -> .a | gMap{|*->*|} f
ana :: (.a -> u:(f .a)) -> .a -> (Fix u:f) | gMap{|*->*|} f
......@@ -15,4 +15,3 @@ cata f = hylo f Out
ana :: (.a -> u:(f .a)) -> .a -> (Fix u:f) | gMap{|*->*|} f
ana f = hylo In f
......@@ -16,4 +16,3 @@ gMap{|{}|} f xs = mapArray f xs
gMap{|{!}|} f xs = mapArray f xs
derive gMap [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
......@@ -9,4 +9,3 @@ derive gMapLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
generic gMapRSt a b :: .a .st -> (.b, .st)
derive gMapRSt c, UNIT, PAIR, EITHER, FIELD, CONS, OBJECT, {}, {!}
derive gMapRSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
......@@ -52,4 +52,3 @@ mapStFIELD f (FIELD x) st
mapStOBJECT f (OBJECT x) st
# (x, st) = f x st
= (OBJECT x, st)
definition module Data.Generics.GenMonad
import StdGeneric, StdMaybe, StdList
import StdGeneric
import StdList
from Data.Maybe import :: Maybe
class Monad m where
class Monad m
where
ret :: a:a -> m:(m a:a), [m <= a]
(>>=) infixl 5 :: u:(m .a) v:(.a -> u:(m .b)) -> u:(m .b), [u <= v]
......@@ -17,4 +20,3 @@ derive gMapLM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
generic gMapRM a b :: a:a -> m:(m b:b) | Monad m, [m <= b]
derive gMapRM c, UNIT, PAIR, EITHER, CONS, FIELD, OBJECT
derive gMapRM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)