haskell: (free) applicative + monad

scratch.hs

-- [[file:~/Dropbox/Public/papers/pl/haskell/free/free-applicative-functors_capriotti-kaposi.org::*%5B%5Bhttp://hackage.haskell.org/package/free-4.7.1/docs/Control-Monad-Free.html%5D%5BFree%20monad%5D%5D][su/haskell/free/FreeAL/modulo]]

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

import Prelude hiding (Monad, return, fail, (>>=), div)
import qualified Prelude
import Control.Applicative
import Control.Monad
-- monad preamble

import Data.Monoid

-- | definition of a free applicative
-- FIXME: verify applicative laws hold true
data Ap f a where
  -- | 'Pure' is like the no-op constructor. in a monoid this would be like the
  -- 'mempty' i.e., the identity 'effect'
  Pure :: a -> Ap f a
  -- | 'Ap' constructor corresponds to <*>. however, note that 'Ap f' by itself
  -- can encode is that of the Identity (via 'Pure'). it is for this reason that
  -- we rely on the second argument to be an 'f a', i.e., we depend on the set
  -- of effects that the Functor defines
  Ap :: Ap f (a -> b) -> f a -> Ap f b

-- | 'evaluating' a free applicative. the idea is that provided we have some
-- natural transformation from the inner Functor to an Applicative, then the
-- semantics of that natural transformation are used to interpret the Free
-- Applicative. the benefit is that we can define the Free Applicative instance
-- once, and then evaluate it multiple times using different interpretations
runAp :: Applicative g
         => Functor f
         => (forall x. f x -> g x) -> Ap f a -> g a
runAp u = retractAp . hoistAp u

-- | Given a natural transformation from @f@ to @g@ this gives a monoidal
-- natural transformation from @Ap f@ to @Ap g@.
hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b
hoistAp _ (Pure a) = Pure a
hoistAp f (Ap x y) = Ap (hoistAp f x) (f y)

-- | Interprets the free applicative functor over f using the semantics for
--   `pure` and `<*>` given by the Applicative instance for f.
--
--   prop> retractApp == runAp id
retractAp :: Applicative f => Ap f a -> f a
retractAp (Pure a) = pure a
retractAp (Ap x y) = y <**> retractAp x

-- | A version of 'lift' that can be used with just a 'Functor' for @f@.
liftAp :: f a -> Ap f a
liftAp = Ap (Pure id)

-- | Functor instance for free applicative
instance (Functor f) => Functor (Ap f) where
  -- when second argument to fmap doesn't have any meta-information, proceed by
  -- ignoring it
  fmap g (Pure a) = Pure (g a)
  -- when the second arg does have meta-information, keep it aside (bit by bit,
  -- by recursing on second arg) till there's none left, and then applying the
  -- function on the contained value (the first arg of Ap)
  fmap g (Ap h y) = Ap ((g .) <$> h) y
  -- g :: a -> b
  -- (Ap h y) :: Ap f a
  -- h :: Ap f (c -> a)
  -- y :: f c
  -- (.) :: (2 -> 3) -> (1 -> 2) -> 1 -> 3
  -- (g .) :: (1 -> a) -> 1 -> b
  -- (g .) <$> :: Ap f (1 -> a) -> Ap f (1 -> b)
  -- (g .) <$> h :: Ap f (c -> b)
  -- Ap ((g .) <$> h) y :: Ap f b

-- | Applicative instance for free applicative
instance (Functor f) => Applicative (Ap f) where
  -- pure :: a -> v a
  pure = Pure

  -- when there's no meta-information contained in partial computation, proceed
  -- by ignoring it
  (Pure h) <*> y = fmap h y
  -- when partial computation contains some meta-information, proceed by moving
  -- it aside and add on the meta-information contained in the passed in
  -- argument at the deepest level. NB: this doesn't *generate* any new meta
  -- information (recombining prior meta-information does not qualify)
  (Ap h y) <*> z = Ap (flip <$> h <*> z) y
  -- (Ap h y) :: Ap f (a -> b)
  -- h :: Ap f (c -> a -> b)
  -- y :: f c
  -- z :: Ap f a
  -- flip :: (1 -> 2 -> 3) -> 2 -> 1 -> 3
  -- flip <$> :: Ap f (1 -> 2 -> 3) -> Ap f (2 -> 1 -> 3)
  -- flip <$> h :: Ap f (a -> c -> b)
  -- flip <$> h <*> z :: Ap f (c -> b)
  -- Ap (flip <$> h <*> z) y :: Ap f b

-- | datatype for optional failure
-- | datatype for optional failure
data Option a = None  -- ^ failure case
              | Some a -- ^ regular case
              deriving (Eq, Read, Show, Ord)

-- | the functor instance for 'Option'. i.e., we need to define a way to apply a
-- function in a way that doesn't interfere with the 'meta-information' we're
-- tracking (i.e., failure state)
instance Functor Option where
  fmap _ None = None
  fmap f (Some a) = Some (f a)

-- | Let's decouple the meta information we're tracking
data ResultState = NoValue
                   | SomeValue
                   deriving (Eq, Read, Show, Ord)

-- | semigroup with identity and zero elements. this is more powerful than a
-- monoid
class SGIZ a where
  sgI :: a
  sgZ :: a
  sgOp :: a -> a -> a

-- | extract 'Monoid' from an SGIZ
-- TODO: define SGIZ using 'free' semantics
instance (SGIZ f) => Monoid f where
  mempty = sgI
  mappend = sgOp

-- | Now this information that we're tracking, actually induces a 'Monoid'
-- instance. Actually it induces two different monoids, with different
-- semantics (depending on the identity element you choose). for the 'failure'
-- semantics we have the following:
instance SGIZ ResultState where
  sgI = SomeValue -- ^ this is the identity element
  sgZ = NoValue -- ^ this is the 'absorbing' element
  sgOp = min -- ^ 'min' semantics, i.e., fail if any one does

-- | Natural transformation from Functor Option to Applicative (courtesy that
-- 'ResultState' is a 'Monoid')
option2Tuple :: Option a -> (ResultState, a)
option2Tuple (Some a) = (SomeValue, a)
option2Tuple None = (NoValue, undefined) -- ^ since the value is missing we have
-- to use this

-- | inverse transformation
tuple2Option :: (ResultState, a) -> Option a
tuple2Option (NoValue, _) = None
tuple2Option (SomeValue, x) = Some x

-- | 'run' an Applicative Option computation
runOptionAp :: Ap Option a -> Option a
runOptionAp = tuple2Option . runAp option2Tuple

-- | lift a binary function into 'Applicative' world
option2Ap2 :: (a -> b -> c)
              -> Option a
              -> Option b
              -> Ap Option c
option2Ap2 f ox oy = (Ap (Ap (Pure f) ox) oy)

-- | basics for modulo arithmetic
data Z3 = Zero | One | Two deriving (Eq, Read, Show, Ord)

-- | view to go in
inZ3 :: Integer -> Z3
inZ3 x = case (x `mod` 3) of
  0 -> Zero
  1 -> One
  2 -> Two
-- | view to go out to regular integers
outZ3 :: Z3 -> Integer
outZ3 Zero = 0
outZ3 One = 1
outZ3 Two = 2

-- | modulo arithmetic functions (without division)
class ModArithSym repr where
  lit :: Integer -> repr
  add :: repr -> repr -> repr
  mul :: repr -> repr -> repr
  sub :: repr -> repr -> repr
-- | the interpretor for semantics in Z3
instance ModArithSym Z3 where
  lit = inZ3
  add x y = lit $ (outZ3 x) + (outZ3 y)
  mul x y = lit $ (outZ3 x) * (outZ3 y)
  sub x y = lit $ (outZ3 x) - (outZ3 y)
-- | evaluate with the Z3 interpreter (the type annotation tells the system
-- where to look for the implementation)
eval :: Z3 -> Z3
eval = id

ta1 :: ModArithSym repr => repr
ta1 = sub (add (lit 3) (lit 5)) (lit 21)
-- eval ta1 = Two

tl1 :: ModArithSym repr
       => repr -> repr -> repr -> repr
tl1 x y z = sub (add x y) z

tl2 :: ModArithSym repr
       => Integer -> Integer -> Integer -> repr
tl2 x y z = tl1 (lit x) (lit y) (lit z)
-- eval $ tl2 3 5 21 = eval ta1 = Two

-- | error-handling interpretor
instance (ModArithSym repr) => ModArithSym (Ap Option repr) where
  lit = Pure . lit
  add aox aoy = option2Ap2 add (runOptionAp aox) (runOptionAp aoy)
  mul aox aoy = option2Ap2 mul (runOptionAp aox) (runOptionAp aoy)
  sub aox aoy = option2Ap2 sub (runOptionAp aox) (runOptionAp aoy)
-- | run the error-handling interpretor
evalAp :: Ap Option Z3 -> Ap Option Z3
evalAp = id

tla2 :: (ModArithSym a)
        => Option Integer
        -> Option Integer
        -> Option Integer
        -> Ap Option a
tla2 ox oy oz = tl1 (o2ao ox) (o2ao oy) (o2ao oz)
  where
    o2ao = liftAp . fmap lit
-- runOptionAp . evalAp $ tla2 (Some 3) (Some 5) (Some 21) = Some Two
-- runOptionAp . evalAp $ tla2 (Some 3) (None) (Some 21) = None


data Free f a = Return a
                | Free (f (Free f a))

-- | 'evaluating' a Free monad (equivalent of 'runAp')
runFree :: (Functor g, Monad g)
       => Functor f
       => (forall a. f a -> g a)
       -> Free f b
       -> g b
runFree u = retract . hoistFree u

-- | Lift a natural transformation from @f@ to @g@ into a natural transformation
-- from @'FreeT' f@ to @'FreeT' g@.
hoistFree :: Functor g
             => (forall a. f a -> g a)
             -> Free f b
             -> Free g b
hoistFree _ (Return a)  = Return a
hoistFree f (Free as) = Free (hoistFree f <$> f as)


-- |
-- 'retract' is the left inverse of 'lift' and 'liftF'
--
-- @
-- 'retract' . 'lift' = 'id'
-- 'retract' . 'liftF' = 'id'
-- @
retract :: Monad f => Free f a -> f a
retract (Return a) = return a
retract (Free as) = as >>= retract

-- | inject 'f' into 'Free f'
liftFree :: (Functor f) => f a -> Free f a
liftFree = Free . (fmap Return)

instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where
  Return a == Return b = a == b
  Free fa == Free fb = fa == fb
  _ == _ = False

instance (Ord (f (Free f a)), Ord a) => Ord (Free f a) where
  Return a `compare` Return b = a `compare` b
  Return _ `compare` Free _ = LT
  Free _ `compare` Return _ = GT
  Free fa `compare` Free fb = fa `compare` fb

instance (Show (f (Free f a)), Show a) => Show (Free f a) where
  showsPrec d (Return a) = showParen (d > 10) $
                         showString "Return " . showsPrec 11 a
  showsPrec d (Free m) = showParen (d > 10) $
                         showString "Free " . showsPrec 11 m

instance (Read (f (Free f a)), Read a) => Read (Free f a) where
  readsPrec d r = readParen (d > 10)
                  (\r' -> [ (Return m, t)
                          | ("Return", s) <- lex r'
                          , (m, t) <- readsPrec 11 s]) r
                  ++ readParen (d > 10)
                  (\r' -> [ (Free m, t)
                          | ("Free", s) <- lex r'
                          , (m, t) <- readsPrec 11 s]) r
instance Functor f => Functor (Free f) where
  -- fmap :: (a -> b) -> v a -> v b
  -- fmap = (<$>)
  fmap = fix hmap where
    hmap :: (Functor f)
            => ((a -> b) -> Free f a -> Free f b)
            -> (a -> b)
            -> Free f a
            -> Free f b
    -- when argument has no meta-information, ignore it
    hmap _ f (Return a) = Return (f a)
    -- when argument has meta-information, proceed by peeling it all out, and
    -- applying function to the contained value
    hmap self f (Free fa) = Free (self f <$> fa)
    -- self f :: Free f a -> Free f b
    -- fa :: f (Free f a)
    -- self f <$> :: f (Free f a) -> f (Free f b)
    -- self f <$> fa :: f (Free f b)

instance Functor f => Applicative (Free f) where
  -- pure :: a -> v a
  pure = Return
  -- (<*>) :: v (a -> b) -> v a -> v b
  (<*>) = fix app where
    app :: (Functor f)
           => (Free f (a -> b) -> Free f a -> Free f b)
           -> Free f (a -> b)
           -> Free f a
           -> Free f b
    -- when partial computation has no meta-information proceed by ignoring it
    app _ (Return a) (Return b) = Return $ a b
    app _ (Return a) (Free mb) = Free $ fmap a <$> mb
    -- when partial-computation has meta-information, proceed by peeling out all
    -- the meta-information and inserting meta-information generated by 'app' at
    -- the bottom of the stack (using recursion)
    app self (Free ma) b = Free $ (`self` b) <$> ma
    -- ma :: f (Free f (a -> b))
    -- b :: Free f a
    -- (`self` b) :: Free f (a -> b) -> Free f b
    -- (`self` b) <$> :: f (Free f (a -> b)) -> f (Free f b)
    -- (`self` b) <$> ma :: f (Free f b)

instance Functor f => Monad (Free f) where
  -- return :: a -> v a
  return = Return
  -- (>>=) :: v a -> (a -> v b) -> v b
  (>>=) = fix rbind where
    rbind :: (Functor f)
             => (Free f a -> (a -> Free f b) -> Free f b)
             -> Free f a
             -> (a -> Free f b)
             -> Free f b
    -- when first arg has no meta-information, proceed by ignoring it
    rbind _ (Return a) g = g a
    -- when first arg, does have meta-information, proceed by peeling it all out
    -- to the point where it can be ignored, and adding the meta-information
    -- *generated* as a result of 'rbind' at the bottom of the stack
    rbind self (Free m) g = Free (fmap (`self` g) m)
    -- m :: f (Free f a)
    -- g :: a -> (Free f b)
    -- `self` :: (a -> Free f b) -> Free f a -> Free f b
    -- (`self` g) :: Free f a -> Free f b
    -- fmap (`self` g) = f (Free f a) -> f (Free f b)
    -- fmap (`self` g) m = f (Free f b)

-- | 'run' a 'Free' computation
runOptionFree :: Free Option a -> Option a
runOptionFree = tuple2Option . runFree option2Tuple

-- | interpret 'Ap Option' as 'Free Option'
optionAp2Free :: Ap Option a -> Free Option a
optionAp2Free = liftFree . runOptionAp

-- | interpret 'Free Option' as 'Ap Option'
optionFree2Ap :: Free Option a -> Ap Option a
optionFree2Ap = liftAp . runOptionFree

-- | monad instance for SGIZ
-- TODO: define this in an incremental way, i.e., still be able to define Monad
-- instances if there isn't an 'absorbing' element 'sgZ'
instance (SGIZ f, Eq f) => Monad ((,) f) where
  return x = (sgI, x)
  fa >>= g = case fa of
    (meta1, _) | (meta1 == sgZ) -> (sgZ, undefined)
    (meta1, x) -> case g x of
      (meta2, y) -> ((mappend meta1 meta2), y)

-- | let's add 'div' operation to our language
class ModDivSym repr where
  div :: repr -> repr -> repr

-- | an interpretor providing semantics for 'div'
instance ModDivSym Z3 where
  div x y = lit $ (outZ3 x) * (inverse y)
    where
      inverse One = 1
      inverse Two = 2

-- | extend 'div' semantics to gracefully handle:
--
-- * error-prone inputs
-- * error-prone computation
instance ModDivSym (Free Option Z3) where
  div fx fy = do
    x <- fx
    y <- fy
    liftFree $ safeDiv x y
    where
      safeDiv _ Zero = None
      safeDiv x y = Some (div x y)
-- | run exception-handling interpretor
evalFree :: Free Option Z3 -> Free Option Z3
evalFree = id

-- | provide exception-handling interpretor for ModArithSym
-- TODO: abstract over 'Option'
instance (ModArithSym (Ap Option repr)) => ModArithSym (Free Option repr) where
  lit = optionAp2Free . lit
  add fx fy = optionAp2Free $ add (optionFree2Ap fx) (optionFree2Ap fy)
  mul fx fy = optionAp2Free $ mul (optionFree2Ap fx) (optionFree2Ap fy)
  sub fx fy = optionAp2Free $ sub (optionFree2Ap fx) (optionFree2Ap fy)


tlm1 :: (ModDivSym repr, ModArithSym repr)
        => repr -> repr -> repr -> repr -> repr
tlm1 x y z w = div (tl1 x y z) w

tlm2 :: (ModDivSym repr, ModArithSym repr)
        => Integer -> Integer -> Integer -> Integer -> repr
tlm2 x y z w = tlm1 (lit x) (lit y) (lit z) (lit w)
-- eval $ tlm2 3 5 21 2 = One

tlfm2 :: (ModDivSym (Free Option b), ModArithSym b)
         => Option Integer
         -> Option Integer
         -> Option Integer
         -> Option Integer
         -> Free Option b
tlfm2 ox oy oz ow = do
  x <- liftFree ox
  y <- liftFree oy
  z <- liftFree oz
  w <- liftFree ow
  tlm2 x y z w
-- runOptionFree . evalFree $ tlfm2 (Some 3) (Some 5) (Some 21) (Some 1) = Some Two
-- runOptionFree . evalFree $ tlfm2 (Some 3) (Some 5) (Some 21) (Some 0) = None
-- runOptionFree . evalFree $ tlfm2 (Some 3) (Some 5) (None) (Some 0) = None

-- | define fixpoint operator
fix :: (t -> t) -> t
fix f = f (fix f)

-- su/haskell/free/FreeAL/modulo ends here