{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Utility functions for the OpenAPI code generator
module OpenAPI.Generate.Internal.Util
  ( haskellifyText,
    haskellifyName,
    haskellifyNameM,
    transformToModuleName,
    uppercaseFirstText,
    mapMaybeM,
    liftedAppend,
    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.Monad as OAM
import qualified OpenAPI.Generate.OptParse as OAO

-- | Checks if the casing of a character can be changed.
-- This is required to ensure the functions 'Char.toUpper' and 'Char.toLower' actually do something.
isCasableAlpha :: Char -> Bool
isCasableAlpha :: Char -> Bool
isCasableAlpha Char
x = Char -> Bool
Char.isLower (Char -> Char
Char.toLower Char
x) Bool -> Bool -> Bool
&& Char -> Bool
Char.isUpper (Char -> Char
Char.toUpper Char
x)

isValidCharaterInSuffixExceptUnderscore :: Char -> Bool
isValidCharaterInSuffixExceptUnderscore :: Char -> Bool
isValidCharaterInSuffixExceptUnderscore Char
x = Char -> Bool
isCasableAlpha Char
x Bool -> Bool -> Bool
|| Char -> Bool
Char.isDigit Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

removeIllegalLeadingCharacters :: String -> String
removeIllegalLeadingCharacters :: String -> String
removeIllegalLeadingCharacters (Char
x : String
xs) | Bool -> Bool
not (Char -> Bool
isCasableAlpha Char
x) = String -> String
removeIllegalLeadingCharacters String
xs
removeIllegalLeadingCharacters String
x = String
x

generateNameForEmptyIdentifier :: Text -> String -> String
generateNameForEmptyIdentifier :: Text -> String -> String
generateNameForEmptyIdentifier Text
originalName String
"" = String
"identifier" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ((Char -> Int -> Int) -> Int -> Text -> Int
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> (Char -> Int) -> Char -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
Char.ord) Int
0 Text
originalName)
generateNameForEmptyIdentifier Text
_ String
name = String
name

-- | Transform an identifier to ensure it is a valid Haskell identifier
-- Additionally, this function applies style settings according to the need of the consumer.
haskellifyText ::
  -- | Should the identifier be transformed to CamelCase?
  Bool ->
  -- | Should the first character of the identifier be uppercase?
  Bool ->
  -- | The identifier to transform
  Text ->
  -- | The resulting identifier
  Text
haskellifyText :: Bool -> Bool -> Text -> Text
haskellifyText Bool
convertToCamelCase Bool
startWithUppercase Text
name =
  let casefn :: Char -> Char
casefn = if Bool
startWithUppercase then Char -> Char
Char.toUpper else Char -> Char
Char.toLower
      replaceChar :: Char -> Char
replaceChar Char
'.' = Char
'\''
      replaceChar Char
'\'' = Char
'\''
      replaceChar Char
a = if Char -> Bool
isValidCharaterInSuffixExceptUnderscore Char
a then Char
a else Char
'_'
      caseFirstCharCorrectly :: String -> String
caseFirstCharCorrectly (Char
x : String
xs) = Char -> Char
casefn Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
      caseFirstCharCorrectly String
x = String
x
      nameWithoutSpecialChars :: f Char -> f Char
nameWithoutSpecialChars f Char
a = Char -> Char
replaceChar (Char -> Char) -> f Char -> f Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Char
a
      toCamelCase :: String -> String
toCamelCase (Char
x : Char
y : String
xs) | Bool -> Bool
not (Char -> Bool
isValidCharaterInSuffixExceptUnderscore Char
x) Bool -> Bool -> Bool
&& Char -> Bool
isCasableAlpha Char
y = Char -> Char
Char.toUpper Char
y Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toCamelCase String
xs
      toCamelCase (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toCamelCase String
xs
      toCamelCase String
xs = String
xs
      replaceReservedWord :: a -> a
replaceReservedWord a
"case" = a
"case'"
      replaceReservedWord a
"class" = a
"class'"
      replaceReservedWord a
"data" = a
"data'"
      replaceReservedWord a
"default" = a
"default'"
      replaceReservedWord a
"deriving" = a
"deriving'"
      replaceReservedWord a
"do" = a
"do'"
      replaceReservedWord a
"else" = a
"else'"
      replaceReservedWord a
"if" = a
"if'"
      replaceReservedWord a
"import" = a
"import'"
      replaceReservedWord a
"in" = a
"in'"
      replaceReservedWord a
"infix" = a
"infix'"
      replaceReservedWord a
"infixl" = a
"infixl'"
      replaceReservedWord a
"infixr" = a
"infixr'"
      replaceReservedWord a
"instance" = a
"instance'"
      replaceReservedWord a
"let" = a
"let'"
      replaceReservedWord a
"module" = a
"module'"
      replaceReservedWord a
"newtype" = a
"newtype'"
      replaceReservedWord a
"of" = a
"of'"
      replaceReservedWord a
"then" = a
"then'"
      replaceReservedWord a
"type" = a
"type'"
      replaceReservedWord a
"where" = a
"where'"
      replaceReservedWord a
"Configuration" = a
"Configuration'"
      replaceReservedWord a
"MonadHTTP" = a
"MonadHTTP'"
      replaceReservedWord a
"SecurityScheme" = a
"SecurityScheme'"
      replaceReservedWord a
"AnonymousSecurityScheme" = a
"AnonymousSecurityScheme'"
      replaceReservedWord a
"JsonByteString" = a
"JsonByteString'"
      replaceReservedWord a
"JsonDateTime" = a
"JsonDateTime'"
      replaceReservedWord a
"RequestBodyEncoding" = a
"RequestBodyEncoding'"
      replaceReservedWord a
"QueryParameter" = a
"QueryParameter'"
      replaceReservedWord a
a = a
a
      replacePlus :: String -> String
replacePlus (Char
'+' : String
rest) = String
"Plus" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
replacePlus String
rest
      replacePlus (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
replacePlus String
xs
      replacePlus String
a = String
a
   in String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
        String -> String
forall {a}. (Eq a, IsString a) => a -> a
replaceReservedWord (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
          String -> String
caseFirstCharCorrectly (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
            Text -> String -> String
generateNameForEmptyIdentifier Text
name (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
              String -> String
removeIllegalLeadingCharacters (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                (if Bool
convertToCamelCase then String -> String
toCamelCase else String -> String
forall a. a -> a
id) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                  String -> String
forall {f :: * -> *}. Functor f => f Char -> f Char
nameWithoutSpecialChars (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                    String -> String
replacePlus (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                      Text -> String
T.unpack Text
name

-- | The same as 'haskellifyText' but transform the result to a 'Name'
haskellifyName :: Bool -> Bool -> Text -> Name
haskellifyName :: Bool -> Bool -> Text -> Name
haskellifyName Bool
convertToCamelCase Bool
startWithUppercase Text
name = String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Text -> Text
haskellifyText Bool
convertToCamelCase Bool
startWithUppercase Text
name

-- | 'OAM.Generator' version of 'haskellifyName'
haskellifyNameM :: Bool -> Text -> OAM.Generator Name
haskellifyNameM :: Bool -> Text -> Generator Name
haskellifyNameM Bool
startWithUppercase Text
name = do
  Bool
convertToCamelCase <- (Settings -> Bool) -> Generator Bool
forall a. (Settings -> a) -> Generator a
OAM.getSetting Settings -> Bool
OAO.settingConvertToCamelCase
  Name -> Generator Name
forall a. a -> Generator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Generator Name) -> Name -> Generator Name
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Text -> Name
haskellifyName Bool
convertToCamelCase Bool
startWithUppercase Text
name

-- | Transform a module name to ensure it is valid for file names
transformToModuleName :: Text -> Text
transformToModuleName :: Text -> Text
transformToModuleName Text
name =
  let toCamelCase :: String -> String
toCamelCase (Char
x : Char
y : String
xs) | Bool -> Bool
not (Char -> Bool
isValidCharaterInSuffixExceptUnderscore Char
x) Bool -> Bool -> Bool
&& Char -> Bool
isCasableAlpha Char
y = Char -> Char
Char.toUpper Char
y Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toCamelCase String
xs
      toCamelCase (Char
'\'' : Char
y : String
xs) | Char -> Bool
isCasableAlpha Char
y = Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
Char.toUpper Char
y Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toCamelCase String
xs
      toCamelCase (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toCamelCase String
xs
      toCamelCase String
xs = String
xs
   in String -> Text
T.pack
        (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
uppercaseFirst
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String -> String
generateNameForEmptyIdentifier Text
name
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
removeIllegalLeadingCharacters
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ( \case
              Char
'\'' -> Char
'_'
              Char
c -> Char
c
          )
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
toCamelCase
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack
        (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Text -> Text
T.map
          ( \case
              Char
'.' -> Char
'\''
              Char
c | Char -> Bool
isValidCharaterInSuffixExceptUnderscore Char
c -> Char
c
              Char
_ -> Char
'_'
          )
          Text
name

uppercaseFirst :: String -> String
uppercaseFirst :: String -> String
uppercaseFirst (Char
x : String
xs) = Char -> Char
Char.toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
uppercaseFirst String
x = String
x

-- | Uppercase the first character of a 'Text'
uppercaseFirstText :: Text -> Text
uppercaseFirstText :: Text -> Text
uppercaseFirstText = String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
uppercaseFirst (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- | Concat a list of strings with a point
--
-- >>> joinWithPoint ["a", "b", "c"]
-- "a.b.c"
joinWithPoint :: [String] -> String
joinWithPoint :: [String] -> String
joinWithPoint = String -> [String] -> String
forall a. Monoid a => a -> [a] -> a
joinWith String
"."

-- | Concat a list of values separated by an other value
joinWith :: (Monoid a) => a -> [a] -> a
joinWith :: forall a. Monoid a => a -> [a] -> a
joinWith a
_ [] = a
forall a. Monoid a => a
mempty
joinWith a
separator [a]
xs =
  (a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1
    ( \a
part1 a
part2 -> a
part1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
separator a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
part2
    )
    [a]
xs

-- | A version of 'Data.Maybe.mapMaybe' that works with a monadic predicate.
-- from https://hackage.haskell.org/package/extra-1.7.1/docs/src/Control.Monad.Extra.html#mapMaybeM copied
mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
op = (a -> m [b] -> m [b]) -> m [b] -> [a] -> m [b]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> m [b] -> m [b]
f ([b] -> m [b]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
  where
    f :: a -> m [b] -> m [b]
f a
x m [b]
xs = do Maybe b
x' <- a -> m (Maybe b)
op a
x; case Maybe b
x' of Maybe b
Nothing -> m [b]
xs; Just b
x'' -> do [b]
xs' <- m [b]
xs; [b] -> m [b]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ b
x'' b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
xs'

-- | Lifted version of '<>' which can be used with 'Semigroup's inside 'Applicative's
liftedAppend :: (Applicative f, Semigroup a) => f a -> f a -> f a
liftedAppend :: forall (f :: * -> *) a.
(Applicative f, Semigroup a) =>
f a -> f a -> f a
liftedAppend = (a -> a -> a) -> f a -> f a -> f a
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
Applicative.liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)