Servant swagger template haskell

Shared.Common.TH.hs

-- |Infer a type constructor by name.
-- **NOTE** Does not give context for applied parameters, so may need to add that later.
extractTypeConstructor :: Name -> Q Type
extractTypeConstructor ty =
  reify ty >>= \ case
    TyConI (NewtypeD _ n ts _ _ _) | n == ty -> foldr appConstructor (conT n) ts
    TyConI (DataD _ n ts _ _ _) | n == ty -> foldr appConstructor (conT n) ts
    TyConI (TySynD n _ t) | n == ty -> pure t
    other -> fail ("couldn't reify type: " <> show other)
  where
    appConstructor x y = case x of
      PlainTV t    -> appT y (varT t)
      KindedTV t _ -> appT y (varT t)

-- |Get the base type of a type synonym `type Foo = Bar a b c` by unwrapping all its layers down to
-- `Bar`.
extractSynonymType :: Type -> Q Name
extractSynonymType = \ case
  AppT x _ -> extractSynonymType x
  ConT tyName -> pure tyName
  other -> fail ("couldn't extract type name: " <> show other)

-- |From a type, extract any synonym to a base type and name. For regular data constructors this
-- should be the identity function on the name and a ConT type.
reifyType :: Name -> Q (Name, Type)
reifyType ty = do
  tyCon <- extractTypeConstructor ty
  tyName <- extractSynonymType tyCon
  pure (tyName, tyCon)

-- |Infer a record to be using record syntax with a leading underscore and lowercased first
-- character.
makeRecordPrefix :: Name -> Q String
makeRecordPrefix tyName =
  case nameBase tyName of
    ""   -> fail "type was empty"
    x:xs -> pure $ '_':(toLower x):xs

Shared.Swagger.Helpers.hs

enumSchema :: [Text] -> Schema
enumSchema ts = mempty
  & type_ .~ SwaggerString
  & paramSchema .~ (mempty
    & type_ .~ SwaggerString
    & enum_ ?~ map String ts)

-- |Remove the given prefix from field names, and strip trailing @'@s from type names.
unprefix :: Text -> SchemaOptions
unprefix prefix = SchemaOptions
  { fieldLabelModifier = unpack . toLowerWithPrefix prefix . pack
  , constructorTagModifier = id
  , datatypeNameModifier = unpack . dropWhileEnd (== '\'') . pack
  , allNullaryToStringTag = True
  , unwrapUnaryRecords = False
  }

unwrap :: SchemaOptions
unwrap = SchemaOptions
  { fieldLabelModifier = id
  , constructorTagModifier = id
  , datatypeNameModifier = id
  , allNullaryToStringTag = True
  , unwrapUnaryRecords = True
  }

Shared.Swagger.TH.hs

-- |Build Swagger ToSchema instance with TH.
--
-- Given
-- @
--   data MyEnum = MyEnumFoo | MyEnumBar
-- @
--
-- This splice
--
-- @
--   makeSwaggerEnum '_MyEnumAsText ''MyEnum
-- @
--
-- is equivalent to:
--
-- @
--   instance ToSchema MyEnum where
--     declareNamedSchema = NamedSchema (Just "MyEnum") $ enumSchema $ review _MyEnumAsText <$> genum
-- @
makeSwaggerEnums :: Name -> Name -> Q [Dec]
makeSwaggerEnums prismName tySyn = do
  (tyName, tyCon) <- reifyType tySyn
  let base = nameBase tyName
      values = [|review $(varE prismName) <$> genum|]
  sequence
    [ instanceD
        (cxt [])
        [t| ToSchema $(pure tyCon) |]
        [ funD
            'declareNamedSchema
            [ clause [wildP] (normalB [| pure $ NamedSchema (Just $ pack base) $ enumSchema $(values) |]) [] ]
        ]
    , instanceD
        (cxt [])
        [t| ToParamSchema $(pure tyCon) |]
        [ funD
            'toParamSchema
            [ clause [wildP] (normalB [| toParamSchema (Proxy @Text) & enum_ ?~ map String $(values) |]) [] ]
        ]
    ]

-- |Build Swagger ToSchema and ToParamSchema instances with TH, and assume that the Enum is
-- structured so that each constructor is prefixed with the type name.
deriveSwaggerEnums :: Name -> Q [Dec]
deriveSwaggerEnums tyName = do
  let prefix = nameBase tyName
      prismName = mkName $ "_" <> prefix <> "AsText"
  makeSwaggerEnums prismName tyName

-- |Build Swagger ToSchema instance with TH.
--
-- Given
-- @
--   data Foo = Foo
--     { _fooA :: Char
--     , _fooB :: Int
--     } deriving (Eq, Ord, Show, Generic)
-- @
--
-- This splice
--
-- @
--   makeSwaggerRecord "_foo" ''Foo
-- @
--
-- is equivalent to:
--
-- @
--   instance ToSchema Foo where
--     declareNamedSchema = map (NamedSchema (Just "Foo")) . genericDeclareSchema (unprefix "_foo")
-- @
makeSwaggerRecord :: String -> Name -> Q [Dec]
makeSwaggerRecord prefix tySyn = do
  (tyName, tyCon) <- reifyType tySyn
  let synBase = nameBase tySyn
      tyBase = nameBase tyName
  unprefixed <- case prefix of
    '_':x:xs -> pure $ (toUpper x):xs
    x:xs     -> pure $ (toUpper x):xs
    []       -> fail "no prefix specified"
  unless (unprefixed `isPrefixOf` tyBase) $ fail $ "prefix " <> prefix <> " did not match type name " <> tyBase
  sequence
    [ instanceD
        (cxt [])
        [t| ToSchema $(pure tyCon) |]
        [ funD
            'declareNamedSchema
            [ clause [] (normalB [| map (NamedSchema (Just synBase)) . genericDeclareSchema (unprefix prefix) |]) [] ]
        ]
    ]

-- |Build Swagger instance with TH, and assume that the record is structured so that each field is
-- prefixed with an underscore, then the type name with the first letter in lowercase.
deriveSwaggerRecord :: Name -> Q [Dec]
deriveSwaggerRecord tyName = makeRecordPrefix tyName >>= flip makeSwaggerRecord tyName

-- |Derive a ToSchema instance through a newtype
deriveSwaggerNewtype :: Name -> Q [Dec]
deriveSwaggerNewtype tySyn = do
  (_tyName, tyCon) <- reifyType tySyn
  let synBase = nameBase tySyn
  sequence
    [ instanceD
        (cxt [])
        [t| ToSchema $(pure tyCon) |]
        [ funD
            'declareNamedSchema
            [ clause [] (normalB [| map (NamedSchema (Just synBase)) . genericDeclareSchema unwrap |]) [] ]
        ]
    ]

-- |Derive ToSchema and ToParamSchema instances through a newtype
deriveSwaggerNewtypes :: Name -> Q [Dec]
deriveSwaggerNewtypes tySyn = do
  (_tyName, tyCon) <- reifyType tySyn
  s <- deriveSwaggerNewtype tySyn
  ps <- sequence
    [ instanceD
        (cxt [])
        [t| ToParamSchema $(pure tyCon) |]
        [ funD
            'toParamSchema
            [ clause [] (normalB [| genericToParamSchema unwrap |]) [] ]
        ]
    ]
  pure $ s <> ps