Main.hs

{-# LANGUAGE TypeFamilies, ScopedTypeVariables, OverloadedStrings, TemplateHaskell, RankNTypes #-}
module Main where

import Data.Map (Map(..), empty)
import Control.Lens
import Data.Monoid (mempty)
import Data.Text (Text(..))
import Control.Applicative (pure)


-- We'll start by making an animal
-- with room for helpful descriptors.

data Animal = A { _name :: Text
                , _call :: Text
                , _tags :: [Text]
                } deriving (Show)

-- We need lenses. You'll see why.
makeLenses ''Animal

-- Now let's get a nice collection for our spaceship.
menagerie :: [Animal]
menagerie = [ A "Dog" "woof" ["friendly", "stinky", "snuggly"]
            , A "Cat" "meow" ["stinky", "snuggly"]
            , A "Tapeworm" "slurp" ["friendly", "unscented", "snuggly"]
            , A "Human" "Notice me!" ["dangerous"]
            , A "Wolf" "woof" ["stinky", "dangerous"]
            ]

-- Of course, if folks are viewing our menagier we'd like to categorize
-- our confsing array of Terran animals. We'd also like to make a sound
-- guidebook, so alien kids have something to bring home.

-- Both of these involve the creation of a map from a key, either one of
-- many tags or from a cry. We can use lenses to make this task easier.
-- Firstly, let's assume given a getting lens and a menagerie, we can make a guidebook.

guidebook :: Ord a => Getter Animal [a] -> [Animal] -> Map a [Animal]
-- Or generically:
-- guidebook :: (Ord a, Foldable f, Applicative f, Monoid (f a)) =>
--              Getter r (f a) -> f r -> Map a (f r) 
guidebook lens animals = foldr step empty animals
  where step animal book = foldr (istep animal) book (view lens animal)
        istep v k m      = m & at k <>~ Just (pure v) -- pure :: a -> f a ([] in this case)
-- This is a bit tricky since it's a double fold, but the real
-- interesting bit is the `istep` part where we step inside the
-- list of tags and start updating the dictionary we've been passed
-- in:
--     istep v k m = m & at k <>~ Just [v]
--
-- This innter step takes our Map m, and updates it with the lens "at k",
-- monoidally appending and setting (<>~ operator) the current animal to the list.
-- If no value is found, the existing value is used (by virtue of list
-- being a monoid).
-- 
-- In the world of ruby we might write that as:
-- istep = lambda { |x k m| m[k] ||= [] ; m[k] += [x] }

main :: IO ()
main = do
  putStrLn "Welcome to the Menagerie!"
  -- We give our guidebook function the tags lens.
  let tagBook = guidebook tags menagerie

  putStrLn $ show tagBook

  -- What's kinda cool about this is that, thanks to the power of lenses,
  -- we can actually reuse the guidebook call for the book of calls, without 
  -- premeditation. The call field isn't a list, so it may seem surprising, 
  -- but we have specified we have a "Getter of a list of a's from an Animal'". 
  -- So all we need to do is use a function that wraps a value as a list and
  -- bam, we've converted it.

  -- The simplest and most future proof way I can think of to go `a -> [a]`.
  -- There is no "singleton" function for single-kind data structures like
  -- this because you can think of it as `a -> f a`, which is `pure` for
  -- any Applicative or Monad. If we ever do change the type of our calls
  -- or the structures we store (and make the type signature of guidebook
  -- more generic) then this code won't be an issue. That's defensive with
  -- lenses, as even profunctor lenses sometimes give somewhat obtuse type
  -- errors.
  let callBook = guidebook (call . to pure) menagerie
  putStrLn $ show callBook

I suppose we could also use these lenses to write back to the animals and update copies of guidebooks for users. That might be a fun way to extend the exercise.