{-# LANGUAGE FlexibleInstances #-}

module Model where

import ClassyPrelude.Yesod
import Database.Persist.Quasi

import Control.Monad.Writer

import           Data.Text   (Text)
import qualified Data.Text as Text

import qualified Data.HashMap.Lazy as HashMap

import Data.Aeson
import Data.Aeson.Types (Parser, Value(..))

-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
    $(persistFileWith lowerCaseSettings "config/models")

class HasType a where
  getType :: ( BaseBackend backend ~ SqlBackend
             , MonadIO m
             , PersistStoreRead backend
             ) => a -> ReaderT backend m Kind

instance HasType Item where
  getType = belongsToJust itemFkType

instance HasType Reference where
  getType = belongsToJust referenceFkType

instance HasType a => HasType (Entity a) where
  getType Entity{..} = getType entityVal

withType :: ( BaseBackend backend ~ SqlBackend
            , MonadIO m
            , PersistStoreRead backend
            , HasType a
            ) => a -> ReaderT backend m (WithType a)
withType val = (val `WithType`) . kindType <$> getType val

instance Ord Item where
  x `compare` y = mconcat cmprs
    where
      cmprs = [ itemOpened x `compareM` itemOpened y
              , itemExpires x `compareM` itemExpires y
              , itemKind x `compare` itemKind y
              , itemBought x `compare` itemBought y
              ]

      compareM (Just _) Nothing = LT
      compareM Nothing (Just _) = GT
      compareM (Just a) (Just b) = compare a b
      compareM _ _ = EQ

instance ToJSON Item where
  toJSON Item{..} = object $
    [ "kind" .= itemKind
    ] ++ maybe [] (\x -> ["bought" .= x]) itemBought
    ++ maybe [] (\x -> ["expires" .= x]) itemExpires
    ++ maybe [] (\x -> ["opened" .= x]) itemOpened

instance FromJSON Item where
  parseJSON = withObject "Item" $ \obj -> do
    itemKind <- obj .: "kind"
    let
      itemNormKind = normalizeKind itemKind
    itemBought <- obj .:? "bought"
    itemExpires <- obj .:? "expires"
    itemOpened <- obj .:? "opened"
    return Item{..}
  
instance ToJSON (Entity Item) where
  toJSON = entityIdToJSON

instance FromJSON (Entity Item) where
  parseJSON = entityIdFromJSON

instance ToJSON Reference where
  toJSON Reference{..} = String referenceKind

instance FromJSON Reference where
  parseJSON = withText "Reference" $ \referenceKind -> do
    let
      referenceNormKind = normalizeKind referenceKind
    return Reference{..}

instance ToJSON (Entity Reference) where
  toJSON = keyValueEntityToJSON

instance FromJSON (Entity Reference) where
  parseJSON = keyValueEntityFromJSON

normalizeKind :: Text -> Text
normalizeKind = Text.strip . Text.toCaseFold

data ItemDiff = DiffKind Text
              | DiffType Text
              | DiffBought (Maybe Day)
              | DiffExpires (Maybe Day)
              | DiffOpened (Maybe Day)

newtype ItemDiffs = ItemDiffs [ItemDiff]

instance FromJSON ItemDiffs where
  parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
    tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
    tell =<< maybe [] (pure . DiffType) <$> lift (obj .:? "type")
    tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
    tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
    tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")

toUpdate :: ItemDiffs -> ([Update Item], [Update Kind])
toUpdate (ItemDiffs ds) = mconcat $ do
  x <- ds
  return $ case x of
    DiffKind t    -> (, []) [ ItemKind =. t
                            , ItemNormKind =. normalizeKind t
                            ]
    DiffType t    -> ([], ) [ KindType =. t ]
    DiffBought d  -> (, []) [ ItemBought =. d ]
    DiffExpires d -> (, []) [ ItemExpires =. d ]
    DiffOpened d  -> (, []) [ ItemOpened =. d ]

data WithType a = WithType { typedVal :: a, valType :: Text }
  deriving (Eq, Ord, Show)

typeToJSON :: ToJSON a
           => Text -- ^ Key for value, if needed
           -> WithType a -> Value
typeToJSON valKey (record `WithType` t) = Object $ HashMap.insert "type" (toJSON t) o
  where
    o
      | Object o' <- toJSON record = o'
      | otherwise = HashMap.singleton valKey $ toJSON record

typeFromJSON :: FromJSON a
             => Maybe Text -- ^ Key for value, if needed
             -> Value -> Parser (WithType a)
typeFromJSON valKey = withObject "value with type" $ \obj -> do
  t <- obj .: "type"
  value <- case valKey of
    Just key -> parseJSON =<< obj .: key
    Nothing  -> parseJSON $ Object obj
  return $ value `WithType` t

instance ToJSON (WithType Item) where
  toJSON = typeToJSON $ error "Item is not serializing correctly"

instance ToJSON (WithType (Entity Item)) where
  toJSON = typeToJSON $ error "Entity Item is not serializing correctly"

instance ToJSON (WithType Reference) where
  toJSON = typeToJSON "kind"

instance ToJSON (WithType (Entity Reference)) where
  toJSON ((Entity eId ref) `WithType` t) = object
    [ "id" .= eId
    , "type" .= t
    , "kind" .= referenceKind ref
    ]

instance FromJSON (WithType Item) where
  parseJSON = typeFromJSON Nothing

instance FromJSON (WithType Reference) where
  parseJSON = typeFromJSON $ Just "kind"