ProjectList.purs
module Aftok.ProjectList where
import Prelude
import Control.Monad.Trans.Class (lift)
import Data.Array (index)
import Data.Either (Either(..))
import Data.Foldable (any)
import Data.Maybe (Maybe(..), isNothing)
import Data.Newtype (unwrap)
import Data.Traversable (traverse_)
import Effect.Aff (Aff)
import Aftok.Types
( System
, ProjectId
, pidStr
)
import Aftok.Api.Types
( APIError
)
import Aftok.Api.Project
( Project'(..)
, Project
, listProjects
)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Core (ClassName(..))
import Halogen.HTML.Events as E
import Halogen.HTML.Properties as P
type Input
= Maybe ProjectId
data Query a
= ProjectCreated ProjectId a
data Output
= ProjectChange ProjectId
type Slot id
= H.Slot Query Output id
type CState
= { selectedPid :: Maybe ProjectId
, projects :: Array Project
}
data Action
= Initialize (Maybe ProjectId)
| Select Int
type Capability m
= { listProjects :: m (Either APIError (Array Project))
}
component ::
forall m.
Monad m =>
System m ->
Capability m ->
H.Component HH.HTML Query Input Output m
component console caps =
H.mkComponent
{ initialState
, render
, eval:
H.mkEval
$ H.defaultEval
{ handleAction = handleAction
, handleQuery = handleQuery
, initialize = Just (Initialize Nothing)
, receive = Just <<< Initialize
}
}
where
initialState :: Input -> CState
initialState input = { selectedPid: input, projects: [] }
render :: forall slots. CState -> H.ComponentHTML Action slots m
render st =
HH.div
[ P.classes (ClassName <$> [ "form-group" ]) ]
[ HH.label
[ P.classes (ClassName <$> [ "sr-only" ])
, P.for "projectSelect"
]
[ HH.text "Project" ]
, HH.select
[ P.classes (ClassName <$> [ "form-control" ])
, P.id_ "projectSelect"
, E.onSelectedIndexChange (Just <<< Select)
]
( [ HH.option [ P.selected (isNothing st.selectedPid), P.disabled true ] [ HH.text "Select a project" ] ]
<> map renderOption st.projects
)
]
where
renderOption (Project' p) =
HH.option
[ P.selected (any (p.projectId == _) st.selectedPid)
, P.value $ pidStr p.projectId
]
[ HH.text p.projectName ]
handleQuery :: forall slots a. Query a -> H.HalogenM CState Action slots Output m (Maybe a)
handleQuery = case _ of
ProjectCreated pid a -> do
handleAction (Initialize (Just pid))
pure (Just a)
handleAction :: forall slots. Action -> H.HalogenM CState Action slots Output m Unit
handleAction = case _ of
Initialize pidMay -> do
res <- lift caps.listProjects
case res of
Left _ -> lift <<< console.error $ "Could not retrieve project list."
Right projects -> H.modify_ (_ { projects = projects, selectedPid = pidMay })
Select i -> do
projects <- H.gets (_.projects)
traverse_ projectSelected (index projects (i - 1))
where
projectSelected p = do
let pid = (unwrap p).projectId
H.modify_ (_ { selectedPid = Just pid })
H.raise $ ProjectChange pid
apiCapability :: Capability Aff
apiCapability = { listProjects }
mockCapability :: forall m. Applicative m => Capability m
mockCapability = { listProjects: pure (Right []) }