From eebd81ddfea08fa44f088064c3dcc8be96d6bbf4 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Fri, 17 Jan 2020 01:48:42 +0100
Subject: [PATCH] Do the JSON instance properly

---
 lib/GHCup/Types.hs      |   4 +-
 lib/GHCup/Types/JSON.hs | 106 ++++++++++++++++++++++++++++++++++++++--
 2 files changed, 103 insertions(+), 7 deletions(-)

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