"Real World"-ish recursion schemes example

Task.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module Dagny.Task where

import Control.Lens (Lens', Getter, folded, lens, makePrisms, makeLenses, set, view)
import Control.Lens.Fold (toListOf)
import Control.Monad.State (get, put, evalState)
import Control.Comonad.Trans.Env (EnvT(..), ask, local, lowerEnvT)
import Data.Aeson
import Data.Aeson.TH
import Data.Functor.Foldable
import Data.List as L
import Data.List.NonEmpty
import Data.Set as S
import Data.Map.Strict as M
import Data.Semigroup
import Data.Text as T
import Data.Time.Clock
import Data.UUID
import Data.Validation (toEither, fromEither)
import GHC.Generics

newtype TaskId = TaskId UUID
makePrisms ''TaskId
$(deriveJSON defaultOptions ''TaskId)

data TaskState
  = Created 
  | InProgress
  | Stopped
  | Completed
  deriving (Generic, Show)
makePrisms ''TaskState

newtype TaskTag = TaskTag [Text] deriving (Show, Eq, Ord, Generic)
makePrisms ''TaskTag

data TaskF n a = TaskF
  { _title :: Text
  , _description :: Text
  , _dependsOn :: [a]
  , _state :: TaskState
  , _tags :: Set TaskTag
  , _estimate :: n
  } deriving (Functor, Foldable, Traversable, Generic)
makeLenses ''TaskF

-- | Task DAG 
type Task n = Fix (TaskF n)

-- | Task DAG where each node is annotated with an identifier
type IdTask a n = Fix (EnvT a (TaskF n))

unIdTask :: (Ord a) => IdTask a n -> Map a (TaskF n a)
unIdTask = 
  let stripBranches :: TaskF n (IdTask a n) -> TaskF n a
      stripBranches tf = ask . unfix <$> tf

      unionDeps :: (Ord a) => TaskF n (Map a (TaskF n a)) -> Map a (TaskF n a)
      unionDeps = M.unions . _dependsOn
  
      palg (EnvT a tf) = M.insert a (stripBranches (fst <$> tf)) (unionDeps (snd <$> tf))
  in  para palg
 
idTask :: (Ord a) => Map a (TaskF n a) -> a -> Either (NonEmpty a) (IdTask a n)
idTask m ref = do
  root <- maybe (Left $ ref :| []) (Right . EnvT ref) (M.lookup ref m)
  embed <$> (toEither $ traverse (fromEither . idTask m) root)

_getEnv :: (Functor f) => Lens' (Fix (EnvT a f)) a 
_getEnv = lens (ask . unfix) (\e a -> embed $ local (const a) (unfix e))

_getValue :: (Functor f) => Lens' (Fix (EnvT a f)) (f (Fix (EnvT a f)))
_getValue = lens (lowerEnvT . unfix) (\e fa -> embed $ EnvT (ask $ unfix e) fa)

spanningTree :: (Ord a) => Getter t a -> Lens' t [t] -> t -> t
spanningTree idx deps t =
  evalState (go t) S.empty 
    where 
      go t' = do
        seen <- get
        let retained = L.filter (not . (flip S.member) seen . view idx) (view deps t') 
        put (S.union seen . S.fromList $ toListOf (folded . idx) retained)
        pruned <- traverse go retained
        pure (set deps pruned t')

taskCost :: (Semigroup n, Ord a) => IdTask a n -> n
taskCost t = 
  let pruned = spanningTree _getEnv (_getValue . dependsOn) t
  in  cata (\t' -> sconcat (view estimate (lowerEnvT t') :| view dependsOn (lowerEnvT t'))) pruned

data TaskAction n a r where
  CreateTask      :: TaskF n a -> TaskAction n a a
  SetTitle        :: a -> Text -> TaskAction n a ()
  SetDescription  :: a -> Text -> TaskAction n a ()
  SetDependsOn    :: a -> [a] -> TaskAction n a ()
  SetState        :: a -> TaskState -> TaskAction n a ()
  SetTags         :: a -> Set TaskTag -> TaskAction n a ()
  SetEstimate     :: a -> n -> TaskAction n a ()

data TaskEvent u n a r = TaskEvent
  { _initiatedBy :: u
  , _eventTime :: UTCTime
  , _action :: TaskAction n a r
  }
makeLenses ''TaskEvent