{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.CodeGen.Internal.Name
  ( toHaskellTypeName,
    camelCaseTypeName,
    toHaskellName,
    camelCaseFieldName,
  )
where

import Data.Char
  ( toLower,
    toUpper,
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    TypeName,
    packName,
    unpackName,
  )
import qualified Data.Morpheus.Types.Internal.AST as N
import qualified Data.Text as T
import Relude hiding
  ( ToString (..),
    Type,
  )

mapFstChar :: (Char -> Char) -> Text -> Text
mapFstChar :: (Char -> Char) -> Text -> Text
mapFstChar Char -> Char
f Text
x
  | Text -> Bool
T.null Text
x = Text
x
  | Bool
otherwise = Char -> Text
T.singleton (Char -> Char
f forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
x) forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.tail Text
x

capitalize :: Text -> Text
capitalize :: Text -> Text
capitalize = (Char -> Char) -> Text -> Text
mapFstChar Char -> Char
toUpper

camelCaseTypeName :: [N.Name t] -> TypeName -> TypeName
camelCaseTypeName :: forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [Name t]
list TypeName
name =
  forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
capitalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName) ([Name t]
list forall a. Semigroup a => a -> a -> a
<> [coerce :: forall a b. Coercible a b => a -> b
coerce TypeName
name])

toHaskellTypeName :: TypeName -> Text
toHaskellTypeName :: TypeName -> Text
toHaskellTypeName TypeName
"String" = Text
"Text"
toHaskellTypeName TypeName
"Boolean" = Text
"Bool"
toHaskellTypeName TypeName
"Float" = Text
"Double"
toHaskellTypeName TypeName
name
  | Text -> Char
T.head (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name) forall a. Eq a => a -> a -> Bool
== Char
'_' = Text -> Text
capitalize forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name)
  | Bool
otherwise = Text -> Text
capitalize forall a b. (a -> b) -> a -> b
$ forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name
{-# INLINE toHaskellTypeName #-}

uncapitalize :: Text -> Text
uncapitalize :: Text -> Text
uncapitalize = (Char -> Char) -> Text -> Text
mapFstChar Char -> Char
toLower

camelCaseFieldName :: TypeName -> FieldName -> FieldName
camelCaseFieldName :: TypeName -> FieldName -> FieldName
camelCaseFieldName TypeName
nSpace FieldName
name =
  forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$
    Text -> Text
uncapitalize (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
nSpace)
      forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
name)

toHaskellName :: FieldName -> String
toHaskellName :: FieldName -> String
toHaskellName FieldName
name
  | FieldName -> Bool
isReserved FieldName
name = Text -> String
T.unpack (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
name forall a. Semigroup a => a -> a -> a
<> Text
"'")
  | Bool
otherwise = Text -> String
T.unpack (Text -> Text
uncapitalize (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
name))
{-# INLINE toHaskellName #-}

-- handle reserved Names
isReserved :: FieldName -> Bool
isReserved :: FieldName -> Bool
isReserved FieldName
"case" = Bool
True
isReserved FieldName
"class" = Bool
True
isReserved FieldName
"data" = Bool
True
isReserved FieldName
"default" = Bool
True
isReserved FieldName
"deriving" = Bool
True
isReserved FieldName
"do" = Bool
True
isReserved FieldName
"else" = Bool
True
isReserved FieldName
"foreign" = Bool
True
isReserved FieldName
"if" = Bool
True
isReserved FieldName
"import" = Bool
True
isReserved FieldName
"in" = Bool
True
isReserved FieldName
"infix" = Bool
True
isReserved FieldName
"infixl" = Bool
True
isReserved FieldName
"infixr" = Bool
True
isReserved FieldName
"instance" = Bool
True
isReserved FieldName
"let" = Bool
True
isReserved FieldName
"module" = Bool
True
isReserved FieldName
"newtype" = Bool
True
isReserved FieldName
"of" = Bool
True
isReserved FieldName
"then" = Bool
True
isReserved FieldName
"type" = Bool
True
isReserved FieldName
"where" = Bool
True
isReserved FieldName
"_" = Bool
True
isReserved FieldName
_ = Bool
False
{-# INLINE isReserved #-}