{-# LANGUAGE ApplicativeDo #-}

module Handler.Common
  ( inventoryListing
  , itemForm
  , referenceListing
  , referenceForm
  , kinds
  , InventoryState(..)
  , ReferenceState(..)
  , FormState(..)
  , HasFormState(..)
  , stockSort, referenceSort
  ) where

import Import

import Data.Unique

import qualified Data.Text as Text

import Data.Set (Set)
import qualified Data.Set as Set

import Control.Lens

import Handler.Common.Types

dayFormat :: Day -> String
dayFormat = formatTime defaultTimeLocale "%e. %b %y"

itemForm :: Maybe Item -- ^ Update existing item or insert new?
         -> Html -> MForm Handler (FormResult (WithType Item), Widget)
itemForm proto identView = do
  today <- utctDay <$> liftIO getCurrentTime

  t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto
  
  (kindRes, kindWidget) <- kindField $ itemKind <$> proto
  (typeRes, typeWidget) <- typeField $ t
  (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
  (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
  (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"

  let itemRes = do
        itemKind <- kindRes
        itemBought <- boughtRes
        itemExpires <- expiresRes
        itemOpened <- openedRes
        t <- typeRes
        return $ Item{ itemNormKind = normalizeKind itemKind, ..} `WithType` t

  return . (itemRes, ) $
    [whamlet|
            $newline never
            #{identView}
            <div .td>^{kindWidget}
            <div .td>^{typeWidget}
            <div .td>^{boughtWidget}
            <div .td>^{expiresWidget}
            <div .td>^{openedWidget}
            |]
  where
    dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget)
    dayForm proto label = do
      today <- utctDay <$> liftIO getCurrentTime

      checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
      
      (fmap (fromMaybe False) -> isNothingRes, isNothingView) <-
        mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto
      (dayRes, dayView) <-
        mreq dayField "" . Just . fromMaybe today $ join proto

      let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes
      return . (res, ) $ do
        [whamlet|
                $newline never
                <div .table>
                  <div .tr>
                    <label for=#{checkboxId} .checkbox .td>
                      ^{fvInput isNothingView}
                      <span>
                        #{label}
                  <div .tr>
                    <div .td .dayInput>^{fvInput dayView}
                |]

inventoryListing :: InventoryState -> Widget
inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")

referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
              -> Html -> MForm Handler (FormResult (WithType Reference), Widget)
referenceForm proto identView = do
  t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto

  (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
  (typeRes, typeWidget) <- typeField $ t

  let referenceRes = do
        referenceKind <- kindRes
        t <- typeRes
        return $ Reference{ referenceNormKind = normalizeKind referenceKind, .. } `WithType` t

  return . (referenceRes, ) $
    [whamlet|
            $newline never
            #{identView}
            <div .td>^{kindWidget}
            <div .td>^{typeWidget}
            |]

referenceListing :: ReferenceState -> Widget
referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing")

kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
kindField proto = do
  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique

  let
    attrs = [ ("list", optionId)
            , ("autocomplete", "off")
            ]
  
  (kindRes, kindView) <- mreq textField ("" { fsAttrs = attrs }) proto

  options <- lift kinds

  return . (kindRes, ) $
    [whamlet|
            $newline never
            ^{fvInput kindView}
            <datalist ##{optionId}>
              $forall opt <- options
                <option value=#{opt}>
            |]

typeField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
typeField proto = do
  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique

  let
    attrs = [ ("list", optionId)
            , ("autocomplete", "off")
            ]

  (typeRes, typeView) <- mreq textField ("" { fsAttrs = attrs }) proto

  (Set.fromList . map (kindType . entityVal) -> options) <- lift . runDB $ selectList [] []

  return . (typeRes, ) $
    [whamlet|
            $newline never
            ^{fvInput typeView}
            <datalist ##{optionId}>
              $forall opt <- Set.toList options
                <option value=#{opt}>
            |]

kinds :: Handler [Text]
kinds = do
  stock <- runDB $ selectList [] []
  reference <- runDB $ selectList [] []

  return $ concat
    [ [ itemKind | Entity _ Item{..} <- stock ]
    , [ referenceKind | Entity _ Reference{..} <- reference ]
    ]

type Sort a = a -> a

stockSort :: Sort [WithType (Entity Item)]
stockSort = concat . map (sortOn $ entityVal . typedVal) . sortGroups . group
  where
    group = groupBy ((==) `on` valType) . sortOn valType
    sortGroups = sortOn (fmap minimum . fromNullable . map (entityVal . typedVal))

referenceSort :: Sort [WithType (Entity Reference)]
referenceSort = sortBy referenceOrdering
  where
    referenceOrdering (Entity _ refA `WithType` refAType) (Entity _ refB `WithType` refBType) = compare refAType refBType <> compare refA refB