{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Model.Migration.Version
  ( MigrationVersion(..)
  , version, migrationVersion
  , module Data.Version
  ) where

import ClassyPrelude.Yesod

import Database.Persist.Sql
import Text.ParserCombinators.ReadP
import Data.Maybe (fromJust)

import Data.Version

import Data.Aeson.TH

import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax (Lift)
import qualified Language.Haskell.TH.Syntax as TH (lift)

import Data.Data (Data)


deriving instance Lift Version
  

data MigrationVersion = InitialVersion | MigrationVersion Version
  deriving (Eq, Ord, Show, Read, Generic, Typeable, Data, Lift)

deriveJSON defaultOptions
  { constructorTagModifier = toLower . fromJust . stripSuffix "Version"
  , sumEncoding = UntaggedValue
  } ''MigrationVersion

instance PersistField MigrationVersion where
  toPersistValue  InitialVersion      = PersistText "initial"
  toPersistValue (MigrationVersion v) = PersistText . pack $ showVersion v

  fromPersistValue (PersistText t)
    | t == "initial" = return InitialVersion
    | otherwise = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
        [x] -> Right $ MigrationVersion x
        []  -> Left "No parse"
        _   -> Left "Ambiguous parse"
  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x

instance PersistFieldSql MigrationVersion where
  sqlType _ = SqlString


instance PersistField Version where
  toPersistValue = PersistText . pack . showVersion

  fromPersistValue (PersistText t) = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
    [x] -> Right x
    []  -> Left "No parse"
    _   -> Left "Ambiguous parse"
  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x

instance PersistFieldSql Version where
  sqlType _ = SqlString


version, migrationVersion :: QuasiQuoter
version = QuasiQuoter{..}
  where
    quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
      [x] -> x
      []  -> error "No parse"
      _   -> error "Ambiguous parse"
    quotePat = error "version cannot be used as pattern"
    quoteType = error "version cannot be used as type"
    quoteDec = error "version cannot be used as declaration"
migrationVersion = QuasiQuoter{..}
  where
    quoteExp "initial" = TH.lift InitialVersion
    quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
      [x] -> MigrationVersion x
      []  -> error "No parse"
      _   -> error "Ambiguous parse"
    quotePat = error "version cannot be used as pattern"
    quoteType = error "version cannot be used as type"
    quoteDec = error "version cannot be used as declaration"