default value in docs

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

@@ -10,6 +10,7 @@ import Control.Monad
 import Data.Aeson as JSON
 import Data.Aeson.Types as JSON
 import qualified Data.HashMap.Strict as HM
+import Data.Maybe
 import qualified Data.Text as T
 
 parseJSONViaCodec :: HasCodec a => JSON.Value -> JSON.Parser a
@@ -65,5 +66,6 @@ parseContextVia = flip go
       OptionalKeyCodec k c -> do
         let mValueAtKey = HM.lookup k value
         forM mValueAtKey $ \valueAtKey -> go valueAtKey c
+      DefaultCodec defaultValue _ c -> fromMaybe defaultValue <$> go value c
       PureCodec a -> pure a
       ApCodec ocf oca -> go value ocf <*> go value oca

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

@@ -10,6 +10,7 @@ module Autodocodec.Aeson.Document where
 
 import Autodocodec
 import Autodocodec.Aeson.Encode
+import Control.Arrow (second)
 import Control.Monad.State
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as JSON
@@ -36,6 +37,8 @@ import GHC.Generics (Generic)
 -- TODO think about putting this value in a separate package or directly in autodocodec
 --
 -- http://json-schema.org/understanding-json-schema/reference/index.html
+--
+-- NOTE: This schema roundtrips to JSON, but it cannot expres everything that a fully-featured json-schema may be able to express.
 data JSONSchema
   = AnySchema
   | NullSchema
@@ -47,6 +50,10 @@ data JSONSchema
     ObjectSchema ![(Text, (KeyRequirement, JSONSchema))]
   | ValueSchema !JSON.Value
   | ChoiceSchema !(NonEmpty JSONSchema)
+  | DefaultSchema
+      !Text -- Human-readible version of the default value
+      !JSON.Value -- Machine-readible version of the default value
+      JSONSchema
   | CommentSchema !Text !JSONSchema
   | ReferenceSchema !Text !JSONSchema
   deriving (Eq, Generic)
@@ -73,11 +80,12 @@ showJSONSchemaABit = ($ "") . (`evalState` S.empty) . go 0
           pure $ f1 . showString " " . f2 . showString " " . f3
         let s = appEndo $ mconcat $ map Endo fs
         pure $ showParen (d > 10) $ showString "ObjectSchema " . s
-      ValueSchema v -> pure $ showString "ValueSchema" . showsPrec d v
+      ValueSchema v -> pure $ showString "ValueSchema " . showsPrec d v
       ChoiceSchema jcs -> do
         fs <- mapM (go d) (NE.toList jcs)
         let s = appEndo $ mconcat $ map Endo fs
         pure $ showParen (d > 10) $ showString "ChoiceSchema " . s
+      DefaultSchema hr mr c -> (\s -> showParen (d > 10) $ showString "DefaultSchema " . showsPrec d hr . showString " " . showsPrec d mr . showString " " . s) <$> go 11 c
       CommentSchema comment c -> (\s -> showParen (d > 10) $ showString "CommentSchema " . showsPrec d comment . showString " " . s) <$> go 11 c
       ReferenceSchema name c -> do
         alreadySeen <- gets (S.member name)
@@ -122,6 +130,7 @@ validateAccordingTo = go
         _ -> False
       ValueSchema v -> v == value
       ChoiceSchema ss -> any (go value) ss
+      DefaultSchema _ _ s -> go value s
       CommentSchema _ s -> go value s
       ReferenceSchema _ s -> go value s
 
@@ -199,6 +208,7 @@ instance ToJSON JSONSchema where
           let val :: JSON.Value
               val = (JSON.toJSON :: [JSON.Value] -> JSON.Value) svals
           pure [("anyOf", val)]
+        DefaultSchema _ value s -> (("default", value) :) <$> go s
         CommentSchema comment s -> (("$comment" JSON..= comment) :) <$> go s
         ReferenceSchema name s -> do
           alreadySeen <- gets (M.member name)
@@ -272,6 +282,7 @@ jsonSchemaVia = go
       ReferenceCodec t c -> ReferenceSchema t (go c)
       PureCodec _ -> AnySchema -- TODO is this right?
       ApCodec oc1 oc2 -> ObjectSchema (goObject oc1 ++ goObject oc2)
+      DefaultCodec value shownValue c -> DefaultSchema shownValue (JSON.Object (toContextVia c (Just value))) (go c)
       RequiredKeyCodec k c -> ObjectSchema [(k, (Required, go c))]
       OptionalKeyCodec k c -> ObjectSchema [(k, (Optional, go c))]
 
@@ -290,5 +301,6 @@ jsonSchemaVia = go
       RequiredKeyCodec k c -> [(k, (Required, go c))]
       OptionalKeyCodec k c -> [(k, (Optional, go c))]
       MapCodec _ _ c -> goObject c
+      DefaultCodec value shownValue c -> map (second (second (DefaultSchema shownValue (JSON.Object (toContextVia c (Just value)))))) (goObject c) -- TODO This isn't exactly clean, is it?
       PureCodec _ -> [] -- TODO show something ?
       ApCodec oc1 oc2 -> goObject oc1 ++ goObject oc2

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

@@ -38,5 +38,6 @@ toContextVia = flip go
       OptionalKeyCodec k c -> case a of
         Nothing -> mempty
         Just b -> k JSON..= go b c
+      DefaultCodec _ _ c -> go (Just a) c -- Default value is ignored during encoding.
       PureCodec _ -> error "Cannot toJSON a pure object codec."
       ApCodec oc1 oc2 -> go a oc1 <> go a oc2

autodocodec-api-usage/test/Autodocodec/Aeson/DocumentSpec.hs

@@ -80,6 +80,9 @@ instance GenValid JSONSchema where
     ChoiceSchema ss -> case ss of
       s :| [] -> [s]
       _ -> ChoiceSchema <$> shrinkValid ss
+    DefaultSchema hr mr s -> (s :) $ do
+      (hr', mr', s') <- shrinkValid (hr, mr, s)
+      pure $ DefaultSchema hr' mr' s'
     CommentSchema k s -> (s :) $ do
       (k', s') <- shrinkValid (k, s)
       pure $ CommentSchema k' s'

autodocodec-api-usage/test_resources/schema/example.json

@@ -38,6 +38,9 @@
             ]
         },
         "optional-with-default": {
+            "default": {
+                "optional-with-default": "foobar"
+            },
             "type": "string"
         },
         "optional-or-null": {

autodocodec-api-usage/test_resources/schema/example.txt

@@ -14,6 +14,7 @@
   , <string>
   ]
 optional-with-default: # optional
+  # default: "foobar"
   <string>
 fruit: # required
   [ Apple

autodocodec-yaml/src/Autodocodec/Yaml/Document.hs

@@ -70,6 +70,7 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . (`evalState` S.empty) . go
                     map (addInFrontOfFirstInList [", "]) restChunks
                       ++ [[["]"]]]
          in addListAround s
+      DefaultSchema shownValue _ s -> ([chunk "# default: ", fore magenta $ chunk shownValue] :) <$> go s
       CommentSchema comment s -> ([chunk $ "# " <> comment] :) <$> go s
       ReferenceSchema name s -> do
         alreadySeen <- gets (S.member name)

autodocodec/src/Autodocodec/Codec.hs

@@ -147,7 +147,17 @@ data Codec context input output where
     ValueCodec input output ->
     -- |
     Codec JSON.Object (Maybe input) (Maybe output)
+  DefaultCodec ::
+    -- | Default value
+    value ->
+    -- | Shown version of the default value
+    Text ->
+    -- |
+    ObjectCodec (Maybe value) (Maybe value) ->
+    -- |
+    ObjectCodec value value
   -- Pure is not available for non-object codecs
+  -- TODO why again?
   PureCodec ::
     -- |
     output ->
@@ -213,6 +223,7 @@ showCodecABit = ($ "") . (`evalState` S.empty) . go 0
       OptionalKeyCodec k c -> (\s -> showParen (d > 10) $ showString "OptionalKeyCodec " . showsPrec d k . showString " " . s) <$> go 11 c
       PureCodec _ -> pure $ showString "PureCodec" -- TODO add show instance?
       ApCodec oc1 oc2 -> (\s1 s2 -> showParen (d > 10) $ showString "ApCodec " . s1 . showString " " . s2) <$> go 11 oc1 <*> go 11 oc2
+      DefaultCodec _ defaultShown c -> (\s -> showParen (d > 10) $ showString "DefaultCodec " . showsPrec d defaultShown . showString " " . s) <$> go 11 c
 
 -- | Map the output part of a codec
 --
@@ -347,26 +358,20 @@ optionalFieldWith ::
   ObjectCodec (Maybe input) (Maybe output)
 optionalFieldWith = OptionalKeyCodec
 
--- | Add a default value to a codec
+-- | Add a default value to a codec, documented using its show instance.
 --
 -- During encoding, the default value is not used.
 -- During decoding, the default value will be parsed if the underlying codec decodes 'Nothing'.
 withDefault ::
-  forall value context.
+  forall value.
+  Show value =>
   -- | default value
   value ->
   -- |
-  Codec context (Maybe value) (Maybe value) ->
+  ObjectCodec (Maybe value) (Maybe value) ->
   -- |
-  Codec context value value
-withDefault defaultValue = dimapCodec f g
-  where
-    f :: Maybe value -> value
-    f = \case
-      Nothing -> defaultValue
-      Just value -> value
-    g :: value -> Maybe value
-    g = Just
+  ObjectCodec value value
+withDefault defaultValue = DefaultCodec defaultValue (T.pack (show defaultValue))
 
 -- | Infix version of 'withDefault'
 --
@@ -385,6 +390,7 @@ withDefault defaultValue = dimapCodec f g
 -- >         <*> optionalField "optional-with-default" .!= "default-value" .= exampleOptionalWithDefault
 (.!=) ::
   forall value.
+  Show value =>
   -- |
   ObjectCodec (Maybe value) (Maybe value) ->
   -- | default value