{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Utility functions for 'Language.Haskell.TH.PprLib.Doc' manipulation
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
-- | Empty document inside an 'Applicative' (typically 'Language.Haskell.TH.Q')
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")
-- | Append a 'Doc' to another inside an 'Applicative' (typically 'Language.Haskell.TH.Q')
appendDoc :: Applicative f => f Doc -> f Doc -> f Doc
appendDoc = Applicative.liftA2 ($$)
-- | Generate a Haddock comment with multiple lines
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)
-- | Escape text for use in Haddock comment
escapeText :: Text -> Text
escapeText =
T.replace "'" "\\'"
. T.replace "\"" "\\\""
. T.replace "`" "\\`"
. T.replace "@" "\\@"
. T.replace "$" "\\$"
. T.replace "#" "\\#"
. T.replace "<" "\\<"
. T.replace "/" "\\/"
. T.replace "\\" "\\\\"
-- | Add line breaks to a 'Doc' at all occurrences of the passed tokens (removes all other line breaks).
breakOnTokens :: [Text] -> Doc -> Doc
breakOnTokens = breakOnTokensWithReplacement ("\n " <>)
-- | Add line breaks to a 'Doc' at all occurrences of the passed tokens (removes all other line breaks).
-- The replacement function is used to generate the text replacing the tokens.
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'
-- | Convert a list of lines to side comments
sideComments :: [Text] -> Doc
sideComments = vcat . fmap (text . T.unpack . T.replace "\n" " " . ("-- ^ " <>))
-- | Intertwine code lines with comment lines
--
-- The code lines should have one more line (the first line is not commented)
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
-- | Place two documents side-by-side, aligned at the top line
--
-- If one of the documents is longer than the other, the shorter one is extended with empty lines.
-- The lines of the right document are aligned in the same column, no matter if the left document is shorter or longer
--
-- Example usage:
--
-- >>> show $ sideBySide (text "a") (text "b" $$ text "c")
-- a b
-- c
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')
-- | Add the module header to a module of an operation
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
-- | Add the module header to a module of a model
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
-- | Add the module header to the security scheme module
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
-- | Add the module header to the configuration module
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
-- | Create a 'Doc' containing a module which imports other modules and re-exports them
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