lens-at.hs

#!/usr/bin/env stack
{-
  stack
  script
  --resolver lts-11.0
  --ghc-options -Wall
-}

{-# LANGUAGE RankNTypes #-}

import Control.Lens
import Data.Map

data Animal =
  Animal
  { tags :: Int
  } deriving (Show)

data Model =
  Model
  { animals :: Map String Animal
  } deriving (Show)

model :: Model
model =
  Model 
  { animals = fromList 
                [ ("jake", Animal { tags = 4 })
                , ("skitter", Animal { tags = 6 })
                ]
  }

modelToAnimals :: Lens' Model (Map String Animal)
modelToAnimals = lens animals (\oldModel newAnimals -> oldModel { animals = newAnimals })

animalToTags :: Lens' Animal Int
animalToTags = lens tags (\oldAnimal newTags -> oldAnimal { tags = newTags })

modelToTags :: String -> Traversal' Model Int
modelToTags name = modelToAnimals . at name . _Just . animalToTags

jake :: Maybe Int
jake = preview (modelToTags "jake") model

main :: IO ()
main = print jake -- Just 4