{-# LANGUAGE ApplicativeDo #-}

module Handler.Common
  ( inventoryListing
  , itemForm
  , referenceListing
  , referenceForm
  , kinds
  , InventoryState(..)
  , ReferenceState(..)
  , FormState(..)
  , HasFormState(..)
  , stockSort, referenceSort
  , humanId
  ) 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

import Text.Julius (RawJS(..))

import qualified Codec.Crockford as Crockford (encode)
import Database.Persist.Sql (fromSqlKey)

humanId :: ItemId -> String
humanId = Crockford.encode . fromSqlKey

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
  
  let kt kWidget tWidget =
        [whamlet|
                <div .td>^{kWidget}
                <div .td>^{tWidget}
                |]
  ((kindRes, typeRes), typedKindWidget) <- typedKindField kt ((itemKind <$> proto), 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}
            ^{typedKindWidget}
            <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
  
  let kt kWidget tWidget =
        [whamlet|
                <div .td>^{kWidget}
                <div .td>^{tWidget}
                |]

  ((kindRes, typeRes), typedKindWidget) <- typedKindField kt ((referenceKind <$> proto), t)

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

  return . (referenceRes, ) $
    [whamlet|
            $newline never
            #{identView}
            ^{typedKindWidget}
            |]

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

typedKindField :: (Widget -> Widget -> Widget) -- ^ `\kindWidget typeWidget -> _`
               -> (Maybe Text, Maybe Text) -- ^ `(kindProto, typeProto)`
               -> MForm Handler ((FormResult Text, FormResult Text), Widget) -- ^ `((kindRes, typeRes), typedKindWidget)`
typedKindField collate (kindProto, typeProto) = do
  tOptionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
  let
    tAttrs = [ ("list", tOptionId)
             , ("autocomplete", "off")
             ]
  kOptionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique

  let
    kAttrs = [ ("list", kOptionId)
             , ("autocomplete", "off")
             ]

  (kindRes, kindView) <- mreq textField ("" { fsAttrs = kAttrs }) kindProto
  (typeRes, typeView) <- mreq textField ("" { fsAttrs = tAttrs }) typeProto

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

  return . ((kindRes, typeRes), ) $ do
    toWidget $
      [julius|
             $(function () {
               $("##{rawJS $ fvId kindView}").change(function () {
                 $.ajax({
                   url: '@{TypeR}',
                   type: 'GET',
                   contentType: 'application/json',
                   data: {
                     kind: $(this).val()
                   },
                   success: function (answer) {
                     $("##{rawJS $ fvId typeView}").val(answer);
                    typeChanged = false;
                    }
                 });
               }) ;
             });
             |]
    let
      kindWidget =
        [whamlet|
                $newline never
                ^{fvInput kindView}
                <datalist ##{kOptionId}>
                  $forall opt <- kOptions
                    <option value=#{opt}>
                |]
      typeWidget =
        [whamlet|
                $newline never
                ^{fvInput typeView}
                <datalist ##{tOptionId}>
                  $forall opt <- tOptions
                    <option value=#{opt}>
                |]
    collate kindWidget typeWidget

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

  return . Set.fromList $ 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