can't figure out choice

autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs

@@ -4,6 +4,8 @@
 module Autodocodec.Aeson.Decode where
 
 import Autodocodec
+import Control.Applicative
+import Control.Monad
 import Data.Aeson as JSON
 import Data.Aeson.Types as JSON
 
@@ -21,6 +23,13 @@ parseJSONVia = flip go
       NumberCodec -> parseJSON value
       ObjectCodec c -> withObject "TODO" (\o -> goObject o c) value
       BimapCodec f _ c -> f <$> go value c
+      ChoiceCodec cs _ -> goChoice value cs
+
+    goChoice :: JSON.Value -> [Codec void a] -> JSON.Parser a
+    goChoice value = \case
+      [] -> fail "No choices left." -- TODO better error
+      (c : cs) -> go value c <|> goChoice value cs
+
     -- PureCodec a -> pure a
     -- ApCodec cf ca -> go value cf <*> go value ca
     -- AltCodecs cs -> case cs of
@@ -32,6 +41,10 @@ parseJSONVia = flip go
       KeyCodec k c -> do
         value <- object_ JSON..: k
         go value c
+      -- EqObjectCodec o oc -> do
+      --   o' <- goObject object_ oc
+      --   guard (o == o')
+      --   pure o'
       BimapObjectCodec f _ oc -> f <$> goObject object_ oc
       PureObjectCodec a -> pure a
       ApObjectCodec ocf oca -> goObject object_ ocf <*> goObject object_ oca

autodocodec-aeson/src/Autodocodec/Aeson/Document.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -10,7 +11,8 @@ module Autodocodec.Aeson.Document where
 import Autodocodec
 import Autodocodec.Aeson.Decode
 import Autodocodec.Aeson.Encode
-import Data.Aeson as JSON
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as JSON
 import Data.Text (Text)
 import GHC.Generics (Generic)
 
@@ -20,7 +22,9 @@ data JSONSchema
   | BoolSchema
   | StringSchema
   | NumberSchema
-  | ObjectSchema !JSONObjectSchema
+  | -- | ValueSchema JSON.Value
+    ObjectSchema !JSONObjectSchema
+  | ChoiceSchema ![JSONSchema]
   deriving (Show, Eq, Generic)
 
 data JSONObjectSchema
@@ -30,7 +34,24 @@ data JSONObjectSchema
   deriving (Show, Eq, Generic)
 
 instance HasCodec JSONSchema where
-  codec = undefined
+  codec =
+    ChoiceCodec
+      ( [ bimapCodec
+            (const BoolSchema :: Text -> JSONSchema)
+            (const "boolean" :: JSONSchema -> Text)
+            (object (field "type" .== ("boolean" :: Text)))
+        ] ::
+          [Codec JSONSchema JSONSchema]
+      )
+      ( ( \case
+            BoolSchema ->
+              bimapCodec
+                (const BoolSchema :: Text -> JSONSchema)
+                (const "boolean" :: JSONSchema -> Text)
+                (object (field "type" .== "boolean"))
+        ) ::
+          JSONSchema -> Codec JSONSchema JSONSchema
+      )
 
 instance ToJSON JSONSchema where
   toJSON = toJSONViaCodec
@@ -50,8 +71,10 @@ jsonSchemaVia = go
       BoolCodec -> BoolSchema
       StringCodec -> StringSchema
       NumberCodec -> NumberSchema
+      -- EqCodec _ c -> go c -- TODO maybe we want to show the specific value?
       ObjectCodec oc -> ObjectSchema (goObject oc)
       BimapCodec _ _ c -> go c
+      ChoiceCodec cs _ -> ChoiceSchema (map go cs)
 
     goObject :: ObjectCodec input output -> JSONObjectSchema
     goObject = \case

autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs

@@ -23,6 +23,7 @@ toJSONVia = flip go
       NumberCodec -> toJSON (a :: Scientific)
       ObjectCodec oc -> JSON.Object (goObject a oc)
       BimapCodec _ g c -> go (g a) c
+      ChoiceCodec _ c -> go a (c a)
     -- ApCodec _ _ -> error "Cannot toJSON Ap with non-object codecs."
     -- PureCodec _ -> error "Cannot toJSON a pure codec."
     -- AltCodecs _ -> error "Cannot toJSON an Alt codec."
@@ -30,6 +31,7 @@ toJSONVia = flip go
     goObject :: a -> ObjectCodec a void -> JSON.Object
     goObject a = \case
       KeyCodec k c -> k JSON..= go a c
+      -- EqObjectCodec o oc -> goObject o oc
       PureObjectCodec _ -> error "Cannot toJSON a pure object codec."
       BimapObjectCodec _ g oc -> goObject (g a) oc
       ApObjectCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2

autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs

@@ -6,18 +6,20 @@ module Autodocodec.Aeson.DocumentSpec (spec) where
 
 import Autodocodec
 import Autodocodec.Aeson
+import Data.Data
 import Data.GenValidity
 import Data.GenValidity.Text ()
 import Data.Text (Text)
 import Test.Syd
 import Test.Syd.Aeson
+import Test.Syd.Validity.Utils
 
 spec :: Spec
 spec = do
   jsonSchemaSpec @Bool "bool"
   jsonSchemaSpec @Text "text"
 
-jsonSchemaSpec :: forall a. (Show a, Eq a, GenValid a, HasCodec a) => FilePath -> Spec
+jsonSchemaSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
 jsonSchemaSpec filePath = do
-  it "outputs the same schema as before" $
-    pureGoldenJSONValueFile filePath (jsonSchemaViaCodec @a)
+  it ("outputs the same schema as before for " <> nameOf @a) $
+    pureGoldenJSONValueFile ("test_resources/" <> filePath <> ".json") (jsonSchemaViaCodec @a)

autodocodec/src/Autodocodec/Codec.hs

@@ -39,6 +39,7 @@ data Codec input output where
   -- AltCodecs ::
   --   [Codec input output] ->
   --   Codec input output
+  ChoiceCodec :: [Codec oldInput output] -> (input -> Codec input oldOutput) -> Codec input output
 
 fmapCodec :: (oldOutput -> newOutput) -> Codec input oldOutput -> Codec input newOutput
 fmapCodec f = BimapCodec f id
@@ -75,8 +76,12 @@ instance Functor (Codec input) where
 --   empty = emptyCodec
 --   (<|>) = orCodec
 
+choice :: [Codec oldInput output] -> (input -> Codec input oldOutput) -> Codec input output
+choice = ChoiceCodec
+
 data ObjectCodec input output where
   KeyCodec :: Text -> Codec input output -> ObjectCodec input output
+  EqObjectCodec :: (Show newInput, Eq newInput) => newInput -> ObjectCodec oldInput output -> ObjectCodec newInput output
   PureObjectCodec :: output -> ObjectCodec input output
   BimapObjectCodec :: (oldOutput -> newOutput) -> (newInput -> oldInput) -> ObjectCodec oldInput oldOutput -> ObjectCodec newInput newOutput
   ApObjectCodec :: ObjectCodec input (output -> newOutput) -> ObjectCodec input output -> ObjectCodec input newOutput
@@ -106,6 +111,9 @@ apObjectCodec = ApObjectCodec
 (.=) :: ObjectCodec oldInput output -> (newInput -> oldInput) -> ObjectCodec newInput output
 (.=) = flip comapObjectCodec
 
+(.==) :: (Show newInput, Eq newInput) => ObjectCodec oldInput output -> newInput -> ObjectCodec newInput output
+(.==) = flip EqObjectCodec
+
 boolCodec :: Codec Bool Bool
 boolCodec = BoolCodec