{-# 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 = undefinedQuote{quoteExp}
  where
    quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
      [x] -> TH.lift x
      []  -> error "No parse"
      _   -> error "Ambiguous parse"
migrationVersion = undefinedQuote{quoteExp}
  where
    quoteExp "initial" = TH.lift InitialVersion
    quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
      [x] -> TH.lift $ MigrationVersion x
      []  -> error "No parse"
      _   -> error "Ambiguous parse"


undefinedQuote :: QuasiQuoter
undefinedQuote = QuasiQuoter{..}
  where
    quoteExp = error "version cannot be used as expression"
    quotePat = error "version cannot be used as pattern"
    quoteType = error "version cannot be used as type"
    quoteDec = error "version cannot be used as declaration"
