diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 3d67e3c..247c029 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -11,7 +11,7 @@ import Data.Versions data Tool = GHC | Cabal | Stack - deriving (Eq, Ord, Show) + deriving (Eq, GHC.Generic, Ord, Show) data ToolRequest = ToolRequest { _tool :: Tool @@ -20,7 +20,7 @@ data ToolRequest = ToolRequest { data Architecture = A_64 | A_32 - deriving (Eq, Ord, Show) + deriving (Eq, GHC.Generic, Ord, Show) data LinuxDistro = Debian | Ubuntu diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index b0249bc..5b21af0 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -6,24 +6,120 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} module GHCup.Types.JSON where -import Data.Strict.Maybe import GHCup.Types -import Prelude hiding ( Maybe ) import Data.Versions import Data.Aeson import Data.Aeson.TH +import Network.URL +import qualified Data.Text as T +import Data.Aeson.Types +import Data.Text.Encoding as E + + deriveJSON defaultOptions ''Architecture deriveJSON defaultOptions ''LinuxDistro -deriveJSON defaultOptions ''Maybe deriveJSON defaultOptions ''Mess +deriveJSON defaultOptions ''Platform deriveJSON defaultOptions ''SemVer deriveJSON defaultOptions ''Tool deriveJSON defaultOptions ''VSep deriveJSON defaultOptions ''VUnit -deriveJSON defaultOptions ''Version -deriveJSON defaultOptions ''Versioning + + +instance ToJSON URL where + toJSON = toJSON . exportURL + +instance FromJSON URL where + parseJSON = withText "URL" $ \t -> case importURL (T.unpack t) of + Just x -> pure x + Nothing -> fail "Could not parse URL, failure in importURL" + +instance ToJSON Versioning where + toJSON = toJSON . prettyV + +instance FromJSON Versioning where + parseJSON = withText "Versioning" $ \t -> case versioning t of + Right x -> pure x + Left e -> fail $ "Failure in Version (FromJSON)" <> show e + +instance ToJSONKey Versioning where + toJSONKey = toJSONKeyText $ \x -> prettyV x + +instance FromJSONKey Versioning where + fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of + Right x -> pure x + Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e + +instance ToJSONKey (Maybe Versioning) where + toJSONKey = toJSONKeyText $ \case + Just x -> prettyV x + Nothing -> T.pack "unknown" + +instance FromJSONKey (Maybe Versioning) where + fromJSONKey = FromJSONKeyTextParser + $ \t -> if t == T.pack "unknown" then pure Nothing else pure $ just t + where + just t = case versioning t of + Right x -> pure x + Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e + +instance ToJSONKey Platform where + toJSONKey = toJSONKeyText $ \case + Darwin -> T.pack "Darwin" + FreeBSD -> T.pack "FreeBSD" + Linux d -> T.pack ("Linux_" <> show d) + +instance FromJSONKey Platform where + fromJSONKey = FromJSONKeyTextParser $ \t -> if + | T.pack "Darwin" == t -> pure Darwin + | T.pack "FreeBSD" == t -> pure FreeBSD + | T.pack "Linux_" `T.isPrefixOf` t -> case + T.stripPrefix (T.pack "Linux_") t + of + Just dstr -> + case + (decodeStrict (E.encodeUtf8 (T.pack "\"" <> dstr <> T.pack "\"")) :: Maybe + LinuxDistro + ) + of + Just d -> pure $ Linux d + Nothing -> + fail + $ "Unexpected failure in decoding LinuxDistro: " + <> show dstr + Nothing -> fail "Unexpected failure in Platform stripPrefix" + | otherwise -> fail $ "Failure in Platform (FromJSONKey)" + +instance ToJSONKey Architecture where + toJSONKey = genericToJSONKey defaultJSONKeyOptions + +instance FromJSONKey Architecture where + fromJSONKey = genericFromJSONKey defaultJSONKeyOptions + +instance ToJSON Version where + toJSON = toJSON . prettyVer + +instance FromJSON Version where + parseJSON = withText "Version" $ \t -> case version t of + Right x -> pure x + Left e -> fail $ "Failure in Version (FromJSON)" <> show e + +instance ToJSONKey Version where + toJSONKey = toJSONKeyText $ \x -> prettyVer x + +instance FromJSONKey Version where + fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of + Right x -> pure x + Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e + +instance ToJSONKey Tool where + toJSONKey = genericToJSONKey defaultJSONKeyOptions + +instance FromJSONKey Tool where + fromJSONKey = genericFromJSONKey defaultJSONKeyOptions