annotated.hs

{-# LANGUAGE DeriveFunctor #-}

import Data.Monoid
import Control.Monad
import Control.Applicative

-- | An applicative functor `f` over a base type `b` that is "annotated" by a
-- | monoidal type `a`.
data Ann a f b = Ann a (f b)
  deriving (Eq, Ord, Show, Functor)

instance (Monoid a, Applicative f) => Applicative (Ann a f) where
  pure x = Ann mempty (pure x)
  (Ann a1 f1) <*> (Ann a2 f2) = Ann (a1 <> a2) (f1 <*> f2)

-- | Extract the monoidal part of the annotated functor
annotation :: Ann a f b -> a
annotation (Ann a _) = a

-- | Extract the functorial part of the annotated functor
content :: Ann a f b -> f b
content (Ann _ fb) = fb

-- | Append a monoidal value to the annotated functor
annotate :: Monoid a => Ann a f b -> a -> Ann a f b
annotate (Ann a1 f) a2 = Ann (a1 <> a2) f

main :: IO ()
main = do

  let
    x = pure 3 `annotate` ["Defining x"]
    y = pure 5 `annotate` ["Defining y"]
    z = liftA2 (*) x y `annotate` ["Multiplying"]

  print $ content z    == Just 15
  print $ annotation z == ["Defining x", "Defining y", "Multiplying"]