{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}


module Types (module Types, module Types.Prim) where


import           Control.Lens                      as Lens hiding (Context)
import           Control.Lens.TH                   ()
import           Control.Monad.Except
import           Data.Aeson
import           Data.Function
import           Data.Maybe
import           Data.Proxy
import           Data.Text
import           Database.Beam

import           Servant.API                       hiding (Description)
import           Shpadoinkle
import qualified Shpadoinkle.Html                  as H
import           Shpadoinkle.Router
import           Shpadoinkle.Widgets.Form.Dropdown as Dropdown
import           Shpadoinkle.Widgets.Table         as Table
import           Shpadoinkle.Widgets.Types
import           Shpadoinkle.Widgets.Validation

import           Types.Prim


data SpaceCraftT f = SpaceCraft
  { _identity    :: Columnar f SpaceCraftId
  , _sku         :: Columnar f SKU
  , _description :: Columnar (Nullable f) Description
  , _serial      :: Columnar f SerialNumber
  , _squadron    :: Columnar f Squadron
  , _operable    :: Columnar f Operable
  } deriving (Generic, Beamable)


instance Table SpaceCraftT where
  newtype PrimaryKey SpaceCraftT f = SpaceCraftKey (Columnar f SpaceCraftId) deriving (Generic) deriving anyclass (Beamable)
  primaryKey = SpaceCraftKey . _identity


type SpaceCraft = SpaceCraftT Identity
deriving instance Eq SpaceCraft
deriving instance Ord SpaceCraft
deriving instance Show SpaceCraft
deriving instance ToJSON SpaceCraft
deriving instance FromJSON SpaceCraft


makeFieldsNoPrefix ''SpaceCraftT


newtype DB f = DB { _roster :: f (TableEntity SpaceCraftT) } deriving (Generic) deriving anyclass (Database be)


db :: DatabaseSettings be DB
db = defaultDbSettings


data SpaceCraftUpdate s = SpaceCraftUpdate
  { _sku         :: Field s Text Input SKU
  , _description :: Field s Text Input (Maybe Description)
  , _serial      :: Field s Text Input SerialNumber
  , _squadron    :: Field s Text (Dropdown 'One) Squadron
  , _operable    :: Field s Text (Dropdown 'AtleastOne) Operable
  } deriving Generic


deriving instance Eq       (SpaceCraftUpdate 'Valid)
deriving instance Ord      (SpaceCraftUpdate 'Valid)
deriving instance Show     (SpaceCraftUpdate 'Valid)
deriving instance ToJSON   (SpaceCraftUpdate 'Valid)
deriving instance FromJSON (SpaceCraftUpdate 'Valid)

deriving instance Eq       (SpaceCraftUpdate 'Edit)
deriving instance Ord      (SpaceCraftUpdate 'Edit)
deriving instance Show     (SpaceCraftUpdate 'Edit)
deriving instance ToJSON   (SpaceCraftUpdate 'Edit)
deriving instance FromJSON (SpaceCraftUpdate 'Edit)

deriving instance Show     (SpaceCraftUpdate 'Errors)


instance Validate SpaceCraftUpdate where
  rules = SpaceCraftUpdate
    { _sku         = positive <> nonZero
    , _description = nonMEmpty
    , _serial      = between (30, maxBound)
    , _squadron    = maybe (throwError "Cannot be empty") pure
    , _operable    = pure
    }


makeFieldsNoPrefix ''SpaceCraftUpdate


data Roster = Roster
  { _sort   :: SortCol [SpaceCraft]
  , _search :: Input Search
  , _table  :: [SpaceCraft]
  }


deriving instance Eq      Roster
deriving instance Ord     Roster
deriving instance Show    Roster
deriving instance Generic Roster
instance (ToJSON   (Table.Column [SpaceCraft])) => ToJSON   Roster
instance (FromJSON (Table.Column [SpaceCraft])) => FromJSON Roster


makeFieldsNoPrefix ''Roster


emptyEditForm :: SpaceCraftUpdate 'Edit
emptyEditForm = SpaceCraftUpdate
  { _sku         = Input Clean 0
  , _description = Input Clean Nothing
  , _serial      = Input Clean 0
  , _squadron    = fullOptions
  , _operable    = fullOptionsMin
  }


data Frontend
  = MEcho (Maybe Text)
  | MList Roster
  | MDetail (Maybe SpaceCraftId) (SpaceCraftUpdate 'Edit)
  | M404
  deriving (Eq, Ord, Show, Generic)


instance (ToJSON   (Column [SpaceCraft])) => ToJSON   Frontend
instance (FromJSON (Column [SpaceCraft])) => FromJSON Frontend


makeLenses ''Frontend


data Route
  = REcho (Maybe Text)
  | RList (Input Search)
  | RNew
  | RExisting SpaceCraftId
  deriving (Eq, Ord, Show, Generic)


makeLenses ''Route


type API = "api" :> "space-craft" :> Get '[JSON] [SpaceCraft]
      :<|> "api" :> "space-craft" :> Capture "id" SpaceCraftId :> Get '[JSON] (Maybe SpaceCraft)
      :<|> "api" :> "space-craft" :> Capture "id" SpaceCraftId :> ReqBody '[JSON] (SpaceCraftUpdate 'Valid) :> Post '[JSON] ()
      :<|> "api" :> "space-craft" :> ReqBody '[JSON] (SpaceCraftUpdate 'Valid) :> Put '[JSON] SpaceCraftId
      :<|> "api" :> "space-craft" :> ReqBody '[JSON] SpaceCraftId :> Delete '[JSON] ()


type SPA = "app" :> "echo" :> QueryParam "echo" Text :> Raw
      :<|> "app" :> "new"  :> Raw
      :<|> "app" :> "edit" :> Capture "id" SpaceCraftId :> Raw
      :<|> "app" :> QueryParam "search" Search :> Raw
      :<|> Raw


routes :: SPA :>> Route
routes = REcho
    :<|> RNew
    :<|> RExisting
    :<|> RList . Input Clean . fromMaybe ""
    :<|> RList (Input Clean "")


deriving newtype instance ToHttpApiData   Search
deriving newtype instance FromHttpApiData Search


instance Routed SPA Route where
  redirect = \case
    REcho t     -> Redirect (Proxy @("app" :> "echo" :> QueryParam "echo" Text :> Raw)) ($ t)
    RNew        -> Redirect (Proxy @("app" :> "new" :> Raw)) id
    RExisting i -> Redirect (Proxy @("app" :> "edit" :> Capture "id" SpaceCraftId :> Raw)) ($ i)
    RList s     -> Redirect (Proxy @("app" :> QueryParam "search" Search :> Raw)) ($ Just (_value s))


class CRUDSpaceCraft m where
  listSpaceCraft   :: m [SpaceCraft]
  getSpaceCraft    :: SpaceCraftId -> m (Maybe SpaceCraft)
  updateSpaceCraft :: SpaceCraftId -> SpaceCraftUpdate 'Valid -> m ()
  createSpaceCraft :: SpaceCraftUpdate 'Valid -> m SpaceCraftId
  deleteSpaceCraft :: SpaceCraftId -> m ()


instance (MonadTrans t, Monad m, CRUDSpaceCraft m) => CRUDSpaceCraft (t m) where
  listSpaceCraft     = lift listSpaceCraft
  getSpaceCraft      = lift . getSpaceCraft
  updateSpaceCraft x = lift . updateSpaceCraft x
  createSpaceCraft   = lift . createSpaceCraft
  deleteSpaceCraft   = lift . deleteSpaceCraft


instance Humanize (Column [SpaceCraft]) where
  humanize = \case
    SKUT          -> "SKU"
    DescriptionT  -> "Desc"
    SerialNumberT -> "Serial #"
    SquadronT     -> "Squadron"
    OperableT     -> "Status"
    ToolsT        -> ""


data instance Column [SpaceCraft] =
    SKUT | DescriptionT | SerialNumberT | SquadronT | OperableT | ToolsT
    deriving (Eq, Ord, Show, Enum, Bounded, Generic, ToJSON, FromJSON)


newtype instance Row [SpaceCraft] = SpaceCraftRow { unRow :: SpaceCraft }
    deriving (Eq, Ord, Show)


instance Tabular [SpaceCraft] where

  type Effect [SpaceCraft] m = (MonadJSM m, CRUDSpaceCraft m)

  toRows = fmap SpaceCraftRow

  toCell xs (SpaceCraftRow SpaceCraft {..}) = \case
    SKUT          -> present _sku
    DescriptionT  -> present _description
    SerialNumberT -> present _serial
    SquadronT     -> present _squadron
    OperableT     -> present _operable
    ToolsT        ->
      [ H.div "btn-group"
        [ H.button [ H.class' "btn btn-sm btn-secondary", H.onClick' (xs <$ navigate @ SPA (RExisting _identity)) ] [ "Edit" ]
        , H.button [ H.class' "btn btn-sm btn-secondary", H.onClick' (Prelude.filter (\x -> x ^. identity /= _identity) xs
                          <$ deleteSpaceCraft _identity) ] [ "Delete" ]
        ]
      ]

  sortTable (SortCol c d) = f $ case c of
    SKUT          -> g sku
    DescriptionT  -> g description
    SerialNumberT -> g serial
    SquadronT     -> g squadron
    OperableT     -> g operable
    ToolsT        -> \_ _ -> EQ
    where f = case d of ASC -> id; DESC -> flip
          g l = compare `on` Lens.view l . unRow