{-# LANGUAGE OverloadedStrings #-}
module OpenAPI.Generate.Internal.Util
( haskellifyText,
haskellifyName,
haskellifyNameM,
transformToModuleName,
uppercaseFirstText,
mapMaybeM,
liftedAppend,
splitOn,
joinWithPoint,
joinWith,
)
where
import qualified Control.Applicative as Applicative
import qualified Data.Char as Char
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
import qualified OpenAPI.Generate.Flags as OAF
import qualified OpenAPI.Generate.Monad as OAM
haskellifyText ::
Bool ->
Bool ->
Text ->
String
haskellifyText convertToCamelCase startWithUppercase name =
let casefn = if startWithUppercase then Char.toUpper else Char.toLower
replaceChar '.' = '\''
replaceChar '\'' = '\''
replaceChar a = if Char.isAlphaNum a then a else '_'
caseFirstCharCorrectly (x : xs) = casefn x : xs
caseFirstCharCorrectly x = x
nameWithoutSpecialChars a = replaceChar <$> a
toCamelCase (x : y : xs) | not (Char.isAlphaNum x) && x /= '\'' && Char.isAlpha y = Char.toUpper y : toCamelCase xs
toCamelCase (x : xs) = x : toCamelCase xs
toCamelCase xs = xs
replaceReservedWord "case" = "case'"
replaceReservedWord "class" = "class'"
replaceReservedWord "data" = "data'"
replaceReservedWord "deriving" = "deriving'"
replaceReservedWord "do" = "do'"
replaceReservedWord "else" = "else'"
replaceReservedWord "if" = "if'"
replaceReservedWord "import" = "import'"
replaceReservedWord "in" = "in'"
replaceReservedWord "infix" = "infix'"
replaceReservedWord "infixl" = "infixl'"
replaceReservedWord "infixr" = "infixr'"
replaceReservedWord "instance" = "instance'"
replaceReservedWord "let" = "let'"
replaceReservedWord "of" = "of'"
replaceReservedWord "module" = "module'"
replaceReservedWord "newtype" = "newtype'"
replaceReservedWord "then" = "then'"
replaceReservedWord "type" = "type'"
replaceReservedWord "where" = "where'"
replaceReservedWord "Configuration" = "Configuration'"
replaceReservedWord "MonadHTTP" = "MonadHTTP'"
replaceReservedWord "StringifyModel" = "StringifyModel'"
replaceReservedWord "SecurityScheme" = "SecurityScheme'"
replaceReservedWord "AnonymousSecurityScheme" = "AnonymousSecurityScheme'"
replaceReservedWord "JsonByteString" = "JsonByteString'"
replaceReservedWord "JsonDateTime" = "JsonDateTime'"
replaceReservedWord "RequestBodyEncoding" = "RequestBodyEncoding'"
replaceReservedWord ('_' : rest) = replaceReservedWord rest
replaceReservedWord a = a
replacePlus ('+' : rest) = "Plus" <> replacePlus rest
replacePlus (x : xs) = x : replacePlus xs
replacePlus a = a
in replaceReservedWord
$ caseFirstCharCorrectly
$ (if convertToCamelCase then toCamelCase else id)
$ nameWithoutSpecialChars
$ replacePlus
$ T.unpack name
haskellifyName :: Bool -> Bool -> Text -> Name
haskellifyName convertToCamelCase startWithUppercase name = mkName $ haskellifyText convertToCamelCase startWithUppercase name
haskellifyNameM :: Bool -> Text -> OAM.Generator Name
haskellifyNameM startWithUppercase name = do
flags <- OAM.getFlags
pure $ haskellifyName (OAF.optConvertToCamelCase flags) startWithUppercase name
transformToModuleName :: Text -> Text
transformToModuleName =
let toCamelCase (x : y : xs) | not (Char.isAlphaNum x) && Char.isAlpha y = Char.toUpper y : toCamelCase xs
toCamelCase (x : xs) = x : toCamelCase xs
toCamelCase xs = xs
in T.pack
. toCamelCase
. uppercaseFirst
. T.unpack
. T.dropWhile (== '_')
. T.map (\c -> if Char.isAlphaNum c then c else '_')
uppercaseFirst :: String -> String
uppercaseFirst (x : xs) = Char.toUpper x : xs
uppercaseFirst x = x
uppercaseFirstText :: Text -> Text
uppercaseFirstText = T.pack . uppercaseFirst . T.unpack
joinWithPoint :: [String] -> String
joinWithPoint = joinWith "."
joinWith :: Monoid a => a -> [a] -> a
joinWith _ [] = mempty
joinWith separator xs =
foldr1
( \part1 part2 -> part1 <> separator <> part2
)
xs
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn x =
foldr
( \element (currentAcc : acc) ->
if element == x
then [] : currentAcc : acc
else (element : currentAcc) : acc
)
[[]]
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM op = foldr f (pure [])
where
f x xs = do x' <- op x; case x' of { Nothing -> xs; Just x'' -> do { xs' <- xs; pure $ x'' : xs' } }
liftedAppend :: (Applicative f, Semigroup a) => f a -> f a -> f a
liftedAppend = Applicative.liftA2 (<>)