{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module OpenAPI.Generate.Doc
( emptyDoc,
appendDoc,
generateHaddockComment,
escapeText,
breakOnTokens,
breakOnTokensWithReplacement,
sideComments,
zipCodeAndComments,
sideBySide,
addOperationsModuleHeader,
addSecuritySchemesModuleHeader,
addConfigurationModuleHeader,
createModuleHeaderWithReexports,
addModelModuleHeader,
)
where
import qualified Control.Applicative as Applicative
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH.PprLib hiding ((<>))
import OpenAPI.Generate.Internal.Util
emptyDoc :: Applicative f => f Doc
emptyDoc = pure empty
haddockIntro :: Doc
haddockIntro = text "-- |"
haddockLine :: Doc
haddockLine = text "--"
textToDoc :: Text -> Doc
textToDoc = text . T.unpack
line :: String -> Doc -> Doc
line = ($$) . text
emptyLine :: Doc -> Doc
emptyLine = line ""
languageExtension :: String -> Doc -> Doc
languageExtension = line . ("{-# LANGUAGE " <>) . (<> " #-}")
importQualified :: String -> Doc -> Doc
importQualified = importUnqualified . ("qualified " <>)
importUnqualified :: String -> Doc -> Doc
importUnqualified = line . ("import " <>)
moduleDescription :: String -> Doc -> Doc
moduleDescription = line . ("-- | " <>)
moduleDeclaration :: String -> String -> Doc -> Doc
moduleDeclaration modulePrefix name = line ("module " <> modulePrefix <> "." <> name <> " where")
appendDoc :: Applicative f => f Doc -> f Doc -> f Doc
appendDoc = Applicative.liftA2 ($$)
generateHaddockComment :: [Text] -> Doc
generateHaddockComment =
generateHaddockCommentWithoutNewlines
. ( >>=
( \case
[] -> [""]
x -> x
)
. T.lines
)
generateHaddockCommentWithoutNewlines :: [Text] -> Doc
generateHaddockCommentWithoutNewlines [] = empty
generateHaddockCommentWithoutNewlines [x] = haddockIntro <+> textToDoc x
generateHaddockCommentWithoutNewlines xs =
generateHaddockCommentWithoutNewlines (init xs)
$$ haddockLine <+> textToDoc (last xs)
escapeText :: Text -> Text
escapeText =
T.replace "'" "\\'"
. T.replace "\"" "\\\""
. T.replace "`" "\\`"
. T.replace "@" "\\@"
. T.replace "$" "\\$"
. T.replace "#" "\\#"
. T.replace "<" "\\<"
. T.replace "/" "\\/"
. T.replace "\\" "\\\\"
breakOnTokens :: [Text] -> Doc -> Doc
breakOnTokens = breakOnTokensWithReplacement ("\n " <>)
breakOnTokensWithReplacement :: (Text -> Text) -> [Text] -> Doc -> Doc
breakOnTokensWithReplacement replaceFn tokens =
let addLineBreaks = foldr (\token f -> T.replace token (replaceFn token) . f) id tokens
in text . T.unpack . addLineBreaks . T.replace "\n" "" . removeDuplicateSpaces . T.pack . show
removeDuplicateSpaces :: Text -> Text
removeDuplicateSpaces t =
let t' = T.replace " " " " t
in if t == t' then t' else removeDuplicateSpaces t'
sideComments :: [Text] -> Doc
sideComments = vcat . fmap (text . T.unpack . T.replace "\n" " " . ("-- ^ " <>))
zipCodeAndComments :: [Text] -> [Text] -> Doc
zipCodeAndComments [] _ = empty
zipCodeAndComments [x] _ = textToDoc x
zipCodeAndComments (x : xs) [] = textToDoc x $$ zipCodeAndComments xs []
zipCodeAndComments (x : xs) (y : ys) = textToDoc x $$ nest 2 (generateHaddockComment [y]) $$ zipCodeAndComments xs ys
sideBySide :: Doc -> Doc -> Doc
sideBySide leftDoc rightDoc =
let splitDoc = splitOn '\n' . show
leftDocLines = splitDoc leftDoc
leftDoc' = map text leftDocLines
maxLength = foldr max 0 (fmap length leftDocLines) + 1
rightDoc' = map (nest maxLength . text) . splitDoc $ rightDoc
isLeftLonger = length leftDoc' > length rightDoc'
isRightLonger = length leftDoc' < length rightDoc'
in foldl ($$) empty $
zipWith
($$)
(if isRightLonger then leftDoc' <> repeat empty else leftDoc')
(if isLeftLonger then rightDoc' <> repeat empty else rightDoc')
addOperationsModuleHeader :: String -> String -> String -> Doc -> Doc
addOperationsModuleHeader mainModuleName moduleName operationId =
languageExtension "OverloadedStrings"
. languageExtension "ExplicitForAll"
. languageExtension "MultiWayIf"
. languageExtension "DeriveGeneric"
. emptyLine
. moduleDescription ("Contains the different functions to run the operation " <> operationId)
. moduleDeclaration (mainModuleName <> ".Operations") moduleName
. emptyLine
. importQualified "Prelude as GHC.Integer.Type"
. importQualified "Prelude as GHC.Maybe"
. importQualified "Control.Monad.Trans.Reader"
. importQualified "Data.Aeson"
. importQualified "Data.Aeson as Data.Aeson.Types"
. importQualified "Data.Aeson as Data.Aeson.Types.FromJSON"
. importQualified "Data.Aeson as Data.Aeson.Types.ToJSON"
. importQualified "Data.Aeson as Data.Aeson.Types.Internal"
. importQualified "Data.ByteString.Char8"
. importQualified "Data.ByteString.Char8 as Data.ByteString.Internal"
. importQualified "Data.Either"
. importQualified "Data.Functor"
. importQualified "Data.Scientific"
. importQualified "Data.Text"
. importQualified "Data.Text.Internal"
. importQualified "Data.Time.Calendar as Data.Time.Calendar.Days"
. importQualified "Data.Time.LocalTime as Data.Time.LocalTime.Internal.ZonedTime"
. importQualified "GHC.Base"
. importQualified "GHC.Classes"
. importQualified "GHC.Generics"
. importQualified "GHC.Int"
. importQualified "GHC.Show"
. importQualified "GHC.Types"
. importQualified "Network.HTTP.Client"
. importQualified "Network.HTTP.Client as Network.HTTP.Client.Request"
. importQualified "Network.HTTP.Client as Network.HTTP.Client.Types"
. importQualified "Network.HTTP.Simple"
. importQualified "Network.HTTP.Types"
. importQualified "Network.HTTP.Types as Network.HTTP.Types.Status"
. importQualified "Network.HTTP.Types as Network.HTTP.Types.URI"
. importQualified (mainModuleName <> ".Common")
. importUnqualified (mainModuleName <> ".Types")
. emptyLine
addModelModuleHeader :: String -> String -> [String] -> String -> Doc -> Doc
addModelModuleHeader mainModuleName moduleName modelModulesToImport description =
languageExtension "OverloadedStrings"
. languageExtension "DeriveGeneric"
. emptyLine
. moduleDescription description
. moduleDeclaration mainModuleName moduleName
. emptyLine
. importQualified "Prelude as GHC.Integer.Type"
. importQualified "Prelude as GHC.Maybe"
. importQualified "Data.Aeson"
. importQualified "Data.Aeson as Data.Aeson.Types"
. importQualified "Data.Aeson as Data.Aeson.Types.FromJSON"
. importQualified "Data.Aeson as Data.Aeson.Types.ToJSON"
. importQualified "Data.Aeson as Data.Aeson.Types.Internal"
. importQualified "Data.ByteString.Char8"
. importQualified "Data.ByteString.Char8 as Data.ByteString.Internal"
. importQualified "Data.Functor"
. importQualified "Data.Scientific"
. importQualified "Data.Text"
. importQualified "Data.Text.Internal"
. importQualified "Data.Time.Calendar as Data.Time.Calendar.Days"
. importQualified "Data.Time.LocalTime as Data.Time.LocalTime.Internal.ZonedTime"
. importQualified "GHC.Base"
. importQualified "GHC.Classes"
. importQualified "GHC.Generics"
. importQualified "GHC.Int"
. importQualified "GHC.Show"
. importQualified "GHC.Types"
. importQualified (mainModuleName <> ".Common")
. (vcat (fmap (text . ("import " <>) . ((mainModuleName <> ".") <>)) modelModulesToImport) $$)
. emptyLine
addSecuritySchemesModuleHeader :: String -> Doc -> Doc
addSecuritySchemesModuleHeader moduleName =
languageExtension "OverloadedStrings"
. emptyLine
. moduleDescription "Contains all supported security schemes defined in the specification"
. moduleDeclaration moduleName "SecuritySchemes"
. emptyLine
. importQualified "Data.Text.Internal"
. importQualified "GHC.Base"
. importQualified "GHC.Classes"
. importQualified "GHC.Show"
. importQualified "Network.HTTP.Client as Network.HTTP.Client.Request"
. importQualified "Network.HTTP.Simple"
. importQualified (moduleName <> ".Common")
. emptyLine
addConfigurationModuleHeader :: String -> Doc -> Doc
addConfigurationModuleHeader moduleName =
languageExtension "OverloadedStrings"
. emptyLine
. moduleDescription "Contains the default configuration"
. moduleDeclaration moduleName "Configuration"
. emptyLine
. importQualified "Data.Text"
. importQualified (moduleName <> ".Common")
. emptyLine
createModuleHeaderWithReexports :: String -> [String] -> String -> Doc
createModuleHeaderWithReexports moduleName modulesToExport description =
let exports = vcat $ fmap (text . ("module " <>) . (<> ",")) modulesToExport
imports = vcat $ fmap (text . ("import " <>)) modulesToExport
in moduleDescription description $
text ("module " <> moduleName <> " (")
$$ nest
2
( exports
$$ text ") where"
)
$$ text ""
$$ imports