{-# LANGUAGE OverloadedStrings #-}

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

import Data.Char
  ( toLower,
    toUpper,
  )
import qualified Data.Morpheus.Types.Internal.AST as N
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    TypeName,
    packName,
    unpackName,
  )
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 (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
x) Text -> Text -> Text
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 :: [Name t] -> TypeName -> TypeName
camelCaseTypeName [Name t]
list TypeName
name =
  Text -> TypeName
forall (t :: NAME). Text -> Name t
packName (Text -> TypeName) -> Text -> TypeName
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    (Name t -> Text) -> [Name t] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
capitalize (Text -> Text) -> (Name t -> Text) -> Name t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name t -> Text
forall (t :: NAME). Name t -> Text
unpackName) ([Name t]
list [Name t] -> [Name t] -> [Name t]
forall a. Semigroup a => a -> a -> a
<> [TypeName -> Name t
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 -> Text
capitalize (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ TypeName -> Text
forall (t :: NAME). Name t -> Text
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 =
  Text -> FieldName
forall (t :: NAME). Text -> Name t
packName (Text -> FieldName) -> Text -> FieldName
forall a b. (a -> b) -> a -> b
$
    Text -> Text
uncapitalize (TypeName -> Text
forall (t :: NAME). Name t -> Text
unpackName TypeName
nSpace)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize (FieldName -> Text
forall (t :: NAME). Name t -> Text
unpackName FieldName
name)

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