{-# 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           Data.Map   (Map, (!))
import qualified Data.Map as Map

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
  fkType :: a -> Key Kind
  
getType :: ( BaseBackend backend ~ SqlBackend
           , MonadIO m
           , PersistStoreRead backend
           , HasType a
           ) => a -> ReaderT backend m Kind
getType = getJust . fkType

instance HasType Item where
  fkType = itemFkType

instance HasType Reference where
  fkType = referenceFkType

instance HasType a => HasType (Entity a) where
  fkType = fkType . entityVal
    

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

withTypes :: ( BaseBackend backend ~ SqlBackend
             , MonadIO m
             , PersistStoreRead backend
             , PersistQueryRead backend
             , HasType a
             , Functor f
             ) => f a -> ReaderT backend m (f (WithType a))
withTypes vals = do
  typeMap <- Map.fromList . map (\(Entity kindKey kind) -> (kindKey, kind)) <$> selectList [] []
  let
    lookupType x = (x `WithType`) . kindType $ typeMap ! fkType x
  return $ lookupType <$> vals

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"