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

    , classConstraint
    , typeConstraint
    , safeCast

    , hyphensToCamelCase
    , underscoresToCamelCase

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

    , signalHaskellName
    , signalInfoName

    , submoduleLocation
    , moduleLocation
    , qualifiedAPI
    , qualifiedSymbol
    , normalizedAPIName

    , hackageModuleLink
    , haddockSignalAnchor
    , haddockAttrAnchor
    ) 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, findAPIByName, config)
import Data.GI.CodeGen.Config (Config(..))
import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath, dotModulePath)
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 e Text
classConstraint :: forall e. Name -> CodeGen e Text
classConstraint n :: Name
n@(Name Text
_ Text
s) = Text -> Name -> CodeGen e Text
forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text
"Is" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s) Name
n

-- | Return a qualified form of the function mapping instances of
-- @IsX@ to haskell values of type @X@.
safeCast :: Name -> CodeGen e Text
safeCast :: forall e. Name -> CodeGen e Text
safeCast n :: Name
n@(Name Text
_ Text
s) = Text -> Name -> CodeGen e Text
forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text
"to" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst 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 e Text
typeConstraint :: forall e. Type -> CodeGen e Text
typeConstraint (TInterface Name
n) = Name -> CodeGen e Text
forall e. Name -> CodeGen e Text
classConstraint Name
n
typeConstraint Type
t = [Char] -> CodeGen e Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> CodeGen e Text) -> [Char] -> CodeGen 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

-- | Obtain the absolute location of the module where the given `API`
-- lives.
moduleLocation :: Name -> API -> ModulePath
moduleLocation :: Name -> API -> ModulePath
moduleLocation Name
n API
api =
  (ModulePath
"GI" ModulePath -> Text -> ModulePath
/. Text -> Text
ucFirst (Name -> Text
namespace Name
n)) ModulePath -> ModulePath -> ModulePath
forall a. Semigroup a => a -> a -> a
<> Name -> API -> ModulePath
submoduleLocation Name
n API
api

-- | 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 e Text
qualifiedAPI :: forall e. API -> Name -> CodeGen e 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 e Text
forall e. ModulePath -> Name -> CodeGen e 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 e Text
qualifiedSymbol :: forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol Text
s n :: Name
n@(Name Text
ns Text
_) = do
  API
api <- Type -> CodeGen e API
forall e. HasCallStack => Type -> CodeGen e API
getAPI (Name -> Type
TInterface Name
n)
  ModulePath -> Name -> CodeGen e Text
forall e. ModulePath -> Name -> CodeGen e 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
    | Arg -> Text
argCName Arg
arg Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"_" = Text
"_'"  -- "_" denotes a hole, so we need to escape it
    | 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 e Text
signalInfoName :: forall e. Name -> Signal -> CodeGen e 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 e Text
forall e. Text -> Name -> CodeGen e 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 = case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
sn of
                         [] -> Text
""  -- Won't happen due to the
                                   -- definition of T.split, but GHC
                                   -- does not know this.
                         Text
w:[Text]
ws -> 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)

-- | Return a link to the hackage package for the given name. Note
-- that the generated link will only be valid if the name belongs to
-- the binding which is currently being generated.
hackageModuleLink :: Name -> CodeGen e Text
hackageModuleLink :: forall e. Name -> CodeGen e Text
hackageModuleLink Name
n = do
  API
api <- Name -> CodeGen e API
forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
n
  Config
cfg <- CodeGen e Config
forall e. CodeGen e Config
config
  let location :: Text
location = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"." Text
"-" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
n API
api)
      pkg :: Text
pkg = Config -> Text
ghcPkgName Config
cfg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Config -> Text
ghcPkgVersion Config
cfg
  Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> CodeGen e Text) -> Text -> CodeGen e Text
forall a b. (a -> b) -> a -> b
$ Text
"https://hackage.haskell.org/package/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/docs/"
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
location Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".html"

-- | Prefix in Haddock for the signal anchor.
haddockSignalAnchor :: Text
haddockSignalAnchor :: Text
haddockSignalAnchor = Text
"g:signal:"

-- | Prefix in Haddock for the attribute anchor.
haddockAttrAnchor :: Text
haddockAttrAnchor :: Text
haddockAttrAnchor = Text
"g:attr:"