Composing lenses

Main.purs

module Main where

import Prelude

import Concur.Core (Widget)
import Concur.React (HTML)
import Concur.React.DOM (text, div', br') as D
import Concur.React.Run (runWidgetInDom)
import Effect (Effect)
import Data.Lens (Lens', lens, over, setJust)
import Data.Lens.At (at)
import Data.Map (Map, empty, singleton)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Unfoldable (class Unfoldable, singleton) as Unfoldable

type Id = Int

type Animal =
  { name :: String
  , tagDb :: TagDb
  }

type Tags = Array String
type Ids = Array Id

type TagDb =
  { tagsById :: Map Id Tags
  , idsByTag :: Map String Ids
  }

emptyDb :: TagDb
emptyDb =
  { tagsById : empty
  , idsByTag : empty
  }

addTag :: Id -> String -> TagDb -> TagDb
addTag id tag db = 
  db
    # addTagTo id tag
    # addIdTo tag id

--- Helpers

addTagTo :: Id -> String -> TagDb -> TagDb
addTagTo id tag =
  over (_idTags id) $ appendOrCreate tag

addIdTo :: String -> Id -> TagDb -> TagDb
addIdTo tag id = 
  over (_tagIds tag) $ appendOrCreate id

-- I can't find a Lens function that does this for me. 
appendOrCreate :: forall a f. Monoid (f a) => Unfoldable.Unfoldable f =>
                  a -> Maybe (f a) -> Maybe (f a)
appendOrCreate new =
  fromMaybe mempty 
    >>> (_ <> Unfoldable.singleton new)
    >>> Just

-- Lenses

_tagDb :: Lens' (Maybe Animal) (Maybe TagDb)
_tagDb = lens (map _.tagDb) $ \ ma mt -> 
            (_ { tagDb = _ }) <$> ma <*> mt

_tagsById :: Lens' TagDb (Map Id Tags)
_tagsById =
  lens  _.tagsById $ _ { tagsById = _ } 

_idsByTag :: Lens' TagDb (Map String Ids)
_idsByTag =
  lens _.idsByTag $ _ { idsByTag = _ }

_idTags :: Id -> Lens' TagDb (Maybe (Array String))
_idTags id =
  _tagsById <<< at id

_tagIds :: String -> Lens' TagDb (Maybe (Array Id))
_tagIds tag =
  _idsByTag <<< at tag

named :: String -> Id -> Animal
named name id =
  { name, tagDb: emptyDb }

type Model =
  { animals :: Map Id Animal
  }

initialModel :: Model
initialModel = (\id -> addAnimalTag id "mare"
  { animals : singleton id $ named "Genesis" id
  })  3838

addAnimalTag :: Id -> String -> Model -> Model
addAnimalTag id tag =
  over (_oneAnimal id <<< _tagDb) (map $ addTag id tag)

addAnimal :: Id -> String -> Model -> Model
addAnimal id name =
  setJust (_oneAnimal id) (named name id)

_animals :: Lens' Model (Map Id Animal) 
_animals =
  lens _.animals $ _ { animals = _ }

_oneAnimal :: Id -> Lens' Model (Maybe Animal)
_oneAnimal id =
  _animals <<< at id 

data Action
  = AddAnimal Id String
  | AddTag Id String
    
update :: Model -> Action -> Model

update model (AddAnimal animalId name) =
  addAnimal animalId name model

update model (AddTag animalId tag) =
  addAnimalTag animalId tag model
  
exerciseWidget :: forall a. Widget HTML a
exerciseWidget = 
  D.div' $ (pure <<< (_ <> D.br')) =<<
    [ D.text $ show $ initialModel
    , D.br'
    , D.text $ show $ update initialModel (AddAnimal 1 "Bossy")
    , D.br'
    , D.text $ show $ update initialModel (AddTag 3838 "skittish")
    , D.br'
    , D.text $ show $ update 
                    (update initialModel (AddTag 3838 "skittish"))
                    (AddAnimal 1 "Bossy")
    ]

main :: Effect Unit
main = do
  runWidgetInDom "main" exerciseWidget