Merge pull request #1 from haskell-works/newhoggy/new-RenderedError-type

New RenderedError types
haskell-works · Nov 2, 2024 · f4fa30c · f4fa30c
2 parents ca8ff87 + 0acb686
commit f4fa30c
Show file tree

Hide file tree

Showing 6 changed files with 116 additions and 15 deletions.
diff --git a/hw-prelude.cabal b/hw-prelude.cabal
@@ -19,11 +19,14 @@ source-repository head
 
 common base                       { build-depends: base                       >= 4.13       && < 5      }
 
+common aeson                      { build-depends: aeson                                       < 2.3    }
 common async                      { build-depends: async                                       < 2.3    }
 common bytestring                 { build-depends: bytestring                                  < 0.13   }
 common contravariant              { build-depends: contravariant                               < 1.6    }
 common directory                  { build-depends: directory                                   < 1.4    }
 common filepath                   { build-depends: filepath                                    < 1.6    }
+common generic-lens               { build-depends: generic-lens                                < 2.3    }
+common microlens                  { build-depends: microlens                                   < 0.5    }
 common network                    { build-depends: network                                     < 3.3    }
 common process                    { build-depends: process                                     < 1.7    }
 common resourcet                  { build-depends: resourcet                                   < 1.4    }
@@ -63,11 +66,14 @@ common project-config
 
 library
   import:               base, project-config,
+                        aeson,
                         async,
                         bytestring,
                         contravariant,
                         directory,
                         filepath,
+                        generic-lens,
+                        microlens,
                         network,
                         process,
                         resourcet,
@@ -82,6 +88,10 @@ library
                         HaskellWorks.Data.String
                         HaskellWorks.Error
                         HaskellWorks.Error.Types
+                        HaskellWorks.Error.Types.All
+                        HaskellWorks.Error.Types.GenericError
+                        HaskellWorks.Error.Types.RenderedError
+                        HaskellWorks.Error.Types.TimedOut
                         HaskellWorks.IO.Network.NamedPipe
                         HaskellWorks.IO.Network.Port
                         HaskellWorks.IO.Network.Socket

diff --git a/src/HaskellWorks/Error/Types.hs b/src/HaskellWorks/Error/Types.hs
@@ -1,18 +1,11 @@
-{-# LANGUAGE DeriveGeneric #-}
-
 module HaskellWorks.Error.Types
-  ( GenericError(..),
-    TimedOut(..),
-  ) where
+  ( -- * Error types
+    GenericError(GenericError),
+    RenderedError(RenderedError),
+    TimedOut(TimedOut),
 
-import           HaskellWorks.Prelude
-
-newtype GenericError = GenericError
-  { message :: Text
-  }
-  deriving (Generic, Eq, Show)
+    -- * Type classes
+    ToRenderedError(..),
+  ) where
 
-newtype TimedOut = TimedOut
-  { message :: Text
-  }
-  deriving (Generic, Eq, Show)
+import           HaskellWorks.Error.Types.All
diff --git a/src/HaskellWorks/Error/Types/All.hs b/src/HaskellWorks/Error/Types/All.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module HaskellWorks.Error.Types.All (
+    GenericError (..),
+    RenderedError (..),
+    TimedOut(..),
+
+    ToRenderedError (..),
+) where
+
+import           HaskellWorks.Error.Types.GenericError
+import           HaskellWorks.Error.Types.RenderedError
+import           HaskellWorks.Error.Types.TimedOut
diff --git a/src/HaskellWorks/Error/Types/GenericError.hs b/src/HaskellWorks/Error/Types/GenericError.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module HaskellWorks.Error.Types.GenericError (
+    GenericError (..),
+) where
+
+import           Data.Aeson
+import           Data.Generics.Product.Any
+import           HaskellWorks.Error.Types.RenderedError
+import           Lens.Micro
+
+import           HaskellWorks.Prelude
+
+newtype GenericError = GenericError
+    { message :: Text
+    }
+    deriving (Eq, Generic, Show)
+
+instance ToRenderedError GenericError where
+    toRenderedError e =
+        RenderedError
+            { error   = "GenericError"
+            , payload = toJSON $ e ^. the @"message"
+            }
diff --git a/src/HaskellWorks/Error/Types/RenderedError.hs b/src/HaskellWorks/Error/Types/RenderedError.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module HaskellWorks.Error.Types.RenderedError (
+    RenderedError (..),
+
+    ToRenderedError (..),
+) where
+
+import           Data.Aeson
+
+import           HaskellWorks.Prelude
+
+data RenderedError = RenderedError
+    { error   :: Text
+    , payload :: Value
+    }
+    deriving (Eq, Generic, Show)
+
+instance ToJSON RenderedError where
+    toJSON e =
+        object
+            [ "error" .= error e
+            , "payload" .= payload e
+            ]
+
+class ToRenderedError a where
+    toRenderedError :: a -> RenderedError
+
+instance ToRenderedError RenderedError where
+    toRenderedError = id
diff --git a/src/HaskellWorks/Error/Types/TimedOut.hs b/src/HaskellWorks/Error/Types/TimedOut.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module HaskellWorks.Error.Types.TimedOut (
+    TimedOut (..),
+) where
+
+import           Data.Aeson
+import           Data.Generics.Product.Any
+import           HaskellWorks.Error.Types.RenderedError
+import           Lens.Micro
+
+import           HaskellWorks.Prelude
+
+newtype TimedOut = TimedOut
+    { message :: Text
+    }
+    deriving (Eq, Generic, Show)
+
+instance ToRenderedError TimedOut where
+    toRenderedError e =
+        RenderedError
+            { error   = "TimedOut"
+            , payload = toJSON $ e ^. the @"message"
+            }