my_prelude.hs

{- * Foundational functions -}

id :: a -> a
id x = x

const :: a -> b -> a
const x y = x

fix :: (a -> a) -> a
fix f = f (fix f)

bottom :: a
bottom = fix id

{- * Foundational typeclasses.
The following definitions form the foundation for programming in psilo.
-}

{- |
A type `m` is a Monoid if
- It has a default value; and
- You can combine two `m` values into a one `m` value.
-}
class Monoid a where
    empty :: a
    combine :: a -> a -> a

-- | Shorthand for `combine`.
(<>) :: Monoid a => a -> a -> a
(<>) = combine

{- |
A type `f` is a Functor if it provides some context or structure for some base
type `a` and permits the internal a value(s) to be mapped to some other type
`b` by a unary mapping function.

The mapping function may only see each independently - not the whole structure;
it may also not change the structure. Just the values being mapped.

See the definitions of Monad and Comonad for extensions which permit localized
mutation and read-only global access to the structure, respectively.

The type signature is probably much clearer.
-}
class Functor f where
    map :: (a -> b) -> f a -> f b

-- | Shorthand for `map`
(<$>) :: Functor f => (a -> b) -> f a -> f b
(<$>) = map

{- |
A type `f` is an Apply if it is a Functor, and also permits the mapping
function to be value in the context of `f`.

More simply, this allows for chaining of computations inside some context.

Say the functor in question is the List type (defined below). If I have a list
of functions which take an integer and produce a boolean, and another list of
integers, then I can write

    funcList <*> intList

to apply all the functions in the first list to all the ints in the second list
to produce a list of all results.
-}
class (Functor f) => Apply f where
    apply :: f (a -> b) -> f a -> f b

-- | Shorthand for `apply`.
(<*>) :: Apply f => f (a -> b) -> f a -> f b
(<*>) = apply

{- |
A type `f` is Applicative if it is an Apply and also permits arbitrary values
to be lifted into the `f` context in a uniform way.

More simply this is a kind of functor for which initial structure may be
created for any arbitrary value, making it easier to then use `apply` on
arbitrary values.
-}
class (Apply f) => Applicative f where
    pure :: a -> f a

{- |
A type `f` is Alternative if it is Applicative and monoidal. The name
"Alternative" suggests a common use case for this typeclass: functor
computations which allow for a limited form of choice.

How your Alternative decides between two values of `f a` is what defines it.
-}
class (Applicative f) => Alternative f where
    base :: f a
    (<|>) :: f a -> f a -> f a

{- |
A type `m` is a monad if
- `m` is Applicative; and
- An `m` parameterized over some `m a` can be flattened into an `m a`.

This second requirement is called "joining" because it is like joining two
layers of type structure.

`map` and `join` permit the mechanical definition of a function called `>>=`.
`>>=` is like `map` except the mapping function creates an extra layer of
`m` on top of the existing value. These two layers of `m` will then be joined
together, producing a single monad value `m b`.

Intuitively this means that a Monad is a Functor which permits a mapping
function to alter the structure around each internal value.
-}
class (Applicative m) => Monad m where
    join :: m (m a) -> m a

    return :: a -> m a
    return = pure

    (>>=) :: m a -> (a -> m b) -> m b
    ma >>= f = join (map f ma)

    (>>) :: m a -> m b -> m b
    ma >> mb = ma >>= \_ -> mb

{- |
A type `w` is an Extract if it is an Apply and also permits values of the base
type `a` to be extracted from a `w a`.

This is really the dual to Applicative.
-}
class (Apply w) => Extract w where
    extract :: w a -> a

{- |
A type `w` is a Comonad if
- It is an Extract; and
- A value `w a` may duplicate the `w` structure to produce a value
`w (w a)`.

We call this duplication a "fork" because the single layer of structure
is forked into an identical layer around it.

`map` and `fork` permit the definition of `=<<`. Whereas `map` only allows the
mapping to rely on each element individually, `=<<` allows the mapping function
to use the entire structure to produce each individual value.

More simply a Comonad is a Functor whose mapping operation can see the entire
structure but not alter it.

Comonads are duals to Monads.
-}
class (Extract w) => Comonad w where
    fork :: w a -> w (w a)

    (=<<) :: w a -> (w a -> b) -> w b
    wa =<< f = map f . fork wa

-- * Basic types

-- | A Box is the simplest functor. It has many uses.
newtype Box a = Box { unbox :: a } deriving Show

instance Functor Box where
    map f i = Box $ f $ unbox i

instance Apply Box where
    Box f `apply` Box a = Box (f a)

instance Applicative Box where
    pure = Box

instance Extract Box where
    extract (Box v) = v

instance Monad Box where
    join (Box bx) = bx

instance Comonad Box where
    fork (Box v) = Box (Box v)

instance Monoid a => Monoid (Box a) where
    empty = Box empty
    bx `combine` by = combine <$> bx <*> by

-- | A monoid of endomorphisms under composition
newtype Endo a = Endo {
    appEndo :: a -> a
}

instance Monoid (Endo a) where
    empty = Endo id
    Endo f `combine` Endo g = Endo (f . g)

newtype Bool = Bool {
    if :: forall r. r -> r -> r
}

true :: Bool
true = Bool $ \t _ -> t

false :: Bool
false = Bool $ \_ e -> e

-- * Utility typeclasses

{- |
A type `f` is Foldable if it permits the values inside it to be reduced or
"folded" down to some other value.
-}

class Foldable t where
    fold :: Monoid m => t m -> m
    fold = foldMap id

    foldMap :: Monoid m => (a -> m) -> t a -> m
    foldMap f = foldr (append . f) empty

    foldr :: (a -> b -> b) -> b -> t a -> b
    foldr f z t = appEndo (foldMap (Endo . f) t) z

    foldl :: (b -> a -> b) -> b -> t a -> b
    foldl f z t = appEndo (unbox (foldMap
        (Box . Endo . flip f) t )) z

    foldl' :: (b -> a -> b) -> b -> t a -> b
    foldl'  f z0 xs = foldr f' id xs z0 where
        f' x k z = k $! f z x

    filter :: (Monoid (t a), Applicative t) => (a -> Bool) -> t a -> t a
    filter p = foldMap (\a -> if (p a) (pure a) empty)

    foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
    foldlM f z0 xs = foldr f' return xs z0
        where f' x k z = f z x >>= k

-- * Utility types

-- | Const is like a Box which preserves its value
newtype Const a b = Const { getConst :: a }

instance Functor (Const a) where
    map _ cnst = cnst

-- | A Pair is a structure containing two values of different types.
newtype Pair a b = Pair {
        unpair :: forall r.
                  (a -> b -> r)
               -> r
}

pair :: a -> b -> Pair a b
pair x y = Pair $ \f -> f x y

instance Functor (Pair a) where
    map f p = unpair p (\x y -> pair x (f y))

fst :: Pair r b -> r
fst p = unpair p (\f _ -> f)

snd :: Pair a r -> r
snd p = unpair p (\_ s -> s)

newtype Opt a = Opt {
    maybe :: forall r. (a -> r) -> r -> r
}

just :: a -> Opt a
just x = Opt $ \s n -> s x

none :: Opt a
none = Opt $ \s n -> n

instance Functor Opt where
    map f o = maybe o (\x -> just (f x)) none

instance Apply Opt where
    oa `apply` ob = maybe oa (\f -> map f ob) none

instance Applicative Opt where
    pure = just

instance Alternative Opt where
    base = none
    ol <|> or = maybe o (\j -> just j) or

instance Foldable Opt where
    foldr f z o = maybe o (\x -> f x z) z

instance Monoid a => Monoid (Opt a) where
    empty = none
    x `combine` y = maybe x (\x' ->
        maybe y (\y' -> just (x' `combine` y'))
              x)
            y

instance Monad Opt where
    join ooa = maybe ooa id none

-- | List: a linked list of arbitrary length, which may be empty.

newtype List a = List {
    listFoldr :: forall r.
                 (a -> r -> r)
              -> r
              -> r
}

cons :: a -> List a -> List a
cons x xs = List $ \c e -> c x $ listFoldr xs c e

nil :: List a
nil = List $ \c e -> e

split :: List a -> Pair (Opt a) (List a)
split xs = listFoldr xs f (pair none nil) where
    f y ys = pair (just y) (List (\c e ->
        maybe (fst ys) (\x -> c x (listFoldr (snd ys) c e))
            e))

car :: List a -> Opt a
car xs = fst . split $ xs

cdr :: List a -> List a
cdr = snd . split

append :: List a -> List a -> List a
xs `append` ys = listFoldr xs cons ys

zip :: List a -> List b -> List (Pair a b)
zip as bs =
    let (ha, ta) = split as
        (hb, tb) = split bs
    in  maybe ha (\a ->
            maybe hb (\b -> cons (pair a b) (zip ta tb)) nil)
            nil

listFilter :: (a -> Bool) -> List a -> List a
listFilter pred xs = listFoldr xs f nil where
    f y ys = List $ \c e ->
        if (pred y)
            (c y (listFoldr ys c e))
            (listFoldr ys c e)

instance Functor List where
    map f xs = listFoldr xs (\y ys -> cons (f y) ys) nil

instance Apply List where
    la `apply` lb = listFoldr la (\l ls ->
        cons (f <$> lb) (ls `apply` lb))
        lb

instance Applicative List where
    pure x = cons x nil

instance Monoid (List a) where
    empty = nil
    combine = append

instance Alternative List where
    base = nil
    (<|>) = append

instance Foldable List where
    foldr c n xs = listFoldr xs c n
    filter = listFilter

instance Monad List where
    join xs = listFoldr xs append nil

-- * The free monad

class (Functor f, Monad m) => FreeMonad f m | m -> f where
    wrap :: f (m a) -> m a

liftF :: (FreeMonad f m) => f a -> m a
liftF = wrap . map return

newtype MT f m a = MT {
    runMT :: forall r.
             (a -> m r)         -- ^ terminal case
          -> (f (m r) -> m r)   -- ^ continue case
          -> m r
}

instance Functor (MT f m) where
    map f (MT k) = MT $ \a fr -> k (a . f) fr

instance Apply (MT f m) where
    MT fk `apply` MT ak = MT $ \b fr -> ak (\d ->
        fk (\e -> b (e d)) fr) fr

instance Applicative (MT f m) where
    pure a = MT $ \k _ -> k a

instance Monad (MT f m) where
    join (MT fk) = MT $ \u w -> fk (\d -> runMT d u w) w

instance Functor f => FreeMonad f (MT f m) where
    wrap f = MT $ \u w -> w (map (\(MT m) -> m u w) f)

type M f = MT f Box

runM :: Functor f
     => M f a
     -> (forall r. (a -> r) -> (f r -> r) -> r)
runM (MT m) = \u w -> unbox $ m (return . u) (return . w . map unbox)

data AskF r a = Ask (r -> a)

instance Functor (AskF r) where
    map f (Ask ra) = f . ra

type Ask r a = M (AskF r) a

class (Monad m) => MonadReader r m | m -> r where
    liftAsk :: Ask r a -> m a

ask :: (FreeMonad (AskF a) ((->) r), MonadReader r m) => m a
ask = liftAsk (liftF (Ask id))