{-# 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.Lib (viewP)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax (Lift)
import qualified Language.Haskell.TH.Syntax as TH (lift)

import Data.Data (Data)

import Utils (assertM')


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, quotePat}
  where
    withP f v = case [ x | (x, "") <- readP_to_S parseVersion v] of
      [x] -> f x
      []  -> error "No parse"
      _   -> error "Ambiguous parse"
    
    quoteExp = withP TH.lift
    quotePat = withP $ \p -> viewP [e|assertM' (== $(TH.lift p))|] [p|Just _|]
migrationVersion = undefinedQuote{quoteExp, quotePat}
  where
    withP f "initial" = f InitialVersion
    withP f v = case [ x | (x, "") <- readP_to_S parseVersion v] of
      [x] -> f $ MigrationVersion x
      []  -> error "No parse"
      _   -> error "Ambiguous parse"
    
    quoteExp = withP TH.lift
    quotePat = withP $ \p -> viewP [e|assertM' (== $(TH.lift p))|] [p|Just _|]


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