{-# LANGUAGE ViewPatterns #-}
module Data.GI.CodeGen.SymbolNaming
    ( lowerName
    , lowerSymbol
    , upperName
    , escapedArgName

    , classConstraint
    , typeConstraint

    , hyphensToCamelCase
    , underscoresToCamelCase

    , callbackCType
    , callbackHTypeWithClosures
    , callbackDropClosures
    , callbackDynamicWrapper
    , callbackWrapperAllocator
    , callbackHaskellToForeign
    , callbackHaskellToForeignWithClosures
    , callbackClosureGenerator

    , signalHaskellName
    , signalInfoName

    , submoduleLocation
    , qualifiedAPI
    , qualifiedSymbol
    , normalizedAPIName
    ) where

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code (CodeGen, qualified, getAPI)
import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath)
import Data.GI.CodeGen.Type (Type(TInterface))
import Data.GI.CodeGen.Util (lcFirst, ucFirst, modifyQualified)

-- | Return a qualified form of the constraint for the given name
-- (which should correspond to a valid `TInterface`).
classConstraint :: Name -> CodeGen Text
classConstraint :: Name -> CodeGen Text
classConstraint n :: Name
n@(Name Text
_ Text
s) = Text -> Name -> CodeGen Text
qualifiedSymbol (Text
"Is" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s) Name
n

-- | Same as `classConstraint`, but applicable directly to a type. The
-- type should be a `TInterface`, otherwise an error will be raised.
typeConstraint :: Type -> CodeGen Text
typeConstraint :: Type -> CodeGen Text
typeConstraint (TInterface Name
n) = Name -> CodeGen Text
classConstraint Name
n
typeConstraint Type
t = [Char] -> BaseCodeGen e Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> BaseCodeGen e Text) -> [Char] -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Class constraint for non-interface type: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t

-- | Foreign type associated with a callback type. It can be passed in
-- qualified.
callbackCType :: Text -> Text
callbackCType :: Text -> Text
callbackCType = (Text -> Text) -> Text -> Text
modifyQualified (Text
"C_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | Haskell type exposing the closure arguments, which are generally
-- elided.
callbackHTypeWithClosures :: Text -> Text
callbackHTypeWithClosures :: Text -> Text
callbackHTypeWithClosures = (Text -> Text) -> Text -> Text
modifyQualified (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_WithClosures")

-- | The name of the dynamic wrapper for the given callback type. It
-- can be passed in qualified.
callbackDynamicWrapper :: Text -> Text
callbackDynamicWrapper :: Text -> Text
callbackDynamicWrapper = (Text -> Text) -> Text -> Text
modifyQualified (Text
"dynamic_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | The name of the Haskell to foreign wrapper for the given callback
-- type. It can be passed in qualified.
callbackHaskellToForeign :: Text -> Text
callbackHaskellToForeign :: Text -> Text
callbackHaskellToForeign = (Text -> Text) -> Text -> Text
modifyQualified (Text
"wrap_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | The name of the Haskell to foreign wrapper for the given callback
-- type, keeping the closure arguments (we usually elide them). The
-- callback type can be passed in qualified.
callbackHaskellToForeignWithClosures :: Text -> Text
callbackHaskellToForeignWithClosures :: Text -> Text
callbackHaskellToForeignWithClosures = (Text -> Text) -> Text -> Text
modifyQualified (Text
"with_closures_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | The name of a function which takes a callback without closure
-- arguments, and generates a function which does accep the closures,
-- but simply ignores them.
callbackDropClosures :: Text -> Text
callbackDropClosures :: Text -> Text
callbackDropClosures = (Text -> Text) -> Text -> Text
modifyQualified (Text
"drop_closures_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | The name for the foreign wrapper allocator (@foreign import
-- "wrapper" ...@) for the given callback type. It can be passed in
-- qualified.
callbackWrapperAllocator :: Text -> Text
callbackWrapperAllocator :: Text -> Text
callbackWrapperAllocator = (Text -> Text) -> Text -> Text
modifyQualified (Text
"mk_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | The name for the closure generator for the given callback
-- type. It can be passed in qualified.
callbackClosureGenerator :: Text -> Text
callbackClosureGenerator :: Text -> Text
callbackClosureGenerator = (Text -> Text) -> Text -> Text
modifyQualified (Text
"genClosure_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | Move leading underscores to the end.
--
-- === Examples
-- >>> sanitize "_Value_Data_Union"
-- "Value_Data_Union_"
sanitize :: Text -> Text
sanitize :: Text -> Text
sanitize (Text -> Maybe (Char, Text)
T.uncons -> Just (Char
'_', Text
xs)) = Text -> Text
sanitize Text
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
sanitize Text
xs = Text
xs

-- | Same as `lowerSymbol`, but accepts a `Name`. The namespace part
-- of the name will be discarded.
--
-- === __Examples__
-- >>> lowerName (Name "Gtk" "main_quit")
-- "mainQuit"
lowerName :: Name -> Text
lowerName :: Name -> Text
lowerName (Name Text
_ Text
s) = Text -> Text
lowerSymbol Text
s

-- | Turn the given identifier into camelCase, starting with a
-- lowercase letter.
--
-- === __Examples__
-- >>> lowerSymbol "main_quit"
-- "mainQuit"
lowerSymbol :: Text -> Text
lowerSymbol :: Text -> Text
lowerSymbol Text
s = case Text -> Text
underscoresToCamelCase (Text -> Text
sanitize Text
s) of
                  Text
"" -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"empty name!!"
                  Text
n -> Text -> Text
lcFirst Text
n

-- | Turn the given `Name` into CamelCase, starting with a capital letter.
--
-- === __Examples__
-- >>> upperName (Name "Foo" "bar_baz")
-- "BarBaz"
upperName :: Name -> Text
upperName :: Name -> Text
upperName (Name Text
_ Text
s) = Text -> Text
underscoresToCamelCase (Text -> Text
sanitize Text
s)

-- | Construct the submodule path where the given API element will
-- live. This is the path relative to the root for the corresponding
-- namespace. I.e. the "GI.Gtk" part is not prepended.
submoduleLocation :: Name -> API -> ModulePath
submoduleLocation :: Name -> API -> ModulePath
submoduleLocation Name
_ (APIConst Constant
_) = ModulePath
"Constants"
submoduleLocation Name
_ (APIFunction Function
_) = ModulePath
"Functions"
submoduleLocation Name
_ (APICallback Callback
_) = ModulePath
"Callbacks"
submoduleLocation Name
_ (APIEnum Enumeration
_) = ModulePath
"Enums"
submoduleLocation Name
_ (APIFlags Flags
_) = ModulePath
"Flags"
submoduleLocation Name
n (APIInterface Interface
_) = ModulePath
"Interfaces" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n
submoduleLocation Name
n (APIObject Object
_) = ModulePath
"Objects" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n
submoduleLocation Name
n (APIStruct Struct
_) = ModulePath
"Structs" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n
submoduleLocation Name
n (APIUnion Union
_) = ModulePath
"Unions" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n

-- | Construct the Haskell version of the name associated to the given
-- API.
normalizedAPIName :: API -> Name -> Name
normalizedAPIName :: API -> Name -> Name
normalizedAPIName (APIConst Constant
_) (Name Text
ns Text
name) = Text -> Text -> Name
Name Text
ns (Text -> Text
ucFirst Text
name)
normalizedAPIName (APIFunction Function
_) Name
n = Name
n
normalizedAPIName (APICallback Callback
_) n :: Name
n@(Name Text
ns Text
_) = Text -> Text -> Name
Name Text
ns (Name -> Text
upperName Name
n)
normalizedAPIName (APIEnum Enumeration
_) n :: Name
n@(Name Text
ns Text
_) = Text -> Text -> Name
Name Text
ns (Name -> Text
upperName Name
n)
normalizedAPIName (APIFlags Flags
_) n :: Name
n@(Name Text
ns Text
_) = Text -> Text -> Name
Name Text
ns (Name -> Text
upperName Name
n)
normalizedAPIName (APIInterface Interface
_) n :: Name
n@(Name Text
ns Text
_) = Text -> Text -> Name
Name Text
ns (Name -> Text
upperName Name
n)
normalizedAPIName (APIObject Object
_) n :: Name
n@(Name Text
ns Text
_) = Text -> Text -> Name
Name Text
ns (Name -> Text
upperName Name
n)
normalizedAPIName (APIStruct Struct
_) n :: Name
n@(Name Text
ns Text
_) = Text -> Text -> Name
Name Text
ns (Name -> Text
upperName Name
n)
normalizedAPIName (APIUnion Union
_) n :: Name
n@(Name Text
ns Text
_) = Text -> Text -> Name
Name Text
ns (Name -> Text
upperName Name
n)

-- | Return an identifier for the given interface type valid in the current
-- module.
qualifiedAPI :: API -> Name -> CodeGen Text
qualifiedAPI :: API -> Name -> CodeGen Text
qualifiedAPI API
api n :: Name
n@(Name Text
ns Text
_) =
  let normalized :: Name
normalized = API -> Name -> Name
normalizedAPIName API
api Name
n
  in ModulePath -> Name -> CodeGen Text
qualified (Text -> ModulePath
toModulePath (Text -> Text
ucFirst Text
ns) ModulePath -> ModulePath -> ModulePath
forall a. Semigroup a => a -> a -> a
<> Name -> API -> ModulePath
submoduleLocation Name
n API
api) Name
normalized

-- | Construct an identifier for the given symbol in the given API.
qualifiedSymbol :: Text -> Name -> CodeGen Text
qualifiedSymbol :: Text -> Name -> CodeGen Text
qualifiedSymbol Text
s n :: Name
n@(Name Text
ns Text
_) = do
  API
api <- HasCallStack => Type -> CodeGen API
Type -> CodeGen API
getAPI (Name -> Type
TInterface Name
n)
  ModulePath -> Name -> CodeGen Text
qualified (Text -> ModulePath
toModulePath (Text -> Text
ucFirst Text
ns) ModulePath -> ModulePath -> ModulePath
forall a. Semigroup a => a -> a -> a
<> Name -> API -> ModulePath
submoduleLocation Name
n API
api) (Text -> Text -> Name
Name Text
ns Text
s)

-- | Turn a hyphen-separated identifier into camel case.
--
-- === __Examples__
-- >>> hyphensToCamelCase "one-sample-string"
-- "OneSampleString"
hyphensToCamelCase :: Text -> Text
hyphensToCamelCase :: Text -> Text
hyphensToCamelCase = [Text] -> Text
T.concat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
ucFirst ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')

-- | Similarly to `hyphensToCamelCase`, turn a name
-- separated_by_underscores into CamelCase. We preserve final and
-- initial underscores, and n>1 consecutive underscores are
-- transformed into n-1 underscores.
--
-- === __Examples__
-- >>> underscoresToCamelCase "sample_id"
-- "SampleId"
--
-- >>> underscoresToCamelCase "_internal_id_"
-- "_InternalId_"
--
-- >>> underscoresToCamelCase "multiple___underscores"
-- "Multiple__Underscores"
underscoresToCamelCase :: Text -> Text
underscoresToCamelCase :: Text -> Text
underscoresToCamelCase =
    [Text] -> Text
T.concat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
normalize ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
ucFirst ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
        where normalize :: Text -> Text
              normalize :: Text -> Text
normalize Text
"" = Text
"_"
              normalize Text
s = Text
s

-- | Name for the given argument, making sure it is a valid Haskell
-- argument name (and escaping it if not).
escapedArgName :: Arg -> Text
escapedArgName :: Arg -> Text
escapedArgName Arg
arg
    | Text
"_" Text -> Text -> Bool
`T.isPrefixOf` Arg -> Text
argCName Arg
arg = Arg -> Text
argCName Arg
arg
    | Bool
otherwise =
        Text -> Text
escapeReserved (Text -> Text) -> (Arg -> Text) -> Arg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
lcFirst (Text -> Text) -> (Arg -> Text) -> Arg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
underscoresToCamelCase (Text -> Text) -> (Arg -> Text) -> Arg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Text
argCName (Arg -> Text) -> Arg -> Text
forall a b. (a -> b) -> a -> b
$ Arg
arg

-- | Reserved symbols, either because they are Haskell syntax or
-- because the clash with symbols in scope for the generated bindings.
escapeReserved :: Text -> Text
escapeReserved :: Text -> Text
escapeReserved Text
"type" = Text
"type_"
escapeReserved Text
"in" = Text
"in_"
escapeReserved Text
"data" = Text
"data_"
escapeReserved Text
"instance" = Text
"instance_"
escapeReserved Text
"where" = Text
"where_"
escapeReserved Text
"module" = Text
"module_"
-- Reserved because we generate code that uses these names.
escapeReserved Text
"result" = Text
"result_"
escapeReserved Text
"return" = Text
"return_"
escapeReserved Text
"show" = Text
"show_"
escapeReserved Text
"fromEnum" = Text
"fromEnum_"
escapeReserved Text
"toEnum" = Text
"toEnum_"
escapeReserved Text
"undefined" = Text
"undefined_"
escapeReserved Text
"error" = Text
"error_"
escapeReserved Text
"map" = Text
"map_"
escapeReserved Text
"length" = Text
"length_"
escapeReserved Text
"mapM" = Text
"mapM__"
escapeReserved Text
"mapM_" = Text
"mapM___"
escapeReserved Text
"fromIntegral" = Text
"fromIntegral_"
escapeReserved Text
"realToFrac" = Text
"realToFrac_"
escapeReserved Text
"peek" = Text
"peek_"
escapeReserved Text
"poke" = Text
"poke_"
escapeReserved Text
"sizeOf" = Text
"sizeOf_"
escapeReserved Text
"when" = Text
"when_"
escapeReserved Text
"default" = Text
"default_"
escapeReserved Text
s
    | Text
"set_" Text -> Text -> Bool
`T.isPrefixOf` Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
    | Text
"get_" Text -> Text -> Bool
`T.isPrefixOf` Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
    | Bool
otherwise = Text
s

-- | Qualified name for the "(sigName, info)" tag for a given signal.
signalInfoName :: Name -> Signal -> CodeGen Text
signalInfoName :: Name -> Signal -> CodeGen Text
signalInfoName Name
n Signal
signal = do
  let infoName :: Text
infoName = Name -> Text
upperName Name
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
ucFirst (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
signalHaskellName (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName) Signal
signal
                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"SignalInfo"
  Text -> Name -> CodeGen Text
qualifiedSymbol Text
infoName Name
n

-- | Return the name for the signal in Haskell CamelCase conventions.
signalHaskellName :: Text -> Text
signalHaskellName :: Text -> Text
signalHaskellName Text
sn = let (Text
w:[Text]
ws) = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
sn
                       in Text
w Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
ucFirst [Text]
ws)