You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 

168 lines
5.9 KiB

module Types where
import ClassyPrelude.Yesod
import Data.Aeson.Extra
import Data.Hashable (hashUsing)
import Text.Blaze (ToMarkup)
import Database.Persist.Sql (PersistFieldSql (sqlType))
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder.Int as Builder
import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Read as Reader
data SnapshotBranch = LtsMajorBranch Int
| LtsBranch
| NightlyBranch
deriving (Eq, Read, Show)
instance PathPiece SnapshotBranch where
toPathPiece NightlyBranch = "nightly"
toPathPiece LtsBranch = "lts"
toPathPiece (LtsMajorBranch x) = "lts-" ++ tshow x
fromPathPiece "nightly" = Just NightlyBranch
fromPathPiece "lts" = Just LtsBranch
fromPathPiece t0 = do
t1 <- stripPrefix "lts-" t0
Right (x, "") <- Just $ Reader.decimal t1
Just $ LtsMajorBranch x
newtype PackageName = PackageName { unPackageName :: Text }
deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString)
instance ToJSON PackageName where
toJSON = toJSON . unPackageName
instance ToJSONKey PackageName where
toJSONKey = unPackageName
instance PersistFieldSql PackageName where
sqlType = sqlType . liftM unPackageName
newtype Version = Version { unVersion :: Text }
deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField)
instance ToJSON Version where
toJSON = toJSON . unVersion
instance PersistFieldSql Version where
sqlType = sqlType . liftM unVersion
newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text }
deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField)
instance PersistFieldSql PackageSetIdent where
sqlType = sqlType . liftM unPackageSetIdent
data PackageNameVersion = PNVTarball !PackageName !Version
| PNVNameVersion !PackageName !Version
| PNVName !PackageName
deriving (Show, Read, Typeable, Eq, Ord)
instance PathPiece PackageNameVersion where
toPathPiece (PNVTarball x y) = concat [toPathPiece x, "-", toPathPiece y, ".tar.gz"]
toPathPiece (PNVNameVersion x y) = concat [toPathPiece x, "-", toPathPiece y]
toPathPiece (PNVName x) = toPathPiece x
fromPathPiece t' | Just t <- stripSuffix ".tar.gz" t' =
case T.breakOnEnd "-" t of
("", _) -> Nothing
(_, "") -> Nothing
(T.init -> name, version) -> Just $ PNVTarball (PackageName name) (Version version)
fromPathPiece t = Just $
case T.breakOnEnd "-" t of
("", _) -> PNVName (PackageName t)
(T.init -> name, version) | validVersion version ->
PNVNameVersion (PackageName name) (Version version)
_ -> PNVName (PackageName t)
where
validVersion =
all f
where
f c = (c == '.') || ('0' <= c && c <= '9')
newtype HoogleVersion = HoogleVersion Text
deriving (Show, Eq, Ord, Typeable, PathPiece)
currentHoogleVersion :: HoogleVersion
currentHoogleVersion = HoogleVersion VERSION_hoogle
data UnpackStatus = USReady
| USBusy
| USFailed !Text
data StackageExecutable
= StackageWindowsExecutable
| StackageUnixExecutable
deriving (Show, Read, Eq)
instance PathPiece StackageExecutable where
-- TODO: distribute stackage, not just stackage-setup
toPathPiece StackageWindowsExecutable = "stackage-setup.exe"
toPathPiece StackageUnixExecutable = "stackage-setup"
fromPathPiece "stackage-setup" = Just StackageUnixExecutable
fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable
fromPathPiece _ = Nothing
data GhcMajorVersion = GhcMajorVersion !Int !Int
deriving (Eq)
data GhcMajorVersionFailedParse = GhcMajorVersionFailedParse Text
deriving (Show, Typeable)
instance Exception GhcMajorVersionFailedParse
ghcMajorVersionToText :: GhcMajorVersion -> Text
ghcMajorVersionToText (GhcMajorVersion a b)
= LText.toStrict
$ Builder.toLazyText
$ Builder.decimal a <> "." <> Builder.decimal b
ghcMajorVersionFromText :: MonadThrow m => Text -> m GhcMajorVersion
ghcMajorVersionFromText t = case Reader.decimal t of
Right (a, T.uncons -> Just ('.', t')) -> case Reader.decimal t' of
Right (b, t'') | T.null t'' -> return $ GhcMajorVersion a b
_ -> failedParse
_ -> failedParse
where
failedParse = throwM $ GhcMajorVersionFailedParse t
instance PersistFieldSql GhcMajorVersion where
sqlType = sqlType . liftM ghcMajorVersionToText
instance PersistField GhcMajorVersion where
toPersistValue = toPersistValue . ghcMajorVersionToText
fromPersistValue v = do
t <- fromPersistValueText v
case ghcMajorVersionFromText t of
Just ver -> return ver
Nothing -> Left $ "Cannot convert to GhcMajorVersion: " <> t
instance Hashable GhcMajorVersion where
hashWithSalt = hashUsing ghcMajorVersionToText
instance FromJSON GhcMajorVersion where
parseJSON = withText "GhcMajorVersion" $
either (fail . show) return . ghcMajorVersionFromText
instance ToJSON GhcMajorVersion where
toJSON = toJSON . ghcMajorVersionToText
data SupportedArch
= Win32
| Win64
| Linux32
| Linux64
| Mac32
| Mac64
deriving (Enum, Bounded, Show, Read, Eq)
instance Hashable SupportedArch where
hashWithSalt = hashUsing fromEnum
instance PathPiece SupportedArch where
toPathPiece Win32 = "win32"
toPathPiece Win64 = "win64"
toPathPiece Linux32 = "linux32"
toPathPiece Linux64 = "linux64"
toPathPiece Mac32 = "mac32"
toPathPiece Mac64 = "mac64"
fromPathPiece "win32" = Just Win32
fromPathPiece "win64" = Just Win64
fromPathPiece "linux32" = Just Linux32
fromPathPiece "linux64" = Just Linux64
fromPathPiece "mac32" = Just Mac32
fromPathPiece "mac64" = Just Mac64
fromPathPiece _ = Nothing