Commit 88d08a2c authored by Kai-Oliver Prott's avatar Kai-Oliver Prott
Browse files

Add Applicative

parent 4d359ce0
module Control.Applicative where
infixl 4 <*>, <*, *>
--- Typeclass for Applicative-Functors
class Functor f => Applicative f where
pure :: a -> f a
(<*>) :: f (a -> b) -> f a -> f b
(*>) :: f a -> f b -> f b
m *> n = (id <$ m) <*> n
(<*) :: f a -> f b -> f a
(<*) = liftA2 const
liftA2 :: (a -> b -> c) -> f a -> f b -> f c
liftA2 f x = (<*>) (fmap f x)
instance Applicative Maybe where
pure = Just
Just f <*> Just a = Just (f a)
Nothing <*> Just _ = Nothing
Just _ <*> Nothing = Nothing
Nothing <*> Nothing = Nothing
--- Lift a function to actions.
--- This function may be used as a value for `fmap` in a `Functor` instance.
liftA :: Applicative f => (a -> b) -> f a -> f b
liftA f a = pure f <*> a
--- Lift a ternary function to actions.
liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 f a b c = liftA2 f a b <*> c
......@@ -13,7 +13,9 @@ module Control.Monad.Trans.Error (
) where
import Data.Either
import Data.Functor.Identity
import Control.Monad.Trans.Class
import Control.Applicative
--- Error monad.
newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
......@@ -34,19 +36,24 @@ instance ErrorList a => Error [a] where
strMsg = listMsg
instance (Functor m) => Functor (ErrorT e m) where
fmap f = ErrorT . fmap (fmap f) . runErrorT
fmap f = ErrorT . fmap (fmap f) . runErrorT
-- defined in terms of the monad instance for ErrorT
instance (Functor m, Monad m, Error e) => Applicative (ErrorT e m) where
pure = return
f <*> v = f >>= (\f' -> v >>= (\x -> return (f' x)))
instance (Monad m, Error e) => Monad (ErrorT e m) where
return a = ErrorT $ return (Right a)
m >>= k = ErrorT (do a <- runErrorT m
case a of
Left l -> return (Left l)
Right r -> runErrorT (k r))
fail msg = ErrorT $ return (Left (strMsg msg))
return a = ErrorT $ return (Right a)
m >>= k = ErrorT (do a <- runErrorT m
case a of
Left l -> return (Left l)
Right r -> runErrorT (k r))
fail msg = ErrorT $ return (Left (strMsg msg))
instance MonadTrans (ErrorT e) where
lift m = ErrorT (do a <- m
return (Right a))
lift m = ErrorT (do a <- m
return (Right a))
-- Signal an error value e.
throwError :: (Monad m) => e -> ErrorT e m a
......@@ -59,21 +66,11 @@ catchError m h = ErrorT (do a <- runErrorT m
Left l -> runErrorT (h l)
Right r -> return (Right r))
--- Sequence operator of the ErrorT monad
(*>) :: (Error e, Monad m) => ErrorT e m a -> ErrorT e m b -> ErrorT e m b
m *> n = m >>= (\x -> n)
--- Apply a pure function onto a monadic value.
(<$>) :: (Error e, Monad m) => (a -> b) -> ErrorT e m a -> ErrorT e m b
f <$> act = act >>= (\x -> return (f x))
--- Apply a function yielded by a monadic action to a monadic value.
(<*>) :: (Error e, Monad m) => ErrorT e m (a -> b)
-> ErrorT e m a -> ErrorT e m b
f <*> v = f >>= (\f' -> v >>= (\x -> return (f' x)))
runError :: ErrorT e Identity a -> Either e a
runError = runIdentity . runErrorT
--- Same as `concatMap`, but for a monadic function.
concatMapM :: (Error e, Monad m) => (a -> ErrorT e m [b])
concatMapM :: (Error e, Functor m, Monad m) => (a -> ErrorT e m [b])
-> [a] -> ErrorT e m [b]
concatMapM f xs = concat <$> mapM f xs
......
......@@ -16,6 +16,7 @@ module Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.Functor.Identity
import Control.Applicative
newtype StateT s m a = StateT { runStateT :: s -> m (a, s) }
......@@ -23,6 +24,11 @@ instance (Functor m) => Functor (StateT s m) where
fmap f m = StateT (\ s ->
fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s)
-- defined in terms of the monad instance for StateT
instance (Functor m, Monad m) => Applicative (StateT s m) where
pure = return
f <*> v = f >>= (\f' -> v >>= (\x -> return (f' x)))
instance (Monad m) => Monad (StateT s m) where
m >>= k = StateT (\ s -> do ~(a, s') <- runStateT m s
runStateT (k a) s')
......@@ -45,7 +51,7 @@ put s = state (\ _ -> ((), s))
modify :: Monad m => (s -> s) -> StateT s m ()
modify f = state (\ s -> ((), f s))
type State s a = StateT s (Identity) a
type State s = StateT s Identity
runState :: State s a -> s -> (a, s)
runState m = runIdentity . runStateT m
......
......@@ -33,7 +33,7 @@ module Prelude
, takeWhile, dropWhile, span, break, lines, unlines, words, unwords
, reverse, and, or, any, all
, ord, chr, (=:=), success, (&), (&>), maybe, either
, (>>=), return, (>>), done, putChar, getChar, readFile
, (<$>), (<$), (>>=), return, (>>), done, putChar, getChar, readFile
, writeFile, appendFile
, putStr, putStrLn, getLine, userError, ioError, showError
, catch, doSolve, sequenceIO, sequenceIO_, mapIO
......@@ -61,6 +61,7 @@ module Prelude
infixl 9 !!
infixr 9 .
infixr 8 ^
infixl 7 *, `div`, `mod`, `quot`, `rem`, /
infixl 6 +, -
-- infixr 5 : -- declared together with list
......@@ -69,6 +70,7 @@ infix 4 =:=, ==, /=, <, >, <=, >=, =:<=
#ifdef __PAKCS__
infix 4 =:<<=
#endif
infixl 4 <$>, <$
infix 4 `elem`, `notElem`
infixr 3 &&
infixr 2 ||
......@@ -1806,6 +1808,18 @@ class Functor f where
instance Functor [] where
fmap = map
instance Functor Maybe where
fmap f (Just x) = Just (f x)
fmap _ Nothing = Nothing
--- Operator alias for fmap
(<$>) :: Functor f => (a -> b) -> f a -> f b
(<$>) = fmap
--- Replace all locations in the input with the same value.
(<$) :: Functor f => a -> f b -> f a
(<$) = fmap . const
instance Functor (Either a) where
fmap _ (Left a) = Left a
fmap f (Right b) = Right (f b)
......@@ -1903,24 +1917,22 @@ whenM p act = if p then act else return ()
----------------------------------------------------------------------------
--some useful numerical operations and constants
infixr 8 ^
--- The number pi.
pi :: Float
pi = 3.141592653589793238
--- The value of `a ^. b` is `a` raised to the power of `b`.
--- Executes in `O(log b)` steps.
---
--- @param a - The base.
--- @param b - The exponent.
--- @return `a` raised to the power of `b`.
--- The number pi.
pi :: Float
pi = 3.141592653589793238
--- The value of `a ^. b` is `a` raised to the power of `b`.
--- Executes in `O(log b)` steps.
---
--- @param a - The base.
--- @param b - The exponent.
--- @return `a` raised to the power of `b`.
(^) :: Fractional a => a -> Int -> a
a ^ b | b < 0 = 1 / a ^ (b * (-1))
| otherwise = powaux 1 a b
where
powaux n x y = if y == 0 then n
else powaux (n * if (y `mod` 2 == 1) then x else 1)
(x * x)
(y `div` 2)
(^) :: Fractional a => a -> Int -> a
a ^ b | b < 0 = 1 / a ^ (b * (-1))
| otherwise = powaux 1 a b
where
powaux n x y = if y == 0 then n
else powaux (n * if (y `mod` 2 == 1) then x else 1)
(x * x)
(y `div` 2)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment