{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# OPTIONS_GHC -Wwarn #-}
module Data.Schema.OpenAPI.Haskell where

import qualified Data.HashMap.Strict       as HashMap
import           Data.List                 (sortOn)
import           Data.Maybe                (fromMaybe, mapMaybe)
import           Data.Schema.OpenAPI.Types (Content (contentSchema),
                                            Method (methodRequestBody), Path,
                                            Request (requestContent),
                                            SchemaObject (SchemaObject, schemaObjectProperties, schemaObjectRequired),
                                            SchemaType (..), Spec (specPaths))
import           Data.Text                 (Text)
import qualified Data.Text                 as Text
import           Data.Text.Casing          (pascal)

mkFieldType :: SchemaType -> Maybe Text
mkFieldType :: SchemaType -> Maybe Text
mkFieldType SchemaTypeObject{}  = Maybe Text
forall a. Maybe a
Nothing  -- TODO
mkFieldType SchemaTypeString{}  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"String"
mkFieldType SchemaTypeBoolean{} = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Bool"
mkFieldType SchemaTypeInteger{} = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Int"
mkFieldType SchemaTypeNumber{}  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Float"
mkFieldType SchemaType
x                   = [Char] -> Maybe Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe Text) -> [Char] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ SchemaType -> [Char]
forall a. Show a => a -> [Char]
show SchemaType
x

mkField :: Text -> [Text] -> Text -> SchemaType -> Maybe Text
mkField :: Text -> [Text] -> Text -> SchemaType -> Maybe Text
mkField Text
prefix [Text]
req Text
name SchemaType
ty = do
    Text
innerTy <- SchemaType -> Maybe Text
mkFieldType SchemaType
ty
    let fieldTy :: Text
fieldTy = if Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
req
        then Text
innerTy
        else Text
"Maybe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
innerTy
    Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
pascal Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fieldTy

mkTypeName :: Text
mkTypeName :: Text
mkTypeName = Text
"data EditRepo = EditRepo"

mkType :: SchemaType -> Maybe Text
mkType :: SchemaType -> Maybe Text
mkType (SchemaTypeObject SchemaObject{Maybe [Text]
Maybe (HashMap Text SchemaType)
schemaObjectRequired :: Maybe [Text]
schemaObjectProperties :: Maybe (HashMap Text SchemaType)
schemaObjectRequired :: SchemaObject -> Maybe [Text]
schemaObjectProperties :: SchemaObject -> Maybe (HashMap Text SchemaType)
..}) = do
    HashMap Text SchemaType
props <- Maybe (HashMap Text SchemaType)
schemaObjectProperties
    let req :: [Text]
req = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
schemaObjectRequired
    let fields :: [Text]
fields = ((Text, SchemaType) -> Maybe Text)
-> [(Text, SchemaType)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Text -> SchemaType -> Maybe Text)
-> (Text, SchemaType) -> Maybe Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> [Text] -> Text -> SchemaType -> Maybe Text
mkField Text
"editRepo" [Text]
req)) ([(Text, SchemaType)] -> [Text])
-> (HashMap Text SchemaType -> [(Text, SchemaType)])
-> HashMap Text SchemaType
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, SchemaType) -> Text)
-> [(Text, SchemaType)] -> [(Text, SchemaType)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text, SchemaType) -> Text
forall a b. (a, b) -> a
fst ([(Text, SchemaType)] -> [(Text, SchemaType)])
-> (HashMap Text SchemaType -> [(Text, SchemaType)])
-> HashMap Text SchemaType
-> [(Text, SchemaType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text SchemaType -> [(Text, SchemaType)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap Text SchemaType -> [Text])
-> HashMap Text SchemaType -> [Text]
forall a b. (a -> b) -> a -> b
$ HashMap Text SchemaType
props
    Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
mkTypeName
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    { "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"\n    , " [Text]
fields
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    } deriving (Eq)"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n$(deriveJSON defaultOptions{fieldLabelModifier = quietSnake . drop (length \"EditRepo\")} ''EditRepo)"
mkType SchemaType
ty = [Char] -> Maybe Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe Text) -> [Char] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ SchemaType -> [Char]
forall a. Show a => a -> [Char]
show SchemaType
ty

toHaskell :: Spec -> Text -> (Path -> Maybe Method) -> Maybe Text
toHaskell :: Spec -> Text -> (Path -> Maybe Method) -> Maybe Text
toHaskell Spec
spec Text
pathName Path -> Maybe Method
getMethod =
    Text -> HashMap Text Path -> Maybe Path
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup Text
pathName (Spec -> HashMap Text Path
specPaths Spec
spec)
        Maybe Path -> (Path -> Maybe Method) -> Maybe Method
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path -> Maybe Method
getMethod
        Maybe Method -> (Method -> Maybe Request) -> Maybe Request
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Method -> Maybe Request
methodRequestBody
        Maybe Request -> (Request -> Maybe Content) -> Maybe Content
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> HashMap Text Content -> Maybe Content
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"application/json" (HashMap Text Content -> Maybe Content)
-> (Request -> HashMap Text Content) -> Request -> Maybe Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> HashMap Text Content
requestContent
        Maybe Content -> (Content -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchemaType -> Maybe Text
mkType (SchemaType -> Maybe Text)
-> (Content -> SchemaType) -> Content -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> SchemaType
contentSchema