89 lines
2.6 KiB
Haskell
89 lines
2.6 KiB
Haskell
{-# 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"
|